diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index 2b1208266c6..bfe54fd7d87 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -5,6 +5,7 @@ 10a14397e7295f79bb65ff505e52895f4864270a c7a5ac671338998395c1d12f04a0f9190d89e3af 9985a2c27b1b292ca50489cf439193a8caa1249c +d1b1ef56393524a2d37abec78dbb0832e42c6698 # 2022 ######################################## diff --git a/.github/workflows/linting.yml b/.github/workflows/linting.yml index 47595b1f527..3f0fb4c5c14 100644 --- a/.github/workflows/linting.yml +++ b/.github/workflows/linting.yml @@ -16,8 +16,17 @@ jobs: Cabal/**/*.hs Cabal-syntax/**/*.hs Cabal-install/**/*.hs + Cabal-QuickCheck/**/*.hs + Cabal-described/**/*.hs + Cabal-tests/**/*.hs + Cabal-tree-diff/**/*.hs + cabal-benchmarks/**/*.hs + cabal-dev-scripts/**/*.hs + cabal-install-solver/**/*.hs + solver-benchmarks/**/*.hs !Cabal-syntax/src/Distribution/Fields/Lexer.hs !Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs !Cabal-syntax/src/Distribution/SPDX/LicenseId.hs !Cabal/src/Distribution/Simple/Build/Macros/Z.hs !Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs + !cabal-testsuite diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs b/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs index 00f32bc0d70..9f3caaf18b1 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} -module Test.QuickCheck.GenericArbitrary ( - genericArbitrary, - GArbitrary, -) where + +module Test.QuickCheck.GenericArbitrary + ( genericArbitrary + , GArbitrary + ) where import GHC.Generics import Test.QuickCheck @@ -19,31 +20,31 @@ genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a genericArbitrary = fmap to garbitrary class GArbitrary f where - garbitrary :: Gen (f ()) + garbitrary :: Gen (f ()) class GArbitrarySum f where - garbitrarySum :: [Gen (f ())] + garbitrarySum :: [Gen (f ())] class GArbitraryProd f where - garbitraryProd :: Gen (f ()) + garbitraryProd :: Gen (f ()) instance (GArbitrarySum f, i ~ D) => GArbitrary (M1 i c f) where - garbitrary = fmap M1 (oneof garbitrarySum) + garbitrary = fmap M1 (oneof garbitrarySum) instance (GArbitraryProd f, i ~ C) => GArbitrarySum (M1 i c f) where - garbitrarySum = [fmap M1 garbitraryProd] + garbitrarySum = [fmap M1 garbitraryProd] instance (GArbitrarySum f, GArbitrarySum g) => GArbitrarySum (f :+: g) where - garbitrarySum = map (fmap L1) garbitrarySum ++ map (fmap R1) garbitrarySum + garbitrarySum = map (fmap L1) garbitrarySum ++ map (fmap R1) garbitrarySum instance (GArbitraryProd f, i ~ S) => GArbitraryProd (M1 i c f) where - garbitraryProd = fmap M1 garbitraryProd + garbitraryProd = fmap M1 garbitraryProd instance GArbitraryProd U1 where - garbitraryProd = pure U1 + garbitraryProd = pure U1 instance (GArbitraryProd f, GArbitraryProd g) => GArbitraryProd (f :*: g) where - garbitraryProd = (:*:) <$> garbitraryProd <*> garbitraryProd + garbitraryProd = (:*:) <$> garbitraryProd <*> garbitraryProd -instance (Arbitrary a) => GArbitraryProd (K1 i a) where - garbitraryProd = fmap K1 arbitrary +instance Arbitrary a => GArbitraryProd (K1 i a) where + garbitraryProd = fmap K1 arbitrary diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index 01a5d1d904e..a0746dae1cc 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Test.QuickCheck.Instances.Cabal () where -import Control.Applicative (liftA2) -import Data.Bits (shiftR) -import Data.Char (isAlphaNum, isDigit) -import Data.List (intercalate) -import Data.List.NonEmpty (NonEmpty (..)) +import Control.Applicative (liftA2) +import Data.Bits (shiftR) +import Data.Char (isAlphaNum, isDigit) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) import Distribution.Utils.Generic (lowercase) import Test.QuickCheck @@ -18,18 +19,18 @@ import Data.Bits (popCount) #endif import Distribution.CabalSpecVersion -import Distribution.Compat.NonEmptySet (NonEmptySet) +import Distribution.Compat.NonEmptySet (NonEmptySet) import Distribution.Compiler import Distribution.FieldGrammar.Newtypes import Distribution.ModuleName -import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels) -import Distribution.Simple.Flag (Flag (..)) -import Distribution.Simple.InstallDirs -import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..), DumpBuildInfo) import Distribution.SPDX +import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels) +import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.InstallDirs +import Distribution.Simple.Setup (DumpBuildInfo, HaddockTarget (..), TestShowDetails (..)) import Distribution.System import Distribution.Types.Dependency -import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) +import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName import Distribution.Types.LibraryVisibility @@ -49,7 +50,7 @@ import Distribution.Version import Test.QuickCheck.GenericArbitrary -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.NonEmptySet as NES #if !MIN_VERSION_base(4,8,0) @@ -61,26 +62,27 @@ import Control.Applicative (pure, (<$>), (<*>)) ------------------------------------------------------------------------------- instance Arbitrary CabalSpecVersion where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum instance Arbitrary SpecVersion where - arbitrary = fmap SpecVersion arbitrary + arbitrary = fmap SpecVersion arbitrary ------------------------------------------------------------------------------- -- PackageName and PackageIdentifier ------------------------------------------------------------------------------- instance Arbitrary PackageName where - arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent - where - nameComponent = shortListOf1 5 (elements packageChars) - `suchThat` (liftA2 (&&) (not . all isDigit) (/= "all")) - packageChars = filter isAlphaNum ['\0'..'\127'] + arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent + where + nameComponent = + shortListOf1 5 (elements packageChars) + `suchThat` (liftA2 (&&) (not . all isDigit) (/= "all")) + packageChars = filter isAlphaNum ['\0' .. '\127'] instance Arbitrary PackageIdentifier where - arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary + arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary - shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) + shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) ------------------------------------------------------------------------------- -- Version @@ -89,44 +91,50 @@ instance Arbitrary PackageIdentifier where -- | Does *NOT* generate 'nullVersion' instance Arbitrary Version where arbitrary = do - branch <- smallListOf1 $ - frequency [(3, return 0) - ,(3, return 1) - ,(2, return 2) - ,(2, return 3) - ,(1, return 0xfffd) - ,(1, return 0xfffe) -- max fitting into packed W64 - ,(1, return 0xffff) - ,(1, return 999999998) - ,(1, return 999999999) - ,(1, return 0x10000)] - return (mkVersion branch) + branch <- + smallListOf1 $ + frequency + [ (3, return 0) + , (3, return 1) + , (2, return 2) + , (2, return 3) + , (1, return 0xfffd) + , (1, return 0xfffe) -- max fitting into packed W64 + , (1, return 0xffff) + , (1, return 999999998) + , (1, return 999999999) + , (1, return 0x10000) + ] + return (mkVersion branch) where smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1 - shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver) - , not (null ns) ] + shrink ver = + [ mkVersion ns | ns <- shrink (versionNumbers ver), not (null ns) + ] instance Arbitrary VersionRange where arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt where verRangeExp n - | n > 0 = oneof - [ recurse unionVersionRanges n - , recurse intersectVersionRanges n - ] - | otherwise = oneof - [ return anyVersion - , fmap thisVersion arbitrary - , fmap laterVersion arbitrary - , fmap orLaterVersion arbitrary - , fmap orLaterVersion' arbitrary - , fmap earlierVersion arbitrary - , fmap orEarlierVersion arbitrary - , fmap orEarlierVersion' arbitrary - , fmap withinVersion arbitraryV - , fmap majorBoundVersion arbitrary - ] + | n > 0 = + oneof + [ recurse unionVersionRanges n + , recurse intersectVersionRanges n + ] + | otherwise = + oneof + [ return anyVersion + , fmap thisVersion arbitrary + , fmap laterVersion arbitrary + , fmap orLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap earlierVersion arbitrary + , fmap orEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + , fmap withinVersion arbitraryV + , fmap majorBoundVersion arbitrary + ] recurse mk n = do k <- chooseInt (0, n - 1) @@ -135,18 +143,18 @@ instance Arbitrary VersionRange where arbitraryV :: Gen Version arbitraryV = arbitrary `suchThat` \v -> all (< 999999999) (versionNumbers v) - orLaterVersion' v = - unionVersionRanges (LaterVersion v) (ThisVersion v) + orLaterVersion' v = + unionVersionRanges (LaterVersion v) (ThisVersion v) orEarlierVersion' v = unionVersionRanges (EarlierVersion v) (ThisVersion v) - shrink (ThisVersion v) = map ThisVersion (shrink v) - shrink (LaterVersion v) = map LaterVersion (shrink v) - shrink (EarlierVersion v) = map EarlierVersion (shrink v) - shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) - shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) - shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) - shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) + shrink (ThisVersion v) = map ThisVersion (shrink v) + shrink (LaterVersion v) = map LaterVersion (shrink v) + shrink (EarlierVersion v) = map EarlierVersion (shrink v) + shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) + shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) + shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) + shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b)) instance Arbitrary VersionIntervals where @@ -160,16 +168,16 @@ instance Arbitrary Bound where ------------------------------------------------------------------------------- instance Arbitrary Mixin where - arbitrary = normaliseMixin <$> genericArbitrary - shrink = fmap normaliseMixin . genericShrink + arbitrary = normaliseMixin <$> genericArbitrary + shrink = fmap normaliseMixin . genericShrink instance Arbitrary IncludeRenaming where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary ModuleRenaming where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink ------------------------------------------------------------------------------- -- @@ -178,7 +186,7 @@ instance Arbitrary ModuleRenaming where instance Arbitrary LibraryVisibility where arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] - shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] + shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] shrink LibraryVisibilityPrivate = [] ------------------------------------------------------------------------------- @@ -186,283 +194,319 @@ instance Arbitrary LibraryVisibility where ------------------------------------------------------------------------------- instance Arbitrary ModuleName where - arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp where - comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) - upper = ['A'..'Z'] - moduleChar = [ c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'" ] + arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp + where + comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) + upper = ['A' .. 'Z'] + moduleChar = [c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'"] ------------------------------------------------------------------------------- -- Dependency ------------------------------------------------------------------------------- instance Arbitrary Dependency where - arbitrary = mkDependency - <$> arbitrary - <*> arbitrary - <*> (arbitrary `suchThat` const True) -- should be (not . null) - - shrink (Dependency pn vr lb) = - [ mkDependency pn' vr' lb' - | (pn', vr', lb') <- shrink (pn, vr, lb) - ] + arbitrary = + mkDependency + <$> arbitrary + <*> arbitrary + <*> (arbitrary `suchThat` const True) -- should be (not . null) + + shrink (Dependency pn vr lb) = + [ mkDependency pn' vr' lb' + | (pn', vr', lb') <- shrink (pn, vr, lb) + ] ------------------------------------------------------------------------------- -- PackageVersionConstraint ------------------------------------------------------------------------------- instance Arbitrary PackageVersionConstraint where - arbitrary = PackageVersionConstraint - <$> arbitrary - <*> arbitrary + arbitrary = + PackageVersionConstraint + <$> arbitrary + <*> arbitrary - shrink (PackageVersionConstraint pn vr) = - [ PackageVersionConstraint pn' vr' - | (pn', vr') <- shrink (pn, vr) - ] + shrink (PackageVersionConstraint pn vr) = + [ PackageVersionConstraint pn' vr' + | (pn', vr') <- shrink (pn, vr) + ] ------------------------------------------------------------------------------- -- System ------------------------------------------------------------------------------- instance Arbitrary OS where - arbitrary = elements knownOSs + arbitrary = elements knownOSs instance Arbitrary Arch where - arbitrary = elements knownArches + arbitrary = elements knownArches instance Arbitrary Platform where - arbitrary = Platform <$> arbitrary <*> arbitrary + arbitrary = Platform <$> arbitrary <*> arbitrary ------------------------------------------------------------------------------- -- Various names ------------------------------------------------------------------------------- instance Arbitrary UnqualComponentName where - -- same rules as package names - arbitrary = packageNameToUnqualComponentName <$> arbitrary + -- same rules as package names + arbitrary = packageNameToUnqualComponentName <$> arbitrary instance Arbitrary LibraryName where - arbitrary = oneof - [ LSubLibName <$> arbitrary - , pure LMainLibName - ] + arbitrary = + oneof + [ LSubLibName <$> arbitrary + , pure LMainLibName + ] - shrink (LSubLibName _) = [LMainLibName] - shrink _ = [] + shrink (LSubLibName _) = [LMainLibName] + shrink _ = [] ------------------------------------------------------------------------------- -- option flags ------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (Flag a) where - arbitrary = arbitrary1 + arbitrary = arbitrary1 - shrink NoFlag = [] - shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ] + shrink NoFlag = [] + shrink (Flag x) = NoFlag : [Flag x' | x' <- shrink x] instance Arbitrary1 Flag where - liftArbitrary genA = sized $ \sz -> - if sz <= 0 - then pure NoFlag - else frequency [ (1, pure NoFlag) - , (3, Flag <$> genA) ] + liftArbitrary genA = sized $ \sz -> + if sz <= 0 + then pure NoFlag + else + frequency + [ (1, pure NoFlag) + , (3, Flag <$> genA) + ] ------------------------------------------------------------------------------- -- GPD flags ------------------------------------------------------------------------------- instance Arbitrary FlagName where - arbitrary = mkFlagName <$> frequency + arbitrary = + mkFlagName + <$> frequency [ (20, flagident) - -- special nasty cases - , (1, pure "none") - , (1, pure "any") + , -- special nasty cases + (1, pure "none") + , (1, pure "any") ] - where - flagident = lowercase <$> shortListOf1 5 (elements flagChars) - `suchThat` (("-" /=) . take 1) - flagChars = "-_" ++ ['a'..'z'] + where + flagident = + lowercase + <$> shortListOf1 5 (elements flagChars) + `suchThat` (("-" /=) . take 1) + flagChars = "-_" ++ ['a' .. 'z'] instance Arbitrary FlagAssignment where - arbitrary = mkFlagAssignment <$> arbitrary - shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) + arbitrary = mkFlagAssignment <$> arbitrary + shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) ------------------------------------------------------------------------------- -- Verbosity ------------------------------------------------------------------------------- instance Arbitrary Verbosity where - arbitrary = do - v <- elements [minBound..maxBound] - -- verbose markoutput is left out on purpose - flags <- listOf $ elements - [ verboseCallSite - , verboseCallStack - , verboseNoWrap - , verboseTimestamp - , verboseStderr - ] - return (foldr ($) v flags) + arbitrary = do + v <- elements [minBound .. maxBound] + -- verbose markoutput is left out on purpose + flags <- + listOf $ + elements + [ verboseCallSite + , verboseCallStack + , verboseNoWrap + , verboseTimestamp + , verboseStderr + ] + return (foldr ($) v flags) ------------------------------------------------------------------------------- -- SourceRepo ------------------------------------------------------------------------------- instance Arbitrary RepoType where - arbitrary = elements (KnownRepoType <$> knownRepoTypes) + arbitrary = elements (KnownRepoType <$> knownRepoTypes) instance Arbitrary RepoKind where - arbitrary = elements [RepoHead, RepoThis] + arbitrary = elements [RepoHead, RepoThis] ------------------------------------------------------------------------------- -- SPDX ------------------------------------------------------------------------------- instance Arbitrary LicenseId where - arbitrary = elements $ licenseIdList currentLicenseListVersion + arbitrary = elements $ licenseIdList currentLicenseListVersion instance Arbitrary LicenseExceptionId where - arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion + arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion currentLicenseListVersion :: LicenseListVersion currentLicenseListVersion = cabalSpecVersionToSPDXListVersion cabalSpecLatest instance Arbitrary LicenseRef where - arbitrary = mkLicenseRef' <$> ids' <*> ids - where - ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-" - ids' = oneof [ pure Nothing, Just <$> ids ] + arbitrary = mkLicenseRef' <$> ids' <*> ids + where + ids = listOf1 $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_-" + ids' = oneof [pure Nothing, Just <$> ids] instance Arbitrary SimpleLicenseExpression where - arbitrary = oneof - [ ELicenseId <$> arbitrary - , ELicenseIdPlus <$> arbitrary - , ELicenseRef <$> arbitrary - ] + arbitrary = + oneof + [ ELicenseId <$> arbitrary + , ELicenseIdPlus <$> arbitrary + , ELicenseRef <$> arbitrary + ] instance Arbitrary LicenseExpression where - arbitrary = sized arb - where - arb n - | n <= 0 = ELicense <$> arbitrary <*> pure Nothing - | otherwise = oneof - [ ELicense <$> arbitrary <*> arbitrary - , EAnd <$> arbA <*> arbB - , EOr <$> arbA <*> arbB - ] - where - m = n `div` 2 - arbA = arb m - arbB = arb (n - m) - - shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) - shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) - shrink _ = [] + arbitrary = sized arb + where + arb n + | n <= 0 = ELicense <$> arbitrary <*> pure Nothing + | otherwise = + oneof + [ ELicense <$> arbitrary <*> arbitrary + , EAnd <$> arbA <*> arbB + , EOr <$> arbA <*> arbB + ] + where + m = n `div` 2 + arbA = arb m + arbB = arb (n - m) + + shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) + shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) + shrink _ = [] ------------------------------------------------------------------------------- -- Compiler ------------------------------------------------------------------------------- instance Arbitrary CompilerFlavor where - arbitrary = elements knownCompilerFlavors + arbitrary = elements knownCompilerFlavors instance Arbitrary CompilerId where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary ProfDetailLevel where - arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] + arbitrary = elements [d | (_, _, d) <- knownProfDetailLevels] instance Arbitrary OptimisationLevel where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] instance Arbitrary DebugInfoLevel where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] ------------------------------------------------------------------------------- -- NonEmptySet ------------------------------------------------------------------------------- instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where - arbitrary = mk <$> arbitrary <*> arbitrary where - mk x xs = NES.fromNonEmpty (x :| xs) + arbitrary = mk <$> arbitrary <*> arbitrary + where + mk x xs = NES.fromNonEmpty (x :| xs) - shrink nes = case NES.toNonEmpty nes of - x :| xs -> map mk (shrink (x, xs)) - where - mk (x,xs) = NES.fromNonEmpty (x :| xs) + shrink nes = case NES.toNonEmpty nes of + x :| xs -> map mk (shrink (x, xs)) + where + mk (x, xs) = NES.fromNonEmpty (x :| xs) ------------------------------------------------------------------------------- -- NubList ------------------------------------------------------------------------------- instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where - arbitrary = toNubList <$> arbitrary - shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] - -- try empty, otherwise don't shrink as it can loop + arbitrary = toNubList <$> arbitrary + shrink xs = [toNubList [] | (not . null) (fromNubList xs)] + +-- try empty, otherwise don't shrink as it can loop ------------------------------------------------------------------------------- -- InstallDirs ------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (InstallDirs a) where - arbitrary = InstallDirs - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 + arbitrary = + InstallDirs + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 4 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 8 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 12 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 16 instance Arbitrary PathTemplate where - arbitrary = toPathTemplate <$> arbitraryShortToken - shrink t = [ toPathTemplate s - | s <- shrink (fromPathTemplate t) - , not (null s) ] + arbitrary = toPathTemplate <$> arbitraryShortToken + shrink t = + [ toPathTemplate s + | s <- shrink (fromPathTemplate t) + , not (null s) + ] ------------------------------------------------------------------------------- -- Pkgconfig ------------------------------------------------------------------------------- instance Arbitrary PkgconfigVersion where - arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where - elems = frequency - [ (2, pure ".") - , (1, pure "-") - , (5, listOf1 $ elements ['0' .. '9']) - , (1, listOf1 $ elements ['A' .. 'Z']) - , (1, listOf1 $ elements ['a' .. 'z']) - ] - - -- disallow versions starting with dash - dropDash = notEmpty . dropWhile (== '-') - notEmpty x - | null x = "0" - | otherwise = x + arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems + where + elems = + frequency + [ (2, pure ".") + , (1, pure "-") + , (5, listOf1 $ elements ['0' .. '9']) + , (1, listOf1 $ elements ['A' .. 'Z']) + , (1, listOf1 $ elements ['a' .. 'z']) + ] + + -- disallow versions starting with dash + dropDash = notEmpty . dropWhile (== '-') + notEmpty x + | null x = "0" + | otherwise = x instance Arbitrary PkgconfigVersionRange where arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt where verRangeExp n - | n > 0 = oneof - [ recurse PcUnionVersionRanges n - , recurse PcIntersectVersionRanges n - ] - | otherwise = oneof - [ return PcAnyVersion - , fmap PcThisVersion arbitrary - , fmap PcLaterVersion arbitrary - , fmap PcOrLaterVersion arbitrary - , fmap orLaterVersion' arbitrary - , fmap PcEarlierVersion arbitrary - , fmap PcOrEarlierVersion arbitrary - , fmap orEarlierVersion' arbitrary - ] + | n > 0 = + oneof + [ recurse PcUnionVersionRanges n + , recurse PcIntersectVersionRanges n + ] + | otherwise = + oneof + [ return PcAnyVersion + , fmap PcThisVersion arbitrary + , fmap PcLaterVersion arbitrary + , fmap PcOrLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap PcEarlierVersion arbitrary + , fmap PcOrEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + ] recurse mk n = do k <- chooseInt (0, n - 1) liftA2 mk (verRangeExp k) (verRangeExp (n - k - 1)) - orLaterVersion' v = - PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) + orLaterVersion' v = + PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) orEarlierVersion' v = PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) @@ -471,27 +515,29 @@ instance Arbitrary PkgconfigVersionRange where ------------------------------------------------------------------------------- instance Arbitrary HaddockTarget where - arbitrary = elements [ForHackage, ForDevelopment] + arbitrary = elements [ForHackage, ForDevelopment] instance Arbitrary TestShowDetails where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum ------------------------------------------------------------------------------- -- PackageDB ------------------------------------------------------------------------------- instance Arbitrary PackageDB where - arbitrary = oneof [ pure GlobalPackageDB - , pure UserPackageDB - , SpecificPackageDB <$> arbitraryShortPath - ] + arbitrary = + oneof + [ pure GlobalPackageDB + , pure UserPackageDB + , SpecificPackageDB <$> arbitraryShortPath + ] ------------------------------------------------------------------------------- -- DumpBuildInfo ------------------------------------------------------------------------------- instance Arbitrary DumpBuildInfo where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum ------------------------------------------------------------------------------- -- Helpers @@ -499,8 +545,8 @@ instance Arbitrary DumpBuildInfo where shortListOf1 :: Int -> Gen a -> Gen [a] shortListOf1 bound gen = sized $ \n -> do - k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) - vectorOf k gen + k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) + vectorOf k gen arbitraryShortToken :: Gen String arbitraryShortToken = arbitraryShortStringWithout "{}[]" @@ -510,16 +556,15 @@ arbitraryShortPath = arbitraryShortStringWithout "{}[]," arbitraryShortStringWithout :: String -> Gen String arbitraryShortStringWithout excludeChars = - shortListOf1 5 $ elements [c | c <- ['#' .. '~' ], c `notElem` excludeChars ] + shortListOf1 5 $ elements [c | c <- ['#' .. '~'], c `notElem` excludeChars] --- | intSqrt :: Int -> Int intSqrt 0 = 0 intSqrt 1 = 1 intSqrt n = case compare n 0 of - LT -> 0 -- whatever - EQ -> 0 - GT -> iter (iter guess) -- two iterations give good results + LT -> 0 -- whatever + EQ -> 0 + GT -> iter (iter guess) -- two iterations give good results where iter :: Int -> Int iter 0 = 0 diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index d095040a87c..376c630d10c 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -1,122 +1,145 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Described ( - Described (..), - describeDoc, + +module Distribution.Described + ( Described (..) + , describeDoc + -- * Regular expressions - GrammarRegex (..), - reEps, - reChar, - reChars, - reMunchCS, - reMunch1CS, + , GrammarRegex (..) + , reEps + , reChar + , reChars + , reMunchCS + , reMunch1CS + -- * Variables - reVar0, - reVar1, + , reVar0 + , reVar1 + -- * Special expressions - reDot, - reComma, - reSpacedComma, - reHsString, - reUnqualComponent, - -- * - describeFlagAssignmentNonEmpty, + , reDot + , reComma + , reSpacedComma + , reHsString + , reUnqualComponent + , describeFlagAssignmentNonEmpty + -- * Lists - reSpacedList, - reCommaList, - reCommaNonEmpty, - reOptCommaList, + , reSpacedList + , reCommaList + , reCommaNonEmpty + , reOptCommaList + -- * Character Sets - csChar, - csAlpha, - csAlphaNum, - csUpper, - csNotSpace, - csNotSpaceOrComma, + , csChar + , csAlpha + , csAlphaNum + , csUpper + , csNotSpace + , csNotSpaceOrComma + -- * tasty - testDescribed, - ) where + , testDescribed + ) where import Prelude - (Bool (..), Char, Either (..), Enum (..), Eq (..), Ord (..), Show (..), String, elem, fmap, foldr, id, map, maybe, otherwise, return, undefined, ($), - (.)) + ( Bool (..) + , Char + , Either (..) + , Enum (..) + , Eq (..) + , Ord (..) + , Show (..) + , String + , elem + , fmap + , foldr + , id + , map + , maybe + , otherwise + , return + , undefined + , ($) + , (.) + ) import Data.Functor.Identity (Identity (..)) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.String (IsString (..)) -import Data.Typeable (Typeable, typeOf) -import Data.Void (Void, vacuous) -import Test.QuickCheck (Arbitrary (..), Property, counterexample) -import Test.Tasty (TestTree, testGroup) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Typeable (Typeable, typeOf) +import Data.Void (Void, vacuous) +import Test.QuickCheck (Arbitrary (..), Property, counterexample) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Distribution.Compat.Semigroup (Semigroup (..)) -import Distribution.Parsec (Parsec, eitherParsec) -import Distribution.Pretty (Pretty, prettyShow) +import Distribution.Parsec (Parsec, eitherParsec) +import Distribution.Pretty (Pretty, prettyShow) import qualified Distribution.Utils.CharSet as CS -import qualified RERE as RE -import qualified RERE.CharSet as RE -import qualified Text.PrettyPrint as PP +import qualified RERE as RE +import qualified RERE.CharSet as RE +import qualified Text.PrettyPrint as PP import Distribution.Utils.GrammarRegex -- Types import Distribution.Compat.Newtype -import Distribution.Compiler (CompilerFlavor, CompilerId, knownCompilerFlavors) +import Distribution.Compiler (CompilerFlavor, CompilerId, knownCompilerFlavors) import Distribution.FieldGrammar.Newtypes -import Distribution.ModuleName (ModuleName) -import Distribution.System (Arch, OS, knownArches, knownOSs) -import Distribution.Types.AbiDependency (AbiDependency) -import Distribution.Types.AbiHash (AbiHash) -import Distribution.Types.BenchmarkType (BenchmarkType) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExecutableScope (ExecutableScope) -import Distribution.Types.ExeDependency (ExeDependency) -import Distribution.Types.ExposedModule (ExposedModule) -import Distribution.Types.Flag (FlagAssignment, FlagName) -import Distribution.Types.ForeignLib (LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) -import Distribution.Types.IncludeRenaming (IncludeRenaming) -import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.ModuleReexport (ModuleReexport) -import Distribution.Types.ModuleRenaming (ModuleRenaming) -import Distribution.Types.MungedPackageName (MungedPackageName) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) +import Distribution.ModuleName (ModuleName) +import Distribution.System (Arch, OS, knownArches, knownOSs) +import Distribution.Types.AbiDependency (AbiDependency) +import Distribution.Types.AbiHash (AbiHash) +import Distribution.Types.BenchmarkType (BenchmarkType) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.ExecutableScope (ExecutableScope) +import Distribution.Types.ExposedModule (ExposedModule) +import Distribution.Types.Flag (FlagAssignment, FlagName) +import Distribution.Types.ForeignLib (LibVersionInfo) +import Distribution.Types.ForeignLibOption (ForeignLibOption) +import Distribution.Types.ForeignLibType (ForeignLibType) +import Distribution.Types.IncludeRenaming (IncludeRenaming) +import Distribution.Types.LegacyExeDependency (LegacyExeDependency) +import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.ModuleReexport (ModuleReexport) +import Distribution.Types.ModuleRenaming (ModuleRenaming) +import Distribution.Types.MungedPackageName (MungedPackageName) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency) -import Distribution.Types.SourceRepo (RepoType) -import Distribution.Types.TestType (TestType) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, VersionRange) -import Language.Haskell.Extension (Extension, Language) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency) +import Distribution.Types.SourceRepo (RepoType) +import Distribution.Types.TestType (TestType) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (Verbosity) +import Distribution.Version (Version, VersionRange) +import Language.Haskell.Extension (Extension, Language) -- | Class describing the pretty/parsec format of a. class (Pretty a, Parsec a) => Described a where - -- | A pretty document of "regex" describing the field format - describe :: proxy a -> GrammarRegex void + -- | A pretty document of "regex" describing the field format + describe :: proxy a -> GrammarRegex void -- | Pretty-print description. -- -- >>> describeDoc ([] :: [Bool]) -- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\} --- describeDoc :: Described a => proxy a -> PP.Doc describeDoc p = regexDoc (describe p) instance Described Bool where - describe _ = REUnion ["True", "False"] + describe _ = REUnion ["True", "False"] instance Described a => Described (Identity a) where - describe _ = describe ([] :: [a]) + describe _ = describe ([] :: [a]) ------------------------------------------------------------------------------- -- Lists @@ -139,11 +162,13 @@ reOptCommaList = REOptCommaList ------------------------------------------------------------------------------- reHsString :: GrammarRegex a -reHsString = RENamed "hs-string" impl where +reHsString = RENamed "hs-string" impl + where impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"' strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\") - escChar = REUnion + escChar = + REUnion [ "\\&" , "\\\\" , REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO @@ -155,11 +180,12 @@ reHsString = RENamed "hs-string" impl where ] reUnqualComponent :: GrammarRegex a -reUnqualComponent = RENamed "unqual-name" $ +reUnqualComponent = + RENamed "unqual-name" $ REMunch1 (reChar '-') component where - component - = REMunch reEps (RECharSet csAlphaNum) + component = + REMunch reEps (RECharSet csAlphaNum) -- currently the parser accepts "csAlphaNum `difference` "0123456789" -- which is larger set than CS.alpha -- @@ -203,7 +229,8 @@ csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ',' ------------------------------------------------------------------------------- describeFlagAssignmentNonEmpty :: GrammarRegex void -describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $ +describeFlagAssignmentNonEmpty = + REMunch1 RESpaces1 $ REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) ------------------------------------------------------------------------------- @@ -211,50 +238,51 @@ describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $ ------------------------------------------------------------------------------- convert :: GrammarRegex Void -> RE.RE Void -convert = go id . vacuous where +convert = go id . vacuous + where go :: Ord b => (a -> b) -> GrammarRegex a -> RE.RE b - go f (REAppend rs) = foldr (\r acc -> go f r <> acc) RE.Eps rs - go f (REUnion rs) = foldr (\r acc -> go f r RE.\/ acc) RE.Null rs - go _ (RECharSet cs) = RE.Ch (convertCS cs) - go _ (REString str) = RE.string_ str - - go f (REMunch sep r) = RE.Eps RE.\/ r' <> RE.star_ (sep' <> r') where + go f (REAppend rs) = foldr (\r acc -> go f r <> acc) RE.Eps rs + go f (REUnion rs) = foldr (\r acc -> go f r RE.\/ acc) RE.Null rs + go _ (RECharSet cs) = RE.Ch (convertCS cs) + go _ (REString str) = RE.string_ str + go f (REMunch sep r) = RE.Eps RE.\/ r' <> RE.star_ (sep' <> r') + where sep' = go f sep - r' = go f r - go f (REMunch1 sep r) = r' <> RE.star_ (sep' <> r') where + r' = go f r + go f (REMunch1 sep r) = r' <> RE.star_ (sep' <> r') + where sep' = go f sep - r' = go f r + r' = go f r go f (REMunchR n sep r) - | n <= 0 = RE.Eps - | otherwise = RE.Eps RE.\/ r' <> go' (pred n) + | n <= 0 = RE.Eps + | otherwise = RE.Eps RE.\/ r' <> go' (pred n) where sep' = go f sep - r' = go f r - - go' m | m <= 0 = RE.Eps - | otherwise = RE.Eps RE.\/ sep' <> r' <> go' (pred m) - - go f (REOpt r) = RE.Eps RE.\/ go f r - - go f (REVar a) = RE.Var (f a) - go f (RENamed _ r) = go f r - go f (RERec n r) = RE.fix_ (fromString n) + r' = go f r + + go' m + | m <= 0 = RE.Eps + | otherwise = RE.Eps RE.\/ sep' <> r' <> go' (pred m) + go f (REOpt r) = RE.Eps RE.\/ go f r + go f (REVar a) = RE.Var (f a) + go f (RENamed _ r) = go f r + go f (RERec n r) = + RE.fix_ + (fromString n) (go (maybe RE.B (RE.F . f)) r) - - go _ RESpaces = RE.Eps RE.\/ RE.ch_ ' ' RE.\/ " " RE.\/ "\n" - go _ RESpaces1 = RE.ch_ ' ' RE.\/ " " RE.\/ "\n" - - go f (RECommaList r) = go f (expandedCommaList r) - go f (RECommaNonEmpty r)= go f (expandedCommaNonEmpty r) + go _ RESpaces = RE.Eps RE.\/ RE.ch_ ' ' RE.\/ " " RE.\/ "\n" + go _ RESpaces1 = RE.ch_ ' ' RE.\/ " " RE.\/ "\n" + go f (RECommaList r) = go f (expandedCommaList r) + go f (RECommaNonEmpty r) = go f (expandedCommaNonEmpty r) go f (REOptCommaList r) = go f (expandedOptCommaList r) - - go _ RETodo = RE.Null + go _ RETodo = RE.Null expandedCommaList :: GrammarRegex a -> GrammarRegex a expandedCommaList = REUnion . expandedCommaList' expandedCommaNonEmpty :: GrammarRegex a -> GrammarRegex a -expandedCommaNonEmpty r = REUnion +expandedCommaNonEmpty r = + REUnion [ REMunch1 reSpacedComma r , reComma <> RESpaces <> REMunch1 reSpacedComma r , REMunch1 reSpacedComma r <> RESpaces <> reComma @@ -262,10 +290,10 @@ expandedCommaNonEmpty r = REUnion expandedCommaList' :: GrammarRegex a -> [GrammarRegex a] expandedCommaList' r = - [ REMunch reSpacedComma r - , reComma <> RESpaces <> REMunch1 reSpacedComma r - , REMunch1 reSpacedComma r <> RESpaces <> reComma - ] + [ REMunch reSpacedComma r + , reComma <> RESpaces <> REMunch1 reSpacedComma r + , REMunch1 reSpacedComma r <> RESpaces <> reComma + ] expandedOptCommaList :: GrammarRegex a -> GrammarRegex a expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r @@ -278,10 +306,13 @@ convertCS = RE.fromIntervalList . CS.toIntervalList ------------------------------------------------------------------------------- testDescribed - :: forall a. (Arbitrary a, Described a, Typeable a, Eq a, Show a) - => Proxy a - -> TestTree -testDescribed _ = testGroup name + :: forall a + . (Arbitrary a, Described a, Typeable a, Eq a, Show a) + => Proxy a + -> TestTree +testDescribed _ = + testGroup + name [ testProperty "parsec" propParsec , testProperty "pretty" propPretty , testProperty "roundtrip" propRoundtrip @@ -291,8 +322,8 @@ testDescribed _ = testGroup name propParsec :: Ex a -> Property propParsec (Example str) = counterexample (show res) $ case res of - Right _ -> True - Left _ -> False + Right _ -> True + Left _ -> False where res :: Either String a res = eitherParsec str @@ -307,8 +338,8 @@ testDescribed _ = testGroup name propRoundtrip :: a -> Property propRoundtrip x = counterexample (show (res, str)) $ case res of - Right y -> x == y - Left _ -> False + Right y -> x == y + Left _ -> False where str = prettyShow x res = eitherParsec str @@ -317,261 +348,279 @@ newtype Ex a = Example String deriving (Show) instance Described a => Arbitrary (Ex a) where - arbitrary - = fmap Example - $ fromMaybe (return "") - $ RE.generate 10 5 - $ convert $ describe (Proxy :: Proxy a) + arbitrary = + fmap Example $ + fromMaybe (return "") $ + RE.generate 10 5 $ + convert $ + describe (Proxy :: Proxy a) - shrink (Example s) - | '\n' `elem` s = [ Example $ map (\c -> if c == '\n' then ' ' else c) s ] - | otherwise = [] + shrink (Example s) + | '\n' `elem` s = [Example $ map (\c -> if c == '\n' then ' ' else c) s] + | otherwise = [] ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- instance Described AbiDependency where - describe _ = - describe (Proxy :: Proxy UnitId) <> - reChar '=' <> - describe (Proxy :: Proxy AbiHash) + describe _ = + describe (Proxy :: Proxy UnitId) + <> reChar '=' + <> describe (Proxy :: Proxy AbiHash) instance Described AbiHash where - describe _ = reMunchCS csAlphaNum + describe _ = reMunchCS csAlphaNum instance Described Arch where - describe _ = REUnion - [ fromString (prettyShow arch) - | arch <- knownArches - ] + describe _ = + REUnion + [ fromString (prettyShow arch) + | arch <- knownArches + ] instance Described BenchmarkType where - describe _ = "exitcode-stdio-1.0" + describe _ = "exitcode-stdio-1.0" instance Described BuildType where - describe _ = REUnion ["Simple","Configure","Custom","Make","Default"] + describe _ = REUnion ["Simple", "Configure", "Custom", "Make", "Default"] instance Described CompilerFlavor where - describe _ = REUnion - [ fromString (prettyShow c) - | c <- knownCompilerFlavors - ] + describe _ = + REUnion + [ fromString (prettyShow c) + | c <- knownCompilerFlavors + ] instance Described CompilerId where - describe _ = - describe (Proxy :: Proxy CompilerFlavor) - <> fromString "-" - <> describe (Proxy :: Proxy Version) + describe _ = + describe (Proxy :: Proxy CompilerFlavor) + <> fromString "-" + <> describe (Proxy :: Proxy Version) instance Described Dependency where - describe _ = REAppend - [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName)) - , REOpt $ - reChar ':' + describe _ = + REAppend + [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName)) + , REOpt $ + reChar ':' <> REUnion - [ reUnqualComponent - , REAppend - [ reChar '{' - , RESpaces - -- no leading or trailing comma - , REMunch1 reSpacedComma reUnqualComponent - , RESpaces - , reChar '}' - ] - ] - - , REOpt $ RESpaces <> vr - ] - where - vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) + [ reUnqualComponent + , REAppend + [ reChar '{' + , RESpaces + , -- no leading or trailing comma + REMunch1 reSpacedComma reUnqualComponent + , RESpaces + , reChar '}' + ] + ] + , REOpt $ RESpaces <> vr + ] + where + vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) instance Described ExecutableScope where - describe _ = REUnion ["public","private"] + describe _ = REUnion ["public", "private"] instance Described ExeDependency where - describe _ = RETodo + describe _ = RETodo instance Described ExposedModule where - describe _ = RETodo + describe _ = RETodo instance Described Extension where - describe _ = RETodo + describe _ = RETodo instance Described FlagAssignment where - describe _ = REMunch RESpaces1 $ - REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) + describe _ = + REMunch RESpaces1 $ + REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) instance Described FlagName where - describe _ = lead <> rest where - lead = RECharSet $ csAlphaNum <> fromString "_" - rest = reMunchCS $ csAlphaNum <> fromString "_-" + describe _ = lead <> rest + where + lead = RECharSet $ csAlphaNum <> fromString "_" + rest = reMunchCS $ csAlphaNum <> fromString "_-" instance Described ForeignLibOption where - describe _ = "standalone" + describe _ = "standalone" instance Described ForeignLibType where - describe _ = REUnion ["native-shared","native-static"] + describe _ = REUnion ["native-shared", "native-static"] instance Described IncludeRenaming where - describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr) - where - mr = describe (Proxy :: Proxy ModuleRenaming) + describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr) + where + mr = describe (Proxy :: Proxy ModuleRenaming) instance Described Language where - describe _ = REUnion ["Haskell98", "Haskell2010"] + describe _ = REUnion ["Haskell98", "Haskell2010"] instance Described LegacyExeDependency where - describe _ = RETodo + describe _ = RETodo instance Described LibraryVisibility where - describe _ = REUnion ["public","private"] + describe _ = REUnion ["public", "private"] instance Described LibVersionInfo where - describe _ = reDigits <> REOpt (reChar ':' <> reDigits <> REOpt (reChar ':' <> reDigits)) where - reDigits = reChars ['0'..'9'] + describe _ = reDigits <> REOpt (reChar ':' <> reDigits <> REOpt (reChar ':' <> reDigits)) + where + reDigits = reChars ['0' .. '9'] instance Described Mixin where - describe _ = - RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <> - REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) <> - REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming)) + describe _ = + RENamed "package-name" (describe (Proxy :: Proxy PackageName)) + <> REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) + <> REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming)) instance Described ModuleName where - describe _ = REMunch1 (reChar '.') component where - component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")]) + describe _ = REMunch1 (reChar '.') component + where + component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")]) instance Described ModuleReexport where - describe _ = RETodo + describe _ = RETodo instance Described ModuleRenaming where - describe _ = REUnion - [ reEps - , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) - , bp (REMunch reSpacedComma entry) - ] - where - bp r = "(" <> RESpaces <> r <> RESpaces <> ")" - mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName) - - entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn) + describe _ = + REUnion + [ reEps + , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn) + , bp (REMunch reSpacedComma entry) + ] + where + bp r = "(" <> RESpaces <> r <> RESpaces <> ")" + mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName) + + entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn) instance Described MungedPackageName where - describe _ = RETodo + describe _ = RETodo instance Described OS where - describe _ = REUnion - [ fromString (prettyShow os) - | os <- knownOSs - ] + describe _ = + REUnion + [ fromString (prettyShow os) + | os <- knownOSs + ] instance Described PackageIdentifier where - describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version) + describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version) instance Described PackageName where - describe _ = reUnqualComponent + describe _ = reUnqualComponent instance Described PackageVersionConstraint where - describe _ = describe (Proxy :: Proxy PackageName) <> REUnion + describe _ = + describe (Proxy :: Proxy PackageName) + <> REUnion [ fromString "-" <> describe (Proxy :: Proxy Version) , RESpaces <> describe (Proxy :: Proxy VersionRange) ] instance Described PkgconfigDependency where - describe _ = RETodo + describe _ = RETodo instance Described RepoType where - describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-' + describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-' instance Described TestType where - describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"] + describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"] instance Described Verbosity where - describe _ = REUnion - [ REUnion ["0", "1", "2", "3"] - , REUnion ["silent", "normal", "verbose", "debug", "deafening"] - <> REMunch reEps (RESpaces <> "+" <> - -- markoutput is left out on purpose - REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout" ]) - ] + describe _ = + REUnion + [ REUnion ["0", "1", "2", "3"] + , REUnion ["silent", "normal", "verbose", "debug", "deafening"] + <> REMunch + reEps + ( RESpaces + <> "+" + <> + -- markoutput is left out on purpose + REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout"] + ) + ] instance Described Version where - describe _ = REMunch1 reDot reDigits where - reDigits = REUnion - [ reChar '0' - , reChars ['1'..'9'] <> REMunchR 8 reEps (reChars ['0'..'9']) - ] + describe _ = REMunch1 reDot reDigits + where + reDigits = + REUnion + [ reChar '0' + , reChars ['1' .. '9'] <> REMunchR 8 reEps (reChars ['0' .. '9']) + ] instance Described VersionRange where - describe _ = RERec "version-range" $ REUnion - [ "==" <> RESpaces <> ver - , ">" <> RESpaces <> ver - , "<" <> RESpaces <> ver - , "<=" <> RESpaces <> ver - , ">=" <> RESpaces <> ver + describe _ = + RERec "version-range" $ + REUnion + [ "==" <> RESpaces <> ver + , ">" <> RESpaces <> ver + , "<" <> RESpaces <> ver + , "<=" <> RESpaces <> ver + , ">=" <> RESpaces <> ver , "^>=" <> RESpaces <> ver - - -- ==0.1.* - , "==" <> RESpaces <> wildVer - - , reVar0 <> RESpaces <> "||" <> RESpaces <> reVar0 - , reVar0 <> RESpaces <> "&&" <> RESpaces <> reVar0 - , "(" <> RESpaces <> reVar0 <> RESpaces <> ")" - - -- == { 0.1.2 } - -- silly haddock: ^>= { 0.1.2, 3.4.5 } - , "==" <> RESpaces <> verSet + , -- ==0.1.* + "==" <> RESpaces <> wildVer + , reVar0 <> RESpaces <> "||" <> RESpaces <> reVar0 + , reVar0 <> RESpaces <> "&&" <> RESpaces <> reVar0 + , "(" <> RESpaces <> reVar0 <> RESpaces <> ")" + , -- == { 0.1.2 } + -- silly haddock: ^>= { 0.1.2, 3.4.5 } + "==" <> RESpaces <> verSet , "^>=" <> RESpaces <> verSet ] - where - ver' = describe (Proxy :: Proxy Version) - ver = RENamed "version" ver' - wildVer = ver' <> ".*" - verSet = "{" <> RESpaces <> REMunch1 reSpacedComma ver <> RESpaces <> "}" + where + ver' = describe (Proxy :: Proxy Version) + ver = RENamed "version" ver' + wildVer = ver' <> ".*" + verSet = "{" <> RESpaces <> REMunch1 reSpacedComma ver <> RESpaces <> "}" instance Described UnitId where - describe _ = reMunch1CS $ csAlphaNum <> csChar '-' <> csChar '_' <> csChar '.' <> csChar '+' + describe _ = reMunch1CS $ csAlphaNum <> csChar '-' <> csChar '_' <> csChar '.' <> csChar '+' instance Described UnqualComponentName where - describe _ = reUnqualComponent + describe _ = reUnqualComponent ------------------------------------------------------------------------------- -- Instances: Newtypes ------------------------------------------------------------------------------- class Sep sep => DescribeSep sep where - describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a + describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a -instance DescribeSep CommaVCat where describeSep _ = reCommaList -instance DescribeSep CommaFSep where describeSep _ = reCommaList -instance DescribeSep VCat where describeSep _ = reCommaList -instance DescribeSep FSep where describeSep _ = reOptCommaList +instance DescribeSep CommaVCat where describeSep _ = reCommaList +instance DescribeSep CommaFSep where describeSep _ = reCommaList +instance DescribeSep VCat where describeSep _ = reCommaList +instance DescribeSep FSep where describeSep _ = reOptCommaList instance DescribeSep NoCommaFSep where describeSep _ = reSpacedList instance (Newtype a b, DescribeSep sep, Described b) => Described (List sep b a) where - describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) + describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) instance (Newtype a b, Ord a, DescribeSep sep, Described b) => Described (Set' sep b a) where - describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) + describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b)) instance Described Token where - describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma] + describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma] instance Described Token' where - describe _ = REUnion [reHsString, reMunch1CS csNotSpace] + describe _ = REUnion [reHsString, reMunch1CS csNotSpace] instance Described a => Described (MQuoted a) where - -- TODO: this is simplification - describe _ = describe ([] :: [a]) + -- TODO: this is simplification + describe _ = describe ([] :: [a]) instance Described SpecVersion where - describe _ = "3.4" -- :) + describe _ = "3.4" -- :) instance Described SpecLicense where - describe _ = RETodo + describe _ = RETodo instance Described TestedWith where - describe _ = RETodo + describe _ = RETodo instance Described FilePathNT where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) diff --git a/Cabal-described/src/Distribution/Utils/CharSet.hs b/Cabal-described/src/Distribution/Utils/CharSet.hs index 45bfbb1300b..7a0e48ff2e9 100644 --- a/Cabal-described/src/Distribution/Utils/CharSet.hs +++ b/Cabal-described/src/Distribution/Utils/CharSet.hs @@ -1,43 +1,67 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} + -- | Sets of characters. -- -- Using this is more efficient than 'RE.Type.Alt':ng individual characters. -module Distribution.Utils.CharSet ( - -- * Set of characters - CharSet, +module Distribution.Utils.CharSet + ( -- * Set of characters + CharSet + -- * Construction - empty, - universe, - singleton, - insert, - union, - intersection, - complement, - difference, + , empty + , universe + , singleton + , insert + , union + , intersection + , complement + , difference + -- * Query - size, - null, - member, + , size + , null + , member + -- * Conversions - fromList, - toList, - fromIntervalList, - toIntervalList, + , fromList + , toList + , fromIntervalList + , toIntervalList + -- * Special lists - alpha, - alphanum, - upper, - ) where - -import Data.Char (chr, isAlpha, isAlphaNum, isUpper, ord) -import Data.List (foldl', sortBy) -import Data.Monoid (Monoid (..)) -import Data.String (IsString (..)) + , alpha + , alphanum + , upper + ) where + +import Data.Char (chr, isAlpha, isAlphaNum, isUpper, ord) +import Data.List (foldl', sortBy) +import Data.Monoid (Monoid (..)) +import Data.String (IsString (..)) import Distribution.Compat.Semigroup (Semigroup (..)) import Prelude - (Bool (..), Bounded (..), Char, Enum (..), Eq (..), Int, Maybe (..), Num (..), Ord (..), Show (..), String, concatMap, flip, fst, otherwise, showParen, - showString, uncurry, ($), (.)) + ( Bool (..) + , Bounded (..) + , Char + , Enum (..) + , Eq (..) + , Int + , Maybe (..) + , Num (..) + , Ord (..) + , Show (..) + , String + , concatMap + , flip + , fst + , otherwise + , showParen + , showString + , uncurry + , ($) + , (.) + ) #if MIN_VERSION_containers(0,5,0) import qualified Data.IntMap.Strict as IM @@ -48,27 +72,27 @@ import qualified Data.IntMap as IM -- | A set of 'Char's. -- -- We use range set, which works great with 'Char'. -newtype CharSet = CS { unCS :: IM.IntMap Int } +newtype CharSet = CS {unCS :: IM.IntMap Int} deriving (Eq, Ord) instance IsString CharSet where - fromString = fromList + fromString = fromList instance Show CharSet where - showsPrec d cs - | size cs < 20 - = showsPrec d (toList cs) - | otherwise - = showParen (d > 10) - $ showString "CS " - . showsPrec 11 (unCS cs) + showsPrec d cs + | size cs < 20 = + showsPrec d (toList cs) + | otherwise = + showParen (d > 10) $ + showString "CS " + . showsPrec 11 (unCS cs) instance Semigroup CharSet where - (<>) = union + (<>) = union instance Monoid CharSet where - mempty = empty - mappend = (<>) + mempty = empty + mappend = (<>) -- | Empty character set. empty :: CharSet @@ -89,7 +113,6 @@ null (CS cs) = IM.null cs -- -- >>> length $ toList $ fromIntervalList [('a','f'), ('0','9')] -- 16 --- size :: CharSet -> Int size (CS m) = foldl' (\ !acc (lo, hi) -> acc + (hi - lo) + 1) 0 (IM.toList m) @@ -98,19 +121,21 @@ singleton :: Char -> CharSet singleton c = CS (IM.singleton (ord c) (ord c)) -- | Test whether character is in the set. -member :: Char -> CharSet -> Bool #if MIN_VERSION_containers(0,5,0) +member :: Char -> CharSet -> Bool member c (CS m) = case IM.lookupLE i m of Nothing -> False Just (_, hi) -> i <= hi where + i = ord c #else +member :: Char -> CharSet -> Bool member c (CS m) = go (IM.toList m) where go [] = False go ((x,y):zs) = (x <= i && i <= y) || go zs -#endif i = ord c +#endif -- | Insert 'Char' into 'CharSet'. insert :: Char -> CharSet -> CharSet @@ -122,16 +147,17 @@ union (CS xs) (CS ys) = normalise (IM.unionWith max xs ys) -- | Intersection of two 'CharSet's intersection :: CharSet -> CharSet -> CharSet -intersection (CS xs) (CS ys) = CS $ +intersection (CS xs) (CS ys) = + CS $ IM.fromList (intersectRangeList (IM.toList xs) (IM.toList ys)) -- | Compute the intersection. intersectRangeList :: Ord a => [(a, a)] -> [(a, a)] -> [(a, a)] -intersectRangeList aset@((x,y):as) bset@((u,v):bs) - | y < u = intersectRangeList as bset - | v < x = intersectRangeList aset bs - | y < v = (max x u, y) : intersectRangeList as bset - | otherwise = (max x u, v) : intersectRangeList aset bs +intersectRangeList aset@((x, y) : as) bset@((u, v) : bs) + | y < u = intersectRangeList as bset + | v < x = intersectRangeList aset bs + | y < v = (max x u, y) : intersectRangeList as bset + | otherwise = (max x u, v) : intersectRangeList aset bs intersectRangeList _ [] = [] intersectRangeList [] _ = [] @@ -141,22 +167,22 @@ complement (CS xs) = CS $ IM.fromList $ complementRangeList (IM.toList xs) -- | Compute the complement intersected with @[x,)@ assuming @x [(Int, Int)] -> [(Int, Int)] -complementRangeList' x ((u,v):s) = (x,pred u) : complementRangeList'' v s -complementRangeList' x [] = [(x,0x10ffff)] +complementRangeList' x ((u, v) : s) = (x, pred u) : complementRangeList'' v s +complementRangeList' x [] = [(x, 0x10ffff)] -- | Compute the complement intersected with @(x,)@. complementRangeList'' :: Int -> [(Int, Int)] -> [(Int, Int)] complementRangeList'' x s - | x == 0x10ffff = [] - | otherwise = complementRangeList' (succ x) s + | x == 0x10ffff = [] + | otherwise = complementRangeList' (succ x) s -- | Compute the complement. -- -- Note: we treat Ints as codepoints, i.e minBound is 0, and maxBound is 0x10ffff complementRangeList :: [(Int, Int)] -> [(Int, Int)] -complementRangeList s@((x,y):s') - | x == 0 = complementRangeList'' y s' - | otherwise = complementRangeList' 0 s +complementRangeList s@((x, y) : s') + | x == 0 = complementRangeList'' y s' + | otherwise = complementRangeList' 0 s complementRangeList [] = [(0, 0x10ffff)] -- | Difference of two 'CharSet's. @@ -165,7 +191,7 @@ difference xs ys = intersection xs (complement ys) -- | Make 'CharSet' from a list of characters, i.e. 'String'. fromList :: String -> CharSet -fromList = normalise . foldl' (\ acc c -> IM.insert (ord c) (ord c) acc) IM.empty +fromList = normalise . foldl' (\acc c -> IM.insert (ord c) (ord c) acc) IM.empty -- | Convert 'CharSet' to a list of characters i.e. 'String'. toList :: CharSet -> String @@ -175,9 +201,8 @@ toList = concatMap (uncurry enumFromTo) . toIntervalList -- -- >>> toIntervalList $ union "01234" "56789" -- [('0','9')] --- toIntervalList :: CharSet -> [(Char, Char)] -toIntervalList (CS m) = [ (chr lo, chr hi) | (lo, hi) <- IM.toList m ] +toIntervalList (CS m) = [(chr lo, chr hi) | (lo, hi) <- IM.toList m] -- | Convert from interval pairs. -- @@ -189,32 +214,35 @@ toIntervalList (CS m) = [ (chr lo, chr hi) | (lo, hi) <- IM.toList m ] -- -- >>> fromIntervalList [('Z','A')] -- "" --- -fromIntervalList :: [(Char,Char)] -> CharSet -fromIntervalList xs = normalise' $ sortBy (\a b -> compare (fst a) (fst b)) - [ (ord lo, ord hi) - | (lo, hi) <- xs - , lo <= hi - ] +fromIntervalList :: [(Char, Char)] -> CharSet +fromIntervalList xs = + normalise' $ + sortBy + (\a b -> compare (fst a) (fst b)) + [ (ord lo, ord hi) + | (lo, hi) <- xs + , lo <= hi + ] ------------------------------------------------------------------------------- -- Normalisation ------------------------------------------------------------------------------- normalise :: IM.IntMap Int -> CharSet -normalise = normalise'. IM.toList +normalise = normalise' . IM.toList -normalise' :: [(Int,Int)] -> CharSet -normalise' = CS . IM.fromList . go where - go :: [(Int,Int)] -> [(Int,Int)] - go [] = [] - go ((x,y):zs) = go' x y zs +normalise' :: [(Int, Int)] -> CharSet +normalise' = CS . IM.fromList . go + where + go :: [(Int, Int)] -> [(Int, Int)] + go [] = [] + go ((x, y) : zs) = go' x y zs go' :: Int -> Int -> [(Int, Int)] -> [(Int, Int)] go' lo hi [] = [(lo, hi)] - go' lo hi ws0@((u,v):ws) - | u <= succ hi = go' lo (max v hi) ws - | otherwise = (lo,hi) : go ws0 + go' lo hi ws0@((u, v) : ws) + | u <= succ hi = go' lo (max v hi) ws + | otherwise = (lo, hi) : go ws0 ------------------------------------------------------------------------------- -- Alpha Numeric character list @@ -224,19 +252,16 @@ normalise' = CS . IM.fromList . go where -- but they are not used in-non testing in Cabal's normal operation. -- | Note: this set varies depending on @base@ version. --- alpha :: CharSet -alpha = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlpha c ] +alpha = foldl' (flip insert) empty [c | c <- [minBound .. maxBound], isAlpha c] {-# NOINLINE alpha #-} -- | Note: this set varies depending on @base@ version. --- alphanum :: CharSet -alphanum = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isAlphaNum c ] +alphanum = foldl' (flip insert) empty [c | c <- [minBound .. maxBound], isAlphaNum c] {-# NOINLINE alphanum #-} -- | Note: this set varies depending on @base@ version. --- upper :: CharSet -upper = foldl' (flip insert) empty [ c | c <- [ minBound .. maxBound ], isUpper c ] +upper = foldl' (flip insert) empty [c | c <- [minBound .. maxBound], isUpper c] {-# NOINLINE upper #-} diff --git a/Cabal-described/src/Distribution/Utils/GrammarRegex.hs b/Cabal-described/src/Distribution/Utils/GrammarRegex.hs index d355848b73d..86dff808e4f 100644 --- a/Cabal-described/src/Distribution/Utils/GrammarRegex.hs +++ b/Cabal-described/src/Distribution/Utils/GrammarRegex.hs @@ -1,35 +1,38 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.GrammarRegex ( - -- * Regular expressions - GrammarRegex (..), - reEps, - reChar, - reChars, - reMunchCS, - reMunch1CS, + +module Distribution.Utils.GrammarRegex + ( -- * Regular expressions + GrammarRegex (..) + , reEps + , reChar + , reChars + , reMunchCS + , reMunch1CS + -- * Variables - reVar0, - reVar1, + , reVar0 + , reVar1 + -- * Pretty-printing - regexDoc, - ) where - -import Data.Char (isAlphaNum, isControl, ord) -import Data.Foldable (Foldable) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid (..)) -import Data.String (IsString (..)) -import Data.Traversable (Traversable) -import Data.Void (Void, vacuous) + , regexDoc + ) where + +import Data.Char (isAlphaNum, isControl, ord) +import Data.Foldable (Foldable) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.String (IsString (..)) +import Data.Traversable (Traversable) +import Data.Void (Void, vacuous) import Distribution.Compat.Semigroup (Semigroup (..)) -import Prelude (Bool (..), Char, Eq (..), Functor, Int, Maybe (..), Ord (..), Show, String, fmap, length, map, otherwise, ($), (++), (.)) +import Prelude (Bool (..), Char, Eq (..), Functor, Int, Maybe (..), Ord (..), Show, String, fmap, length, map, otherwise, ($), (++), (.)) import qualified Distribution.Utils.CharSet as CS -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP (<<>>) :: PP.Doc -> PP.Doc -> PP.Doc (<<>>) = (PP.<>) @@ -40,46 +43,62 @@ import qualified Text.PrettyPrint as PP -- | Recursive regular expressions tuned for 'Described' use-case. data GrammarRegex a - = REAppend [GrammarRegex a] -- ^ append @ab@ - | REUnion [GrammarRegex a] -- ^ union @a|b@ - - -- repetition - | REMunch (GrammarRegex a) (GrammarRegex a) -- ^ star @a*@, with a separator - | REMunch1 (GrammarRegex a) (GrammarRegex a) -- ^ plus @a+@, with a separator - | REMunchR Int (GrammarRegex a) (GrammarRegex a) -- ^ 1-n, with a separator - | REOpt (GrammarRegex a) -- ^ optional @r?@ - - | REString String -- ^ literal string @abcd@ - | RECharSet CS.CharSet -- ^ charset @[:alnum:]@ - | REVar a -- ^ variable - | RENamed String (GrammarRegex a) -- ^ named expression - | RERec String (GrammarRegex (Maybe a)) -- ^ recursive expressions - - -- cabal syntax specifics - | RESpaces -- ^ zero-or-more spaces - | RESpaces1 -- ^ one-or-more spaces - | RECommaList (GrammarRegex a) -- ^ comma list (note, leading or trailing commas) - | RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list (note, leading or trailing commas) - | REOptCommaList (GrammarRegex a) -- ^ opt comma list - - | RETodo -- ^ unspecified + = -- | append @ab@ + REAppend [GrammarRegex a] + | -- | union @a|b@ + REUnion [GrammarRegex a] + | -- repetition + + -- | star @a*@, with a separator + REMunch (GrammarRegex a) (GrammarRegex a) + | -- | plus @a+@, with a separator + REMunch1 (GrammarRegex a) (GrammarRegex a) + | -- | 1-n, with a separator + REMunchR Int (GrammarRegex a) (GrammarRegex a) + | -- | optional @r?@ + REOpt (GrammarRegex a) + | -- | literal string @abcd@ + REString String + | -- | charset @[:alnum:]@ + RECharSet CS.CharSet + | -- | variable + REVar a + | -- | named expression + RENamed String (GrammarRegex a) + | -- | recursive expressions + RERec String (GrammarRegex (Maybe a)) + | -- cabal syntax specifics + + -- | zero-or-more spaces + RESpaces + | -- | one-or-more spaces + RESpaces1 + | -- | comma list (note, leading or trailing commas) + RECommaList (GrammarRegex a) + | -- | comma non-empty list (note, leading or trailing commas) + RECommaNonEmpty (GrammarRegex a) + | -- | opt comma list + REOptCommaList (GrammarRegex a) + | -- | unspecified + RETodo deriving (Eq, Ord, Show, Functor, Foldable, Traversable) ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- -instance IsString (GrammarRegex a) where - fromString = REString +instance IsString (GrammarRegex a) where + fromString = REString instance Semigroup (GrammarRegex a) where - x <> y = REAppend (unAppend x ++ unAppend y) where - unAppend (REAppend rs) = rs - unAppend r = [r] + x <> y = REAppend (unAppend x ++ unAppend y) + where + unAppend (REAppend rs) = rs + unAppend r = [r] instance Monoid (GrammarRegex a) where - mempty = REAppend [] - mappend = (<>) + mempty = REAppend [] + mappend = (<>) ------------------------------------------------------------------------------- -- Smart constructors @@ -123,56 +142,60 @@ reVar1 = REVar (Just Nothing) -- -- >>> regexDoc $ REString "foo" <> REString "bar" -- \mathop{\mathord{``}\mathtt{foo}\mathord{"}}\mathop{\mathord{``}\mathtt{bar}\mathord{"}} --- regexDoc :: GrammarRegex Void -> PP.Doc -regexDoc = go 0 . vacuous where +regexDoc = go 0 . vacuous + where go :: Int -> GrammarRegex PP.Doc -> PP.Doc - go _ (REAppend []) = "" - go d (REAppend rs) = parensIf (d > 2) $ PP.hcat (map (go 2) rs) - go d (REUnion [r]) = go d r - go _ (REUnion rs) = PP.hsep + go _ (REAppend []) = "" + go d (REAppend rs) = parensIf (d > 2) $ PP.hcat (map (go 2) rs) + go d (REUnion [r]) = go d r + go _ (REUnion rs) = + PP.hsep [ "\\left\\{" , if length rs < 4 - then PP.hcat (PP.punctuate (PP.text "\\mid") (map (go 0) rs)) - else "\\begin{gathered}" <<>> - PP.hcat (PP.punctuate "\\\\" (map (go 0) rs)) <<>> - "\\end{gathered}" - , "\\right\\}" ] - - go d (REMunch sep r) = parensIf (d > 3) $ + then PP.hcat (PP.punctuate (PP.text "\\mid") (map (go 0) rs)) + else + "\\begin{gathered}" + <<>> PP.hcat (PP.punctuate "\\\\" (map (go 0) rs)) + <<>> "\\end{gathered}" + , "\\right\\}" + ] + go d (REMunch sep r) = + parensIf (d > 3) $ PP.text "{" <<>> go 4 r <<>> PP.text "}^\\ast_{" <<>> go 4 sep <<>> PP.text "}" - go d (REMunch1 sep r) = parensIf (d > 3) $ + go d (REMunch1 sep r) = + parensIf (d > 3) $ PP.text "{" <<>> go 4 r <<>> PP.text "}^+_{" <<>> go 4 sep <<>> PP.text "}" - go d (REMunchR n sep r) = parensIf (d > 3) $ + go d (REMunchR n sep r) = + parensIf (d > 3) $ PP.text "{" <<>> go 4 r <<>> PP.text "}^{\\in [0\\ldots" <<>> PP.int n <<>> "]}_{" <<>> go 4 sep <<>> PP.text "}" - go d (REOpt r) = parensIf (d > 3) $ + go d (REOpt r) = + parensIf (d > 3) $ PP.text "{" <<>> go 4 r <<>> PP.text "}^?" - - go _ (REString s) = PP.text "\\mathop{\\mathord{``}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}" - go _ (RECharSet cs) = charsetDoc cs - - go _ RESpaces = "\\circ" - go _ RESpaces1 = "\\bullet" - - go _ (RECommaList r) = - "\\mathrm{commalist}" <<>> go 4 r - go _ (RECommaNonEmpty r) = - "\\mathrm{commanonempty}" <<>> go 4 r + go _ (REString s) = PP.text "\\mathop{\\mathord{``}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}" + go _ (RECharSet cs) = charsetDoc cs + go _ RESpaces = "\\circ" + go _ RESpaces1 = "\\bullet" + go _ (RECommaList r) = + "\\mathrm{commalist}" <<>> go 4 r + go _ (RECommaNonEmpty r) = + "\\mathrm{commanonempty}" <<>> go 4 r go _ (REOptCommaList r) = - "\\mathrm{optcommalist}" <<>> go 4 r - - go _ (REVar a) = a - go _ (RENamed n _) = terminalDoc n - go d (RERec n r) = parensIf (d > 0) $ - "\\mathbf{fix}\\;" <<>> n' <<>> "\\;\\mathbf{in}\\;" <<>> - go 0 (fmap (fromMaybe n') r) + "\\mathrm{optcommalist}" <<>> go 4 r + go _ (REVar a) = a + go _ (RENamed n _) = terminalDoc n + go d (RERec n r) = + parensIf (d > 0) $ + "\\mathbf{fix}\\;" + <<>> n' + <<>> "\\;\\mathbf{in}\\;" + <<>> go 0 (fmap (fromMaybe n') r) where n' = terminalDoc n - - go _ RETodo = PP.text "\\mathsf{\\color{red}{TODO}}" + go _ RETodo = PP.text "\\mathsf{\\color{red}{TODO}}" parensIf :: Bool -> PP.Doc -> PP.Doc - parensIf True d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)" + parensIf True d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)" parensIf False d = d terminalDoc :: String -> PP.Doc @@ -184,9 +207,9 @@ charDoc '{' = PP.text "\\{" charDoc '}' = PP.text "\\}" charDoc '\\' = PP.text "\\text{\\\\}" charDoc c - | isAlphaNum c = PP.char c - | isControl c = PP.int (ord c) -- TODO: some syntax - | otherwise = PP.text ("\\text{" ++ c : "}") + | isAlphaNum c = PP.char c + | isControl c = PP.int (ord c) -- TODO: some syntax + | otherwise = PP.text ("\\text{" ++ c : "}") inquotes :: PP.Doc -> PP.Doc inquotes d = "\\mathop{\\mathord{``}" <<>> d <<>> "\\mathord{\"}}" @@ -196,20 +219,21 @@ mathtt d = "\\mathtt{" <<>> d <<>> "}" charsetDoc :: CS.CharSet -> PP.Doc charsetDoc acs - | acs == CS.alpha = terminalDoc "alpha" - | acs == CS.alphanum = terminalDoc "alpha-num" - | acs == CS.upper = terminalDoc "upper" + | acs == CS.alpha = terminalDoc "alpha" + | acs == CS.alphanum = terminalDoc "alpha-num" + | acs == CS.upper = terminalDoc "upper" charsetDoc acs = case CS.toIntervalList acs of - [] -> "\\emptyset" - [(x,y)] | x == y -> inquotes $ mathtt $ charDoc x - rs - | CS.size acs <= CS.size notAcs - -> PP.brackets $ PP.hcat $ map rangeDoc rs - | otherwise - -> PP.braces $ PP.brackets (PP.hcat $ map rangeDoc (CS.toIntervalList notAcs)) <<>> PP.text "^c" + [] -> "\\emptyset" + [(x, y)] | x == y -> inquotes $ mathtt $ charDoc x + rs + | CS.size acs <= CS.size notAcs -> + PP.brackets $ PP.hcat $ map rangeDoc rs + | otherwise -> + PP.braces $ PP.brackets (PP.hcat $ map rangeDoc (CS.toIntervalList notAcs)) <<>> PP.text "^c" where notAcs = CS.complement acs rangeDoc :: (Char, Char) -> PP.Doc - rangeDoc (x, y) | x == y = inquotes (mathtt $ charDoc x) - | otherwise = inquotes (mathtt $ charDoc x) <<>> PP.text "\\cdots" <<>> inquotes (mathtt $ charDoc y) + rangeDoc (x, y) + | x == y = inquotes (mathtt $ charDoc x) + | otherwise = inquotes (mathtt $ charDoc x) <<>> PP.text "\\cdots" <<>> inquotes (mathtt $ charDoc y) diff --git a/Cabal-tests/tests/CheckTests.hs b/Cabal-tests/tests/CheckTests.hs index 01fe7ae749f..ea8f0a846f0 100644 --- a/Cabal-tests/tests/CheckTests.hs +++ b/Cabal-tests/tests/CheckTests.hs @@ -1,24 +1,24 @@ module Main - ( main - ) where + ( main + ) where import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.Golden.Advanced (goldenTest) -import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) -import Distribution.Fields (runParseResult) -import Distribution.PackageDescription.Check (checkPackage) +import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) +import Distribution.Fields (runParseResult) +import Distribution.PackageDescription.Check (checkPackage) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) import Distribution.Parsec -import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs, withArgs) -import System.FilePath (replaceExtension, ()) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.Directory (setCurrentDirectory) +import System.Environment (getArgs, withArgs) +import System.FilePath (replaceExtension, ()) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NE tests :: TestTree tests = checkTests @@ -28,7 +28,9 @@ tests = checkTests ------------------------------------------------------------------------------- checkTests :: TestTree -checkTests = testGroup "regressions" +checkTests = + testGroup + "regressions" [ checkTest "nothing-unicode.cabal" , checkTest "haddock-api-2.18.1-check.cabal" , checkTest "issue-774.cabal" @@ -61,17 +63,17 @@ checkTests = testGroup "regressions" checkTest :: FilePath -> TestTree checkTest fp = cabalGoldenTest fp correct $ do - contents <- BS.readFile input - let res = parseGenericPackageDescription contents - let (ws, x) = runParseResult res + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (ws, x) = runParseResult res - return $ toUTF8BS $ case x of - Right gpd -> - -- Note: parser warnings are reported by `cabal check`, but not by - -- D.PD.Check functionality. - unlines (map (showPWarning fp) ws) ++ - unlines (map show (checkPackage gpd Nothing)) - Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs + return $ toUTF8BS $ case x of + Right gpd -> + -- Note: parser warnings are reported by `cabal check`, but not by + -- D.PD.Check functionality. + unlines (map (showPWarning fp) ws) + ++ unlines (map show (checkPackage gpd Nothing)) + Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs where input = "tests" "ParserTests" "regressions" fp correct = replaceExtension input "check" @@ -82,22 +84,25 @@ checkTest fp = cabalGoldenTest fp correct $ do main :: IO () main = do - args <- getArgs - case args of - ("--cwd" : cwd : args') -> do - setCurrentDirectory cwd - withArgs args' $ defaultMain tests - _ -> defaultMain tests + args <- getArgs + case args of + ("--cwd" : cwd : args') -> do + setCurrentDirectory cwd + withArgs args' $ defaultMain tests + _ -> defaultMain tests cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd where upd = BS.writeFile ref cmp x y | x == y = return Nothing - cmp x y = return $ Just $ unlines $ - concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) + cmp x y = + return $ + Just $ + unlines $ + concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) where - f (First xs) = map (cons3 '-' . fromUTF8BS) xs + f (First xs) = map (cons3 '-' . fromUTF8BS) xs f (Second ys) = map (cons3 '+' . fromUTF8BS) ys -- we print unchanged lines too. It shouldn't be a problem while we have -- reasonably small examples diff --git a/Cabal-tests/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index df27938d221..a60d42bedfe 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} #if !MIN_VERSION_deepseq(1,4,0) {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -9,43 +9,43 @@ module Main where import Distribution.Compat.Semigroup -import Prelude () import Prelude.Compat +import Prelude () -import Control.Applicative (many, (<**>), (<|>)) -import Control.DeepSeq (NFData (..), force) -import Control.Exception (evaluate) -import Control.Monad (join, unless, when) -import Data.Foldable (traverse_) -import Data.List (isPrefixOf, isSuffixOf) -import Data.Maybe (mapMaybe) -import Data.Monoid (Sum (..)) -import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage) +import Control.Applicative (many, (<**>), (<|>)) +import Control.DeepSeq (NFData (..), force) +import Control.Exception (evaluate) +import Control.Monad (join, unless, when) +import Data.Foldable (traverse_) +import Data.List (isPrefixOf, isSuffixOf) +import Data.Maybe (mapMaybe) +import Data.Monoid (Sum (..)) +import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import Numeric (showFFloat) -import System.Directory (getXdgDirectory, XdgDirectory(XdgCache, XdgConfig), getAppUserDataDirectory, doesDirectoryExist) -import System.Environment (lookupEnv) -import System.Exit (exitFailure) -import System.FilePath (()) +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import Numeric (showFFloat) +import System.Directory (XdgDirectory (XdgCache, XdgConfig), doesDirectoryExist, getAppUserDataDirectory, getXdgDirectory) +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.FilePath (()) import Data.Orphans () -import qualified Codec.Archive.Tar as Tar -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BSL -import qualified Distribution.Fields.Parser as Parsec -import qualified Distribution.Fields.Pretty as PP +import qualified Codec.Archive.Tar as Tar +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BSL +import qualified Distribution.Fields.Parser as Parsec +import qualified Distribution.Fields.Pretty as PP import qualified Distribution.PackageDescription.Parsec as Parsec -import qualified Distribution.Parsec as Parsec -import qualified Options.Applicative as O -import qualified System.Clock as Clock +import qualified Distribution.Parsec as Parsec +import qualified Options.Applicative as O +import qualified System.Clock as Clock -import Distribution.Compat.Lens +import Distribution.Compat.Lens import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L -- import Distribution.Types.BuildInfo (BuildInfo (cppOptions)) -- import qualified Distribution.Types.BuildInfo.Lens as L @@ -60,30 +60,33 @@ import Data.TreeDiff.Pretty (ansiWlEditExprCompact) -- parseIndex: Index traversal ------------------------------------------------------------------------------- -parseIndex :: (Monoid a, NFData a) => (FilePath -> Bool) - -> (FilePath -> B.ByteString -> IO a) -> IO a +parseIndex + :: (Monoid a, NFData a) + => (FilePath -> Bool) + -> (FilePath -> B.ByteString -> IO a) + -> IO a parseIndex predicate action = do - configPath <- getCabalConfigPath - cfg <- B.readFile configPath - cfgFields <- either (fail . show) pure $ Parsec.readFields cfg - repoCache <- case lookupInConfig "remote-repo-cache" cfgFields of - [] -> getCacheDirPath -- Default - (rrc : _) -> return rrc -- User-specified - let repos = reposFromConfig cfgFields - tarName repo = repoCache repo "01-index.tar" - mconcat <$> traverse (parseIndex' predicate action . tarName) repos + configPath <- getCabalConfigPath + cfg <- B.readFile configPath + cfgFields <- either (fail . show) pure $ Parsec.readFields cfg + repoCache <- case lookupInConfig "remote-repo-cache" cfgFields of + [] -> getCacheDirPath -- Default + (rrc : _) -> return rrc -- User-specified + let repos = reposFromConfig cfgFields + tarName repo = repoCache repo "01-index.tar" + mconcat <$> traverse (parseIndex' predicate action . tarName) repos where getCacheDirPath = - getXdgDirectory XdgCache $ "cabal" "packages" + getXdgDirectory XdgCache $ "cabal" "packages" getCabalConfigPath = do - mx <- lookupEnv "CABAL_CONFIG" - case mx of - Just x -> return x - Nothing -> do - mDir <- maybeGetCabalDir - case mDir of - Nothing -> getXdgDirectory XdgConfig $ "cabal" "config" - Just dir -> return $ dir "config" + mx <- lookupEnv "CABAL_CONFIG" + case mx of + Just x -> return x + Nothing -> do + mDir <- maybeGetCabalDir + case mDir of + Nothing -> getXdgDirectory XdgConfig $ "cabal" "config" + Just dir -> return $ dir "config" maybeGetCabalDir :: IO (Maybe FilePath) maybeGetCabalDir = do mDir <- lookupEnv "CABAL_DIR" @@ -92,40 +95,42 @@ parseIndex predicate action = do Nothing -> do defaultDir <- getAppUserDataDirectory "cabal" dotCabalExists <- doesDirectoryExist defaultDir - return $ if dotCabalExists - then Just defaultDir - else Nothing - + return $ + if dotCabalExists + then Just defaultDir + else Nothing parseIndex' - :: (Monoid a, NFData a) - => (FilePath -> Bool) - -> (FilePath -> B.ByteString -> IO a) -> FilePath -> IO a + :: (Monoid a, NFData a) + => (FilePath -> Bool) + -> (FilePath -> B.ByteString -> IO a) + -> FilePath + -> IO a parseIndex' predicate action path = do - putStrLn $ "Reading index from: " ++ path - contents <- BSL.readFile path - let entries = Tar.read contents - entries' = Tar.foldEntries cons [] (error . show) entries - foldIO f entries' - + putStrLn $ "Reading index from: " ++ path + contents <- BSL.readFile path + let entries = Tar.read contents + entries' = Tar.foldEntries cons [] (error . show) entries + foldIO f entries' where cons entry entries - | predicate (Tar.entryPath entry) = entry : entries - | otherwise = entries + | predicate (Tar.entryPath entry) = entry : entries + | otherwise = entries f entry = case Tar.entryContent entry of - Tar.NormalFile contents _ - | ".cabal" `isSuffixOf` fpath -> do - bs <- evaluate (BSL.toStrict contents) - res <- action fpath bs - evaluate (force res) - | otherwise -> - return mempty - Tar.Directory -> return mempty - _ -> putStrLn ("Unknown content in " ++ fpath) - >> return mempty - where - fpath = Tar.entryPath entry + Tar.NormalFile contents _ + | ".cabal" `isSuffixOf` fpath -> do + bs <- evaluate (BSL.toStrict contents) + res <- action fpath bs + evaluate (force res) + | otherwise -> + return mempty + Tar.Directory -> return mempty + _ -> + putStrLn ("Unknown content in " ++ fpath) + >> return mempty + where + fpath = Tar.entryPath entry ------------------------------------------------------------------------------- -- readFields tests: very fast test for 'readFields' - first step of parser @@ -133,11 +138,11 @@ parseIndex' predicate action path = do readFieldTest :: FilePath -> B.ByteString -> IO () readFieldTest fpath bs = case Parsec.readFields bs' of - Right _ -> return () - Left err -> do - putStrLn fpath - print err - exitFailure + Right _ -> return () + Left err -> do + putStrLn fpath + print err + exitFailure where (_, bs') = patchQuirks bs @@ -147,23 +152,25 @@ readFieldTest fpath bs = case Parsec.readFields bs' of parseParsecTest :: Bool -> FilePath -> B.ByteString -> IO ParsecResult parseParsecTest keepGoing fpath bs = do - let (warnings, result) = Parsec.runParseResult $ - Parsec.parseGenericPackageDescription bs - - let w | null warnings = 0 - | otherwise = 1 - - case result of - Right gpd -> do - forEachGPD fpath bs gpd - return (ParsecResult 1 w 0) - - Left (_, errors) | keepGoing -> do - traverse_ (putStrLn . Parsec.showPError fpath) errors - return (ParsecResult 1 w 1) - | otherwise -> do - traverse_ (putStrLn . Parsec.showPError fpath) errors - exitFailure + let (warnings, result) = + Parsec.runParseResult $ + Parsec.parseGenericPackageDescription bs + + let w + | null warnings = 0 + | otherwise = 1 + + case result of + Right gpd -> do + forEachGPD fpath bs gpd + return (ParsecResult 1 w 0) + Left (_, errors) + | keepGoing -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + return (ParsecResult 1 w 1) + | otherwise -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + exitFailure -- | A hook to make queries on Hackage forEachGPD :: FilePath -> B8.ByteString -> L.GenericPackageDescription -> IO () @@ -177,14 +184,14 @@ data ParsecResult = ParsecResult !Int !Int !Int deriving (Eq, Show) instance Semigroup ParsecResult where - ParsecResult x y z <> ParsecResult u v w = ParsecResult (x + u) (y + v) (z + w) + ParsecResult x y z <> ParsecResult u v w = ParsecResult (x + u) (y + v) (z + w) instance Monoid ParsecResult where - mempty = ParsecResult 0 0 0 - mappend = (<>) + mempty = ParsecResult 0 0 0 + mappend = (<>) instance NFData ParsecResult where - rnf (ParsecResult _ _ _) = () + rnf (ParsecResult _ _ _) = () ------------------------------------------------------------------------------- -- Check test @@ -192,22 +199,23 @@ instance NFData ParsecResult where parseCheckTest :: FilePath -> B.ByteString -> IO CheckResult parseCheckTest fpath bs = do - let (warnings, parsec) = Parsec.runParseResult $ - Parsec.parseGenericPackageDescription bs - case parsec of - Right gpd -> do - let checks = checkPackage gpd Nothing - let w [] = 0 - w _ = 1 - - -- Look into invalid cpp options - -- _ <- L.traverseBuildInfos checkCppFlags gpd - - -- one for file, many checks - return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks) - Left (_, errors) -> do - traverse_ (putStrLn . Parsec.showPError fpath) errors - exitFailure + let (warnings, parsec) = + Parsec.runParseResult $ + Parsec.parseGenericPackageDescription bs + case parsec of + Right gpd -> do + let checks = checkPackage gpd Nothing + let w [] = 0 + w _ = 1 + + -- Look into invalid cpp options + -- _ <- L.traverseBuildInfos checkCppFlags gpd + + -- one for file, many checks + return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks) + Left (_, errors) -> do + traverse_ (putStrLn . Parsec.showPError fpath) errors + exitFailure -- checkCppFlags :: BuildInfo -> IO BuildInfo -- checkCppFlags bi = do @@ -220,22 +228,22 @@ parseCheckTest fpath bs = do data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int !Int instance NFData CheckResult where - rnf !_ = () + rnf !_ = () instance Semigroup CheckResult where - CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' = - CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f') + CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' = + CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f') instance Monoid CheckResult where - mempty = CheckResult 0 0 0 0 0 0 0 0 - mappend = (<>) + mempty = CheckResult 0 0 0 0 0 0 0 0 + mappend = (<>) toCheckResult :: PackageCheck -> CheckResult -toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 1 0 0 0 0 -toCheckResult PackageBuildWarning {} = CheckResult 0 0 1 0 1 0 0 0 -toCheckResult PackageDistSuspicious {} = CheckResult 0 0 1 0 0 1 0 0 -toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 1 0 0 0 1 0 -toCheckResult PackageDistInexcusable {} = CheckResult 0 0 1 0 0 0 0 1 +toCheckResult PackageBuildImpossible{} = CheckResult 0 0 1 1 0 0 0 0 +toCheckResult PackageBuildWarning{} = CheckResult 0 0 1 0 1 0 0 0 +toCheckResult PackageDistSuspicious{} = CheckResult 0 0 1 0 0 1 0 0 +toCheckResult PackageDistSuspiciousWarn{} = CheckResult 0 0 1 0 0 0 1 0 +toCheckResult PackageDistInexcusable{} = CheckResult 0 0 1 0 0 0 0 1 ------------------------------------------------------------------------------- -- Roundtrip test @@ -243,44 +251,44 @@ toCheckResult PackageDistInexcusable {} = CheckResult 0 0 1 0 0 0 0 1 roundtripTest :: Bool -> FilePath -> B.ByteString -> IO (Sum Int) roundtripTest testFieldsTransform fpath bs = do - x0 <- parse "1st" bs - let bs' = showGenericPackageDescription x0 - y0 <- parse "2nd" (toUTF8BS bs') - - -- strip description, there are format variations - let y = y0 & L.packageDescription . L.description .~ mempty - let x = x0 & L.packageDescription . L.description .~ mempty - - assertEqual' bs' x y - - -- fromParsecField, "shallow" parser/pretty roundtrip - when testFieldsTransform $ - if checkUTF8 patchedBs - then do - parsecFields <- assertRight $ Parsec.readFields patchedBs - let prettyFields = PP.fromParsecFields parsecFields - let bs'' = PP.showFields (return PP.NoComment) prettyFields - z0 <- parse "3rd" (toUTF8BS bs'') - - -- note: we compare "raw" GPDs, on purpose; stricter equality - assertEqual' bs'' x0 z0 - else - putStrLn $ fpath ++ " : looks like invalid UTF8" - - return (Sum 1) + x0 <- parse "1st" bs + let bs' = showGenericPackageDescription x0 + y0 <- parse "2nd" (toUTF8BS bs') + + -- strip description, there are format variations + let y = y0 & L.packageDescription . L.description .~ mempty + let x = x0 & L.packageDescription . L.description .~ mempty + + assertEqual' bs' x y + + -- fromParsecField, "shallow" parser/pretty roundtrip + when testFieldsTransform $ + if checkUTF8 patchedBs + then do + parsecFields <- assertRight $ Parsec.readFields patchedBs + let prettyFields = PP.fromParsecFields parsecFields + let bs'' = PP.showFields (return PP.NoComment) prettyFields + z0 <- parse "3rd" (toUTF8BS bs'') + + -- note: we compare "raw" GPDs, on purpose; stricter equality + assertEqual' bs'' x0 z0 + else putStrLn $ fpath ++ " : looks like invalid UTF8" + + return (Sum 1) where patchedBs = snd (patchQuirks bs) - checkUTF8 bs' = replacementChar `notElem` fromUTF8BS bs' where + checkUTF8 bs' = replacementChar `notElem` fromUTF8BS bs' + where replacementChar = '\xfffd' - assertRight (Right x) = return x assertRight (Left err) = do - putStrLn fpath - print err - exitFailure + putStrLn fpath + print err + exitFailure +{- FOURMOLU_DISABLE -} assertEqual' bs' x y = unless (x == y || fpath == "ixset/1.0.4/ixset.cabal") $ do putStrLn fpath #ifdef MIN_VERSION_tree_diff @@ -307,6 +315,7 @@ roundtripTest testFieldsTransform fpath bs = do traverse_ print errs B.putStr c fail "parse error" +{- FOURMOLU_ENABLE -} ------------------------------------------------------------------------------- -- Main @@ -315,76 +324,90 @@ roundtripTest testFieldsTransform fpath bs = do main :: IO () main = join (O.execParser opts) where - opts = O.info (optsP <**> O.helper) $ mconcat - [ O.fullDesc - , O.progDesc "tests using Hackage's index" + opts = + O.info (optsP <**> O.helper) $ + mconcat + [ O.fullDesc + , O.progDesc "tests using Hackage's index" + ] + + optsP = + subparser + [ command + "read-fields" + readFieldsP + "Parse outer format (to '[Field]', TODO: apply Quirks)" + , command "parsec" parsecP "Parse GPD with parsec" + , command "roundtrip" roundtripP "parse . pretty . parse = parse" + , command "check" checkP "Check GPD" ] - - optsP = subparser - [ command "read-fields" readFieldsP - "Parse outer format (to '[Field]', TODO: apply Quirks)" - , command "parsec" parsecP "Parse GPD with parsec" - , command "roundtrip" roundtripP "parse . pretty . parse = parse" - , command "check" checkP "Check GPD" - ] <|> pure defaultA + <|> pure defaultA defaultA = do - putStrLn "Default action: parsec k" - parsecA (mkPredicate ["k"]) False + putStrLn "Default action: parsec k" + parsecA (mkPredicate ["k"]) False readFieldsP = readFieldsA <$> prefixP readFieldsA pfx = parseIndex pfx readFieldTest parsecP = parsecA <$> prefixP <*> keepGoingP keepGoingP = - O.flag' True (O.long "keep-going") <|> - O.flag' False (O.long "no-keep-going") <|> - pure False + O.flag' True (O.long "keep-going") + <|> O.flag' False (O.long "no-keep-going") + <|> pure False parsecA pfx keepGoing = do - begin <- Clock.getTime Clock.Monotonic - ParsecResult n w f <- parseIndex pfx (parseParsecTest keepGoing) - end <- Clock.getTime Clock.Monotonic - let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin + begin <- Clock.getTime Clock.Monotonic + ParsecResult n w f <- parseIndex pfx (parseParsecTest keepGoing) + end <- Clock.getTime Clock.Monotonic + let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin - putStrLn $ show n ++ " files processed" - putStrLn $ show w ++ " files contained warnings" - putStrLn $ show f ++ " files failed to parse" - putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed" - putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file" + putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " files contained warnings" + putStrLn $ show f ++ " files failed to parse" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file" roundtripP = roundtripA <$> prefixP <*> testFieldsP roundtripA pfx testFieldsTransform = do - Sum n <- parseIndex pfx (roundtripTest testFieldsTransform) - putStrLn $ show n ++ " files processed" + Sum n <- parseIndex pfx (roundtripTest testFieldsTransform) + putStrLn $ show n ++ " files processed" checkP = checkA <$> prefixP checkA pfx = do - CheckResult n w x a b c d e <- parseIndex pfx parseCheckTest - putStrLn $ show n ++ " files processed" - putStrLn $ show w ++ " files have lexer/parser warnings" - putStrLn $ show x ++ " files have check warnings" - putStrLn $ show a ++ " build impossible" - putStrLn $ show b ++ " build warning" - putStrLn $ show c ++ " build dist suspicious" - putStrLn $ show d ++ " build dist suspicious warning" - putStrLn $ show e ++ " build dist inexcusable" - - prefixP = fmap mkPredicate $ many $ O.strArgument $ mconcat - [ O.metavar "PREFIX" - , O.help "Check only files starting with a prefix" - ] - - testFieldsP = O.switch $ mconcat - [ O.long "fields-transform" - , O.help "Test also 'showFields . fromParsecFields . readFields' transform" - ] + CheckResult n w x a b c d e <- parseIndex pfx parseCheckTest + putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " files have lexer/parser warnings" + putStrLn $ show x ++ " files have check warnings" + putStrLn $ show a ++ " build impossible" + putStrLn $ show b ++ " build warning" + putStrLn $ show c ++ " build dist suspicious" + putStrLn $ show d ++ " build dist suspicious warning" + putStrLn $ show e ++ " build dist inexcusable" + + prefixP = + fmap mkPredicate $ + many $ + O.strArgument $ + mconcat + [ O.metavar "PREFIX" + , O.help "Check only files starting with a prefix" + ] + + testFieldsP = + O.switch $ + mconcat + [ O.long "fields-transform" + , O.help "Test also 'showFields . fromParsecFields . readFields' transform" + ] mkPredicate [] = const True mkPredicate pfxs = \n -> any (`isPrefixOf` n) pfxs - command name p desc = O.command name - (O.info (p <**> O.helper) (O.progDesc desc)) + command name p desc = + O.command + name + (O.info (p <**> O.helper) (O.progDesc desc)) subparser = O.subparser . mconcat ------------------------------------------------------------------------------- @@ -396,10 +419,14 @@ reposFromConfig :: [Parsec.Field ann] -> [String] reposFromConfig fields = takeWhile (/= ':') <$> mapMaybe f fields where f (Parsec.Field (Parsec.Name _ name) fieldLines) - | B8.unpack name == "remote-repo" = - Just $ fieldLinesToString fieldLines - f (Parsec.Section (Parsec.Name _ name) - [Parsec.SecArgName _ secName] _fieldLines) + | B8.unpack name == "remote-repo" = + Just $ fieldLinesToString fieldLines + f + ( Parsec.Section + (Parsec.Name _ name) + [Parsec.SecArgName _ secName] + _fieldLines + ) | B8.unpack name == "repository" = Just $ B8.unpack secName f _ = Nothing @@ -409,13 +436,13 @@ lookupInConfig :: String -> [Parsec.Field ann] -> [String] lookupInConfig key = mapMaybe f where f (Parsec.Field (Parsec.Name _ name) fieldLines) - | B8.unpack name == key = - Just $ fieldLinesToString fieldLines + | B8.unpack name == key = + Just $ fieldLinesToString fieldLines f _ = Nothing fieldLinesToString :: [Parsec.FieldLine ann] -> String fieldLinesToString fieldLines = - B8.unpack $ B.concat $ bsFromFieldLine <$> fieldLines + B8.unpack $ B.concat $ bsFromFieldLine <$> fieldLines where bsFromFieldLine (Parsec.FieldLine _ bs) = bs @@ -427,9 +454,10 @@ fieldLinesToString fieldLines = -- -- First we chunk input (as single cabal file is little work) foldIO :: forall a m. (Monoid m, NFData m) => (a -> IO m) -> [a] -> IO m -foldIO f = go mempty where +foldIO f = go mempty + where go !acc [] = acc - go !acc (x:xs) = go (mappend acc (f x)) xs + go !acc (x : xs) = go (mappend acc (f x)) xs ------------------------------------------------------------------------------- -- Orphans diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs index da422e37c5e..e87792f68a0 100644 --- a/Cabal-tests/tests/NoThunks.hs +++ b/Cabal-tests/tests/NoThunks.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} #if !(__GLASGOW_HASKELL__ >= 806 && defined(MIN_VERSION_nothunks)) module Main (main) where main :: IO () diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 981be3b4cce..0625fe39baf 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -1,32 +1,33 @@ {-# LANGUAGE CPP #-} + module Main - ( main - ) where + ( main + ) where -import Prelude () import Prelude.Compat +import Prelude () import Test.Tasty import Test.Tasty.Golden.Advanced (goldenTest) import Test.Tasty.HUnit -import Control.Monad (unless, void) -import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) -import Data.Maybe (isNothing) -import Distribution.Fields (runParseResult) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Control.Monad (unless, void) +import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) +import Data.Maybe (isNothing) +import Distribution.Fields (runParseResult) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Parsec (PWarnType (..), PWarning (..), showPError, showPWarning) -import Distribution.Pretty (prettyShow) -import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs, withArgs) -import System.FilePath (replaceExtension, ()) - -import qualified Data.ByteString as BS +import Distribution.Parsec (PWarnType (..), PWarning (..), showPError, showPWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.Directory (setCurrentDirectory) +import System.Environment (getArgs, withArgs) +import System.FilePath (replaceExtension, ()) + +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NE import qualified Distribution.InstalledPackageInfo as IPI @@ -37,7 +38,9 @@ import Data.TreeDiff.Instances.Cabal () #endif tests :: TestTree -tests = testGroup "parsec tests" +tests = + testGroup + "parsec tests" [ regressionTests , warningTests , errorTests @@ -50,54 +53,58 @@ tests = testGroup "parsec tests" -- Verify that we trigger warnings warningTests :: TestTree -warningTests = testGroup "warnings triggered" - [ warningTest PWTLexBOM "bom.cabal" - , warningTest PWTLexNBSP "nbsp.cabal" - , warningTest PWTLexTab "tab.cabal" - , warningTest PWTUTF "utf8.cabal" - , warningTest PWTBoolCase "bool.cabal" - , warningTest PWTVersionTag "versiontag.cabal" - , warningTest PWTNewSyntax "newsyntax.cabal" - , warningTest PWTOldSyntax "oldsyntax.cabal" - , warningTest PWTDeprecatedField "deprecatedfield.cabal" +warningTests = + testGroup + "warnings triggered" + [ warningTest PWTLexBOM "bom.cabal" + , warningTest PWTLexNBSP "nbsp.cabal" + , warningTest PWTLexTab "tab.cabal" + , warningTest PWTUTF "utf8.cabal" + , warningTest PWTBoolCase "bool.cabal" + , warningTest PWTVersionTag "versiontag.cabal" + , warningTest PWTNewSyntax "newsyntax.cabal" + , warningTest PWTOldSyntax "oldsyntax.cabal" + , warningTest PWTDeprecatedField "deprecatedfield.cabal" , warningTest PWTInvalidSubsection "subsection.cabal" - , warningTest PWTUnknownField "unknownfield.cabal" - , warningTest PWTUnknownSection "unknownsection.cabal" - , warningTest PWTTrailingFields "trailingfield.cabal" - , warningTest PWTDoubleDash "doubledash.cabal" + , warningTest PWTUnknownField "unknownfield.cabal" + , warningTest PWTUnknownSection "unknownsection.cabal" + , warningTest PWTTrailingFields "trailingfield.cabal" + , warningTest PWTDoubleDash "doubledash.cabal" , warningTest PWTMultipleSingularField "multiplesingular.cabal" - , warningTest PWTVersionWildcard "wildcard.cabal" - , warningTest PWTVersionOperator "operator.cabal" - , warningTest PWTSpecVersion "specversion-a.cabal" - , warningTest PWTSpecVersion "specversion-b.cabal" - , warningTest PWTSpecVersion "specversion-c.cabal" + , warningTest PWTVersionWildcard "wildcard.cabal" + , warningTest PWTVersionOperator "operator.cabal" + , warningTest PWTSpecVersion "specversion-a.cabal" + , warningTest PWTSpecVersion "specversion-b.cabal" + , warningTest PWTSpecVersion "specversion-c.cabal" -- TODO: not implemented yet -- , warningTest PWTExtraTestModule "extratestmodule.cabal" ] warningTest :: PWarnType -> FilePath -> TestTree warningTest wt fp = testCase (show wt) $ do - contents <- BS.readFile $ "tests" "ParserTests" "warnings" fp + contents <- BS.readFile $ "tests" "ParserTests" "warnings" fp - let res = parseGenericPackageDescription contents - let (warns, x) = runParseResult res + let res = parseGenericPackageDescription contents + let (warns, x) = runParseResult res - assertBool ("should parse successfully: " ++ show x) $ isRight x + assertBool ("should parse successfully: " ++ show x) $ isRight x - case warns of - [PWarning wt' _ _] -> assertEqual "warning type" wt wt' - [] -> assertFailure "got no warnings" - _ -> assertFailure $ "got multiple warnings: " ++ show warns + case warns of + [PWarning wt' _ _] -> assertEqual "warning type" wt wt' + [] -> assertFailure "got no warnings" + _ -> assertFailure $ "got multiple warnings: " ++ show warns where isRight (Right _) = True - isRight _ = False + isRight _ = False ------------------------------------------------------------------------------- -- Errors ------------------------------------------------------------------------------- errorTests :: TestTree -errorTests = testGroup "errors" +errorTests = + testGroup + "errors" [ errorTest "common1.cabal" , errorTest "common2.cabal" , errorTest "common3.cabal" @@ -134,16 +141,16 @@ errorTests = testGroup "errors" errorTest :: FilePath -> TestTree errorTest fp = cabalGoldenTest fp correct $ do - contents <- BS.readFile input - let res = parseGenericPackageDescription contents - let (_, x) = runParseResult res - - return $ toUTF8BS $ case x of - Right gpd -> - "UNXPECTED SUCCESS\n" ++ - showGenericPackageDescription gpd - Left (v, errs) -> - unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs) + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (_, x) = runParseResult res + + return $ toUTF8BS $ case x of + Right gpd -> + "UNXPECTED SUCCESS\n" + ++ showGenericPackageDescription gpd + Left (v, errs) -> + unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs) where input = "tests" "ParserTests" "errors" fp correct = replaceExtension input "errors" @@ -153,7 +160,9 @@ errorTest fp = cabalGoldenTest fp correct $ do ------------------------------------------------------------------------------- regressionTests :: TestTree -regressionTests = testGroup "regressions" +regressionTests = + testGroup + "regressions" [ regressionTest "encoding-0.8.cabal" , regressionTest "Octree-0.5.cabal" , regressionTest "nothing-unicode.cabal" @@ -198,6 +207,7 @@ regressionTests = testGroup "regressions" , regressionTest "hasktorch.cabal" ] +{- FOURMOLU_DISABLE -} regressionTest :: FilePath -> TestTree regressionTest fp = testGroup fp [ formatGoldenTest fp @@ -206,22 +216,23 @@ regressionTest fp = testGroup fp , treeDiffGoldenTest fp #endif ] +{- FOURMOLU_ENABLE -} formatGoldenTest :: FilePath -> TestTree formatGoldenTest fp = cabalGoldenTest "format" correct $ do - contents <- BS.readFile input - let res = parseGenericPackageDescription contents - let (warns, x) = runParseResult res - - return $ toUTF8BS $ case x of - Right gpd -> - unlines (map (showPWarning fp) warns) - ++ showGenericPackageDescription gpd - Left (csv, errs) -> - unlines $ - "ERROR" : - maybe "unknown-version" prettyShow csv : - map (showPError fp) (NE.toList errs) + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (warns, x) = runParseResult res + + return $ toUTF8BS $ case x of + Right gpd -> + unlines (map (showPWarning fp) warns) + ++ showGenericPackageDescription gpd + Left (csv, errs) -> + unlines $ + "ERROR" + : maybe "unknown-version" prettyShow csv + : map (showPError fp) (NE.toList errs) where input = "tests" "ParserTests" "regressions" fp correct = replaceExtension input "format" @@ -240,6 +251,7 @@ treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do exprFile = replaceExtension input "expr" #endif +{- FOURMOLU_DISABLE -} formatRoundTripTest :: FilePath -> TestTree formatRoundTripTest fp = testCase "roundtrip" $ do contents <- BS.readFile input @@ -273,19 +285,23 @@ formatRoundTripTest fp = testCase "roundtrip" $ do void $ assertFailure $ unlines (map (showPError fp) $ NE.toList errs) fail "failure" input = "tests" "ParserTests" "regressions" fp +{- FOURMOLU_ENABLE -} ------------------------------------------------------------------------------- -- InstalledPackageInfo regressions ------------------------------------------------------------------------------- ipiTests :: TestTree -ipiTests = testGroup "ipis" +ipiTests = + testGroup + "ipis" [ ipiTest "transformers.cabal" , ipiTest "Includes2.cabal" , ipiTest "issue-2276-ghc-9885.cabal" , ipiTest "internal-preprocessor-test.cabal" ] +{- FOURMOLU_DISABLE -} ipiTest :: FilePath -> TestTree ipiTest fp = testGroup fp $ #ifdef MIN_VERSION_tree_diff @@ -294,15 +310,16 @@ ipiTest fp = testGroup fp $ [ ipiFormatGoldenTest fp , ipiFormatRoundTripTest fp ] +{- FOURMOLU_ENABLE -} ipiFormatGoldenTest :: FilePath -> TestTree ipiFormatGoldenTest fp = cabalGoldenTest "format" correct $ do - contents <- BS.readFile input - let res = IPI.parseInstalledPackageInfo contents - return $ toUTF8BS $ case res of - Left err -> "ERROR " ++ show err - Right (ws, ipi) -> - unlines ws ++ IPI.showInstalledPackageInfo ipi + contents <- BS.readFile input + let res = IPI.parseInstalledPackageInfo contents + return $ toUTF8BS $ case res of + Left err -> "ERROR " ++ show err + Right (ws, ipi) -> + unlines ws ++ IPI.showInstalledPackageInfo ipi where input = "tests" "ParserTests" "ipi" fp correct = replaceExtension input "format" @@ -322,30 +339,29 @@ ipiTreeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do ipiFormatRoundTripTest :: FilePath -> TestTree ipiFormatRoundTripTest fp = testCase "roundtrip" $ do - contents <- BS.readFile input - x <- parse contents - let contents' = IPI.showInstalledPackageInfo x - y <- parse (toUTF8BS contents') - - -- ghc-pkg prints pkgroot itself, based on cli arguments! - let x' = x { IPI.pkgRoot = Nothing } - let y' = y - assertBool "pkgRoot isn't shown" (isNothing (IPI.pkgRoot y)) - assertEqual "re-parsed doesn't match" x' y' - - -- Complete round-trip - let contents2 = IPI.showFullInstalledPackageInfo x - z <- parse (toUTF8BS contents2) - assertEqual "re-parsed doesn't match" x z - + contents <- BS.readFile input + x <- parse contents + let contents' = IPI.showInstalledPackageInfo x + y <- parse (toUTF8BS contents') + + -- ghc-pkg prints pkgroot itself, based on cli arguments! + let x' = x{IPI.pkgRoot = Nothing} + let y' = y + assertBool "pkgRoot isn't shown" (isNothing (IPI.pkgRoot y)) + assertEqual "re-parsed doesn't match" x' y' + + -- Complete round-trip + let contents2 = IPI.showFullInstalledPackageInfo x + z <- parse (toUTF8BS contents2) + assertEqual "re-parsed doesn't match" x z where parse :: BS.ByteString -> IO IPI.InstalledPackageInfo parse c = do - case IPI.parseInstalledPackageInfo c of - Right (_, ipi) -> return ipi - Left err -> do - void $ assertFailure $ show err - fail "failure" + case IPI.parseInstalledPackageInfo c of + Right (_, ipi) -> return ipi + Left err -> do + void $ assertFailure $ show err + fail "failure" input = "tests" "ParserTests" "ipi" fp ------------------------------------------------------------------------------- @@ -354,22 +370,25 @@ ipiFormatRoundTripTest fp = testCase "roundtrip" $ do main :: IO () main = do - args <- getArgs - case args of - ("--cwd" : cwd : args') -> do - setCurrentDirectory cwd - withArgs args' $ defaultMain tests - _ -> defaultMain tests + args <- getArgs + case args of + ("--cwd" : cwd : args') -> do + setCurrentDirectory cwd + withArgs args' $ defaultMain tests + _ -> defaultMain tests cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd where upd = BS.writeFile ref cmp x y | x == y = return Nothing - cmp x y = return $ Just $ unlines $ - concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) + cmp x y = + return $ + Just $ + unlines $ + concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y)) where - f (First xs) = map (cons3 '-' . fromUTF8BS) xs + f (First xs) = map (cons3 '-' . fromUTF8BS) xs f (Second ys) = map (cons3 '+' . fromUTF8BS) ys -- we print unchanged lines too. It shouldn't be a problem while we have -- reasonably small examples diff --git a/Cabal-tests/tests/RPMVerCmp.hs b/Cabal-tests/tests/RPMVerCmp.hs index 2d766e5f7e7..1f60def3fc3 100644 --- a/Cabal-tests/tests/RPMVerCmp.hs +++ b/Cabal-tests/tests/RPMVerCmp.hs @@ -1,36 +1,38 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where +import Data.Bits ((.&.)) import Foreign.C.String (CString) -import Foreign.C.Types (CInt (..)) +import Foreign.C.Types (CInt (..)) import System.IO.Unsafe (unsafePerformIO) -import Data.Bits ((.&.)) -import Test.QuickCheck (Arbitrary (..), (===)) -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) +import Test.QuickCheck (Arbitrary (..), (===)) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) import Test.Tasty.QuickCheck (testProperty) -import Distribution.Pretty (prettyShow) +import Distribution.Pretty (prettyShow) import Distribution.Types.PkgconfigVersion (rpmvercmp) import Distribution.Types.Version -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 ------------------------------------------------------------------------------- -- C reference implementation ------------------------------------------------------------------------------- -foreign import ccall unsafe "rpmvercmp" c_rmpvercmp +foreign import ccall unsafe "rpmvercmp" + c_rmpvercmp :: CString -> CString -> CInt rpmvercmpRef :: BS.ByteString -> BS.ByteString -> Ordering rpmvercmpRef a b = unsafePerformIO $ - BS.useAsCString a $ \a' -> + BS.useAsCString a $ \a' -> BS.useAsCString b $ \b' -> - return $ fromInt $ c_rmpvercmp a' b' + return $ fromInt $ c_rmpvercmp a' b' where fromInt = flip compare 0 @@ -39,46 +41,50 @@ rpmvercmpRef a b = unsafePerformIO $ ------------------------------------------------------------------------------- main :: IO () -main = defaultMain $ testGroup "rpmvercmp" - [ testGroup "examples" - [ example "openssl" "1.1.0g" "1.1.0i" LT - , example "openssl" "1.0.2h" "1.1.0" LT - - , example "simple" "1.2.3" "1.2.4" LT - , example "word" "apple" "banana" LT - - , example "corner case" "r" "" GT - , example "corner case" "0" "1" LT - , example "corner case" "1" "0.0" GT - ] - , testGroup "Properties" - [ testProperty "ref reflexive" $ \a -> - rpmvercmpRef (BS.pack a) (BS.pack a) === EQ - , testProperty "pure reflexive" $ \a -> - rpmvercmp (BS.pack a) (BS.pack a) === EQ - , testProperty "ref agrees with Version" $ \a b -> - compare a b === rpmvercmpRef (v2bs a) (v2bs b) - , testProperty "pure agrees with Version" $ \a b -> - compare a b === rpmvercmp (v2bs a) (v2bs b) - ] - , testGroup "Random inputs" - [ testProperty "random" $ \xs ys -> - -- only 7bit numbers, no zero, and non-empty. - let xs' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) xs - ys' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) ys - - -- ref doesn't really work with empty inputs reliably. - unnull [] = [1] - unnull zs = zs - in rpmvercmpRef xs' ys' === rpmvercmp xs' ys' - ] - ] +main = + defaultMain $ + testGroup + "rpmvercmp" + [ testGroup + "examples" + [ example "openssl" "1.1.0g" "1.1.0i" LT + , example "openssl" "1.0.2h" "1.1.0" LT + , example "simple" "1.2.3" "1.2.4" LT + , example "word" "apple" "banana" LT + , example "corner case" "r" "" GT + , example "corner case" "0" "1" LT + , example "corner case" "1" "0.0" GT + ] + , testGroup + "Properties" + [ testProperty "ref reflexive" $ \a -> + rpmvercmpRef (BS.pack a) (BS.pack a) === EQ + , testProperty "pure reflexive" $ \a -> + rpmvercmp (BS.pack a) (BS.pack a) === EQ + , testProperty "ref agrees with Version" $ \a b -> + compare a b === rpmvercmpRef (v2bs a) (v2bs b) + , testProperty "pure agrees with Version" $ \a b -> + compare a b === rpmvercmp (v2bs a) (v2bs b) + ] + , testGroup + "Random inputs" + [ testProperty "random" $ \xs ys -> + -- only 7bit numbers, no zero, and non-empty. + let xs' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) xs + ys' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) ys + + -- ref doesn't really work with empty inputs reliably. + unnull [] = [1] + unnull zs = zs + in rpmvercmpRef xs' ys' === rpmvercmp xs' ys' + ] + ] where example n a b c = testCase (n ++ " " ++ BS8.unpack a ++ " <=> " ++ BS8.unpack b) $ do - let ref = rpmvercmpRef a b - let pur = rpmvercmp a b - assertEqual "ref" c ref - assertEqual "pure" c pur + let ref = rpmvercmpRef a b + let pur = rpmvercmp a b + assertEqual "ref" c ref + assertEqual "pure" c pur ------------------------------------------------------------------------------- -- Version arbitrary @@ -91,9 +97,9 @@ unV :: V -> Version unV (V x) = x instance Arbitrary V where - arbitrary = fmap (V . mkVersion_) arbitrary + arbitrary = fmap (V . mkVersion_) arbitrary - shrink = map V . filter (/= version0) . map mkVersion_ . shrink . versionNumbers . unV + shrink = map V . filter (/= version0) . map mkVersion_ . shrink . versionNumbers . unV mkVersion_ :: [Int] -> Version mkVersion_ [] = version0 diff --git a/Cabal-tests/tests/Test/Laws.hs b/Cabal-tests/tests/Test/Laws.hs index 351cee7f0c6..82d79c54cb2 100644 --- a/Cabal-tests/tests/Test/Laws.hs +++ b/Cabal-tests/tests/Test/Laws.hs @@ -1,11 +1,12 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} + module Test.Laws where -import Prelude hiding (Num((+), (*))) -import Data.Monoid (Monoid(..), Endo(..)) import qualified Data.Foldable as Foldable +import Data.Monoid (Endo (..), Monoid (..)) +import Prelude hiding (Num ((*), (+))) -idempotent_unary f x = f fx == fx where fx = f x +idempotent_unary f x = f fx == fx where fx = f x -- Basic laws on binary operators @@ -13,67 +14,64 @@ idempotent_binary (+) x = x + x == x commutative (+) x y = x + y == y + x -associative (+) x y z = (x + y) + z == x + (y + z) +associative (+) x y z = (x + y) + z == x + (y + z) -distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) +distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x) - -- | The first 'fmap' law -- -- > fmap id == id --- fmap_1 :: (Eq (f a), Functor f) => f a -> Bool fmap_1 x = fmap id x == x -- | The second 'fmap' law -- -- > fmap (f . g) == fmap f . fmap g --- fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x - -- | The monoid identity law, 'mempty' is a left and right identity of -- 'mappend': -- -- > mempty `mappend` x = x -- > x `mappend` mempty = x --- monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool -monoid_1 x = mempty `mappend` x == x - && x `mappend` mempty == x +monoid_1 x = + mempty `mappend` x == x + && x `mappend` mempty == x -- | The monoid associativity law, 'mappend' must be associative. -- -- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z) --- monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool -monoid_2 x y z = (x `mappend` y) `mappend` z - == x `mappend` (y `mappend` z) +monoid_2 x y z = + (x `mappend` y) `mappend` z + == x `mappend` (y `mappend` z) -- | The 'mconcat' definition. It can be overridden for the sake of efficiency -- but it must still satisfy the property given by the default definition: -- -- > mconcat = foldr mappend mempty --- monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool monoid_3 xs = mconcat xs == foldr mappend mempty xs - -- | First 'Foldable' law -- -- > Foldable.fold = Foldable.foldr mappend mempty --- foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x -- | Second 'Foldable' law -- -- > foldr f z t = appEndo (foldMap (Endo . f) t) z --- -foldable_2 :: (Foldable.Foldable t, Eq b) - => (a -> b -> b) -> b -> t a -> Bool -foldable_2 f z t = Foldable.foldr f z t - == appEndo (Foldable.foldMap (Endo . f) t) z +foldable_2 + :: (Foldable.Foldable t, Eq b) + => (a -> b -> b) + -> b + -> t a + -> Bool +foldable_2 f z t = + Foldable.foldr f z t + == appEndo (Foldable.foldMap (Endo . f) t) z diff --git a/Cabal-tests/tests/Test/QuickCheck/Utils.hs b/Cabal-tests/tests/Test/QuickCheck/Utils.hs index 72b517be24f..66eb75c601b 100644 --- a/Cabal-tests/tests/Test/QuickCheck/Utils.hs +++ b/Cabal-tests/tests/Test/QuickCheck/Utils.hs @@ -2,7 +2,6 @@ module Test.QuickCheck.Utils where import Test.QuickCheck.Gen - -- | Adjust the size of the generated value. -- -- In general the size gets bigger and bigger linearly. For some types @@ -24,6 +23,5 @@ import Test.QuickCheck.Gen -- -- Not only do we put a limit on the length but we also scale the growth to -- prevent it from hitting the maximum size quite so early. --- adjustSize :: (Int -> Int) -> Gen a -> Gen a adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/Cabal-tests/tests/UnitTests.hs b/Cabal-tests/tests/UnitTests.hs index cf4128c05c9..1c83623cac7 100644 --- a/Cabal-tests/tests/UnitTests.hs +++ b/Cabal-tests/tests/UnitTests.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} + module Main - ( main - ) where + ( main + ) where import Test.Tasty import Test.Tasty.Options @@ -9,18 +10,23 @@ import Test.Tasty.Options import Data.Proxy import Data.Typeable +import Distribution.Compat.Time import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Compat.Time -import qualified UnitTests.Distribution.Compat.Time +import qualified UnitTests.Distribution.CabalSpecVersion import qualified UnitTests.Distribution.Compat.Graph +import qualified UnitTests.Distribution.Compat.Time +import qualified UnitTests.Distribution.Described +import qualified UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) +import qualified UnitTests.Distribution.SPDX (spdxTests) import qualified UnitTests.Distribution.Simple.Command import qualified UnitTests.Distribution.Simple.Glob import qualified UnitTests.Distribution.Simple.Program.GHC import qualified UnitTests.Distribution.Simple.Program.Internal import qualified UnitTests.Distribution.Simple.Utils import qualified UnitTests.Distribution.System +import qualified UnitTests.Distribution.Types.GenericPackageDescription import qualified UnitTests.Distribution.Utils.CharSet import qualified UnitTests.Distribution.Utils.Generic import qualified UnitTests.Distribution.Utils.Json @@ -28,57 +34,66 @@ import qualified UnitTests.Distribution.Utils.NubList import qualified UnitTests.Distribution.Utils.ShortText import qualified UnitTests.Distribution.Utils.Structured import qualified UnitTests.Distribution.Version (versionTests) -import qualified UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) -import qualified UnitTests.Distribution.SPDX (spdxTests) -import qualified UnitTests.Distribution.Described -import qualified UnitTests.Distribution.CabalSpecVersion -import qualified UnitTests.Distribution.Types.GenericPackageDescription tests :: Int -> TestTree tests mtimeChangeCalibrated = askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> - askOption $ \(GhcPath ghcPath) -> - let mtimeChange = if mtimeChangeProvided /= 0 - then mtimeChangeProvided - else mtimeChangeCalibrated - in - testGroup "Unit Tests" - [ testGroup "Distribution.Compat.Time" - (UnitTests.Distribution.Compat.Time.tests mtimeChange) - , testGroup "Distribution.Compat.Graph" - UnitTests.Distribution.Compat.Graph.tests - , testGroup "Distribution.Simple.Command" - UnitTests.Distribution.Simple.Command.tests - , testGroup "Distribution.Simple.Glob" - UnitTests.Distribution.Simple.Glob.tests - , UnitTests.Distribution.Simple.Program.GHC.tests - , testGroup "Distribution.Simple.Program.Internal" - UnitTests.Distribution.Simple.Program.Internal.tests - , testGroup "Distribution.Simple.Utils" $ - UnitTests.Distribution.Simple.Utils.tests ghcPath - , testGroup "Distribution.Utils.Generic" - UnitTests.Distribution.Utils.Generic.tests - , testGroup "Distribution.Utils.Json" $ - UnitTests.Distribution.Utils.Json.tests - , testGroup "Distribution.Utils.NubList" - UnitTests.Distribution.Utils.NubList.tests - , testGroup "Distribution.Utils.ShortText" - UnitTests.Distribution.Utils.ShortText.tests - , testGroup "Distribution.System" - UnitTests.Distribution.System.tests - , testGroup "Distribution.Types.GenericPackageDescription" - UnitTests.Distribution.Types.GenericPackageDescription.tests - , testGroup "Distribution.Version" - UnitTests.Distribution.Version.versionTests - , testGroup "Distribution.Types.PkgconfigVersion(Range)" - UnitTests.Distribution.PkgconfigVersion.pkgconfigVersionTests - , testGroup "Distribution.SPDX" - UnitTests.Distribution.SPDX.spdxTests - , UnitTests.Distribution.Utils.CharSet.tests - , UnitTests.Distribution.Utils.Structured.tests - , UnitTests.Distribution.Described.tests - , UnitTests.Distribution.CabalSpecVersion.tests - ] + askOption $ \(GhcPath ghcPath) -> + let mtimeChange = + if mtimeChangeProvided /= 0 + then mtimeChangeProvided + else mtimeChangeCalibrated + in testGroup + "Unit Tests" + [ testGroup + "Distribution.Compat.Time" + (UnitTests.Distribution.Compat.Time.tests mtimeChange) + , testGroup + "Distribution.Compat.Graph" + UnitTests.Distribution.Compat.Graph.tests + , testGroup + "Distribution.Simple.Command" + UnitTests.Distribution.Simple.Command.tests + , testGroup + "Distribution.Simple.Glob" + UnitTests.Distribution.Simple.Glob.tests + , UnitTests.Distribution.Simple.Program.GHC.tests + , testGroup + "Distribution.Simple.Program.Internal" + UnitTests.Distribution.Simple.Program.Internal.tests + , testGroup "Distribution.Simple.Utils" $ + UnitTests.Distribution.Simple.Utils.tests ghcPath + , testGroup + "Distribution.Utils.Generic" + UnitTests.Distribution.Utils.Generic.tests + , testGroup "Distribution.Utils.Json" $ + UnitTests.Distribution.Utils.Json.tests + , testGroup + "Distribution.Utils.NubList" + UnitTests.Distribution.Utils.NubList.tests + , testGroup + "Distribution.Utils.ShortText" + UnitTests.Distribution.Utils.ShortText.tests + , testGroup + "Distribution.System" + UnitTests.Distribution.System.tests + , testGroup + "Distribution.Types.GenericPackageDescription" + UnitTests.Distribution.Types.GenericPackageDescription.tests + , testGroup + "Distribution.Version" + UnitTests.Distribution.Version.versionTests + , testGroup + "Distribution.Types.PkgconfigVersion(Range)" + UnitTests.Distribution.PkgconfigVersion.pkgconfigVersionTests + , testGroup + "Distribution.SPDX" + UnitTests.Distribution.SPDX.spdxTests + , UnitTests.Distribution.Utils.CharSet.tests + , UnitTests.Distribution.Utils.Structured.tests + , UnitTests.Distribution.Described.tests + , UnitTests.Distribution.CabalSpecVersion.tests + ] extraOptions :: [OptionDescription] extraOptions = @@ -87,34 +102,39 @@ extraOptions = ] newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int - deriving Typeable + deriving (Typeable) instance IsOption OptionMtimeChangeDelay where - defaultValue = OptionMtimeChangeDelay 0 - parseValue = fmap OptionMtimeChangeDelay . safeRead - optionName = return "mtime-change-delay" - optionHelp = return $ "How long to wait before attempting to detect" - ++ "file modification, in microseconds" + defaultValue = OptionMtimeChangeDelay 0 + parseValue = fmap OptionMtimeChangeDelay . safeRead + optionName = return "mtime-change-delay" + optionHelp = + return $ + "How long to wait before attempting to detect" + ++ "file modification, in microseconds" newtype GhcPath = GhcPath FilePath - deriving Typeable + deriving (Typeable) instance IsOption GhcPath where defaultValue = GhcPath "ghc" - optionName = return "with-ghc" - optionHelp = return "The ghc compiler to use" - parseValue = Just . GhcPath + optionName = return "with-ghc" + optionHelp = return "The ghc compiler to use" + parseValue = Just . GhcPath main :: IO () main = do (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay let toMillis :: Int -> Double toMillis x = fromIntegral x / 1000.0 - notice normal $ "File modification time resolution calibration completed, " - ++ "maximum delay observed: " - ++ (show . toMillis $ mtimeChange ) ++ " ms. " - ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') - ++ " for test runs." + notice normal $ + "File modification time resolution calibration completed, " + ++ "maximum delay observed: " + ++ (show . toMillis $ mtimeChange) + ++ " ms. " + ++ "Will be using delay of " + ++ (show . toMillis $ mtimeChange') + ++ " for test runs." defaultMainWithIngredients - (includingOptions extraOptions : defaultIngredients) - (tests mtimeChange') + (includingOptions extraOptions : defaultIngredients) + (tests mtimeChange') diff --git a/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs b/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs index 52fb5c7a689..14514c34cd6 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/CabalSpecVersion.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} + module UnitTests.Distribution.CabalSpecVersion (tests) where import Distribution.Compat.Prelude.Internal @@ -7,8 +8,8 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) -import Distribution.Parsec (eitherParsec) -import Distribution.Pretty (prettyShow) +import Distribution.Parsec (eitherParsec) +import Distribution.Pretty (prettyShow) import Test.Tasty import Test.Tasty.QuickCheck @@ -17,7 +18,9 @@ import Test.Tasty.QuickCheck import Test.QuickCheck.Instances.Cabal () tests :: TestTree -tests = testGroup "Distribution.CabalSpecVersion" +tests = + testGroup + "Distribution.CabalSpecVersion" [ testProperty "roundtrip" propRoundtrip , testProperty "fromVersionDigits . toVersionDigits = Just" propViaVersionDigits ] @@ -26,17 +29,17 @@ tests = testGroup "Distribution.CabalSpecVersion" -- because Described instance is a small simplification. propRoundtrip :: SpecVersion -> Property propRoundtrip x = counterexample (show (res, str)) $ case res of - Right y -> x == y - Left _ -> False + Right y -> x == y + Left _ -> False where str = prettyShow x res = eitherParsec str propViaVersionDigits :: CabalSpecVersion -> Property propViaVersionDigits csv = - counterexample (show digits) $ + counterexample (show digits) $ lhs === rhs where digits = cabalSpecToVersionDigits csv - lhs = cabalSpecFromVersionDigits digits - rhs = Just csv + lhs = cabalSpecFromVersionDigits digits + rhs = Just csv diff --git a/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs b/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs index 68763a81bd5..481a84fe5d9 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs @@ -1,31 +1,32 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module UnitTests.Distribution.Compat.Graph - ( tests - , arbitraryGraph - ) where + ( tests + , arbitraryGraph + ) where import Distribution.Compat.Graph -import qualified Prelude -import Prelude hiding (null) -import Test.Tasty -import Test.Tasty.QuickCheck -import qualified Data.Set as Set import Control.Monad -import qualified Data.Graph as G import Data.Array ((!)) -import Data.Maybe +import qualified Data.Graph as G import Data.List (sort) +import Data.Maybe +import qualified Data.Set as Set +import Test.Tasty +import Test.Tasty.QuickCheck +import Prelude hiding (null) +import qualified Prelude tests :: [TestTree] tests = - [ testProperty "arbitrary unbroken" (prop_arbitrary_unbroken :: Graph (Node Int ()) -> Bool) - , testProperty "nodes consistent" (prop_nodes_consistent :: Graph (Node Int ()) -> Bool) - , testProperty "edges consistent" (prop_edges_consistent :: Graph (Node Int ()) -> Property) - , testProperty "closure consistent" (prop_closure_consistent :: Graph (Node Int ()) -> Property) - ] + [ testProperty "arbitrary unbroken" (prop_arbitrary_unbroken :: Graph (Node Int ()) -> Bool) + , testProperty "nodes consistent" (prop_nodes_consistent :: Graph (Node Int ()) -> Bool) + , testProperty "edges consistent" (prop_edges_consistent :: Graph (Node Int ()) -> Property) + , testProperty "closure consistent" (prop_closure_consistent :: Graph (Node Int ()) -> Property) + ] -- Our arbitrary instance does not generate broken graphs prop_arbitrary_unbroken :: Graph a -> Bool @@ -39,8 +40,8 @@ prop_nodes_consistent g = all p (toList g) where (_, vtn, ktv) = toGraph g p n = case ktv (nodeKey n) of - Just v -> vtn v == n - Nothing -> False + Just v -> vtn v == n + Nothing -> False -- A non-broken graph has the 'nodeNeighbors' of each node -- equal the recorded adjacent edges in the node graph. @@ -48,15 +49,16 @@ prop_edges_consistent :: IsNode a => Graph a -> Property prop_edges_consistent g = Prelude.null (broken g) ==> all p (toList g) where (gr, vtn, ktv) = toGraph g - p n = sort (nodeNeighbors n) - == sort (map (nodeKey . vtn) (gr ! fromJust (ktv (nodeKey n)))) + p n = + sort (nodeNeighbors n) + == sort (map (nodeKey . vtn) (gr ! fromJust (ktv (nodeKey n)))) -- Closure is consistent with reachable prop_closure_consistent :: (Show a, IsNode a) => Graph a -> Property prop_closure_consistent g = - not (null g) ==> + not (null g) ==> forAll (elements (toList g)) $ \n -> - Set.fromList (map nodeKey (fromJust (closure g [nodeKey n]))) + Set.fromList (map nodeKey (fromJust (closure g [nodeKey n]))) == Set.fromList (map (nodeKey . vtn) (G.reachable gr (fromJust (ktv (nodeKey n))))) where (gr, vtn, ktv) = toGraph g @@ -64,28 +66,34 @@ prop_closure_consistent g = hasNoDups :: Ord a => [a] -> Bool hasNoDups = loop Set.empty where - loop _ [] = True - loop s (x:xs) | s' <- Set.insert x s, Set.size s' > Set.size s - = loop s' xs - | otherwise - = False + loop _ [] = True + loop s (x : xs) + | s' <- Set.insert x s + , Set.size s' > Set.size s = + loop s' xs + | otherwise = + False -- | Produces a graph of size @len@. We sample with 'suchThat'; if we -- dropped duplicate entries our size could be smaller. -arbitraryGraph :: (Ord k, Show k, Arbitrary k, Arbitrary a) - => Int -> Gen (Graph (Node k a)) +arbitraryGraph + :: (Ord k, Show k, Arbitrary k, Arbitrary a) + => Int + -> Gen (Graph (Node k a)) arbitraryGraph len = do - -- Careful! Assume k is much larger than size. - ks <- vectorOf len arbitrary `suchThat` hasNoDups - ns <- forM ks $ \k -> do - a <- arbitrary - ns <- listOf (elements ks) - -- Allow duplicates! - return (N a k ns) - return (fromDistinctList ns) + -- Careful! Assume k is much larger than size. + ks <- vectorOf len arbitrary `suchThat` hasNoDups + ns <- forM ks $ \k -> do + a <- arbitrary + ns <- listOf (elements ks) + -- Allow duplicates! + return (N a k ns) + return (fromDistinctList ns) -instance (Ord k, Show k, Arbitrary k, Arbitrary a) - => Arbitrary (Graph (Node k a)) where - arbitrary = sized $ \n -> do - len <- choose (0, n) - arbitraryGraph len +instance + (Ord k, Show k, Arbitrary k, Arbitrary a) + => Arbitrary (Graph (Node k a)) + where + arbitrary = sized $ \n -> do + len <- choose (0, n) + arbitraryGraph len diff --git a/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs b/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs index db656db0be0..d51bd979601 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs @@ -14,7 +14,7 @@ import Test.Tasty.HUnit tests :: Int -> [TestTree] tests mtimeChange = [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange - , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange + , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange ] getModTimeTest :: Int -> Assertion @@ -28,7 +28,6 @@ getModTimeTest mtimeChange = t1 <- getModTime fileName assertBool "expected different file mtimes" (t1 > t0) - getCurTimeTest :: Int -> Assertion getCurTimeTest mtimeChange = withTempDirectory silent "." "getmodtime-" $ \dir -> do @@ -37,13 +36,23 @@ getCurTimeTest mtimeChange = t0 <- getModTime fileName threadDelay mtimeChange t1 <- getCurTime - assertBool("expected file mtime (" ++ show t0 - ++ ") to be earlier than current time (" ++ show t1 ++ ")") + assertBool + ( "expected file mtime (" + ++ show t0 + ++ ") to be earlier than current time (" + ++ show t1 + ++ ")" + ) (t0 < t1) threadDelay mtimeChange writeFile fileName "baz" t2 <- getModTime fileName - assertBool ("expected current time (" ++ show t1 - ++ ") to be earlier than file mtime (" ++ show t2 ++ ")") + assertBool + ( "expected current time (" + ++ show t1 + ++ ") to be earlier than file mtime (" + ++ show t2 + ++ ")" + ) (t1 < t2) diff --git a/Cabal-tests/tests/UnitTests/Distribution/Described.hs b/Cabal-tests/tests/UnitTests/Distribution/Described.hs index 2c73c805c71..c00ebf82e1d 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Described.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Described.hs @@ -1,34 +1,37 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} + module UnitTests.Distribution.Described where import Distribution.Compat.Prelude.Internal import Prelude () import Distribution.Described (testDescribed) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, testGroup) -import Distribution.Compiler (CompilerFlavor, CompilerId) -import Distribution.ModuleName (ModuleName) -import Distribution.System (Arch, OS) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.Flag (FlagAssignment, FlagName) -import Distribution.Types.IncludeRenaming (IncludeRenaming) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.ModuleRenaming (ModuleRenaming) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) +import Distribution.Compiler (CompilerFlavor, CompilerId) +import Distribution.ModuleName (ModuleName) +import Distribution.System (Arch, OS) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Flag (FlagAssignment, FlagName) +import Distribution.Types.IncludeRenaming (IncludeRenaming) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.ModuleRenaming (ModuleRenaming) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) -import Distribution.Types.Version (Version) -import Distribution.Types.VersionRange (VersionRange) -import Distribution.Verbosity (Verbosity) +import Distribution.Types.Version (Version) +import Distribution.Types.VersionRange (VersionRange) +import Distribution.Verbosity (Verbosity) -- instances import Test.QuickCheck.Instances.Cabal () tests :: TestTree -tests = testGroup "Described" +tests = + testGroup + "Described" [ testDescribed (Proxy :: Proxy Dependency) , testDescribed (Proxy :: Proxy PackageName) , testDescribed (Proxy :: Proxy PackageIdentifier) diff --git a/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs b/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs index bccc25f7a72..40d63c8732e 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} + module UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) where import Test.Tasty import Test.Tasty.QuickCheck -import Distribution.Parsec (eitherParsec) +import Distribution.Parsec (eitherParsec) import Distribution.Pretty import Distribution.Types.PkgconfigVersionRange @@ -13,9 +14,10 @@ import Test.QuickCheck.Instances.Cabal () pkgconfigVersionTests :: [TestTree] pkgconfigVersionTests = - [ testProperty "simpleParsec . prettyShow = Just" prop_parse_disp - ] + [ testProperty "simpleParsec . prettyShow = Just" prop_parse_disp + ] prop_parse_disp :: PkgconfigVersionRange -> Property -prop_parse_disp vr = counterexample (show (prettyShow vr)) $ +prop_parse_disp vr = + counterexample (show (prettyShow vr)) $ eitherParsec (prettyShow vr) === Right vr diff --git a/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs b/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs index 2f598553eba..ee8bac58779 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs @@ -1,13 +1,14 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} + module UnitTests.Distribution.SPDX (spdxTests) where import Distribution.Compat.Prelude.Internal import Prelude () -import Distribution.SPDX import Distribution.Parsec (eitherParsec) import Distribution.Pretty (prettyShow) +import Distribution.SPDX import Test.Tasty import Test.Tasty.QuickCheck @@ -24,23 +25,23 @@ import Test.QuickCheck.Instances.Cabal () spdxTests :: [TestTree] spdxTests = - [ testProperty "LicenseId roundtrip" licenseIdRoundtrip - , testProperty "LicenseExceptionId roundtrip" licenseExceptionIdRoundtrip - , testProperty "LicenseRef roundtrip" licenseRefRoundtrip - , testProperty "SimpleLicenseExpression roundtrip" simpleLicenseExpressionRoundtrip - , testProperty "LicenseExpression roundtrip" licenseExpressionRoundtrip - , testProperty "isAcceptableLicense l = True" shouldAcceptProp - , testProperty "isAcceptableLicense l = False" shouldRejectProp - ] + [ testProperty "LicenseId roundtrip" licenseIdRoundtrip + , testProperty "LicenseExceptionId roundtrip" licenseExceptionIdRoundtrip + , testProperty "LicenseRef roundtrip" licenseRefRoundtrip + , testProperty "SimpleLicenseExpression roundtrip" simpleLicenseExpressionRoundtrip + , testProperty "LicenseExpression roundtrip" licenseExpressionRoundtrip + , testProperty "isAcceptableLicense l = True" shouldAcceptProp + , testProperty "isAcceptableLicense l = False" shouldRejectProp + ] licenseIdRoundtrip :: LicenseId -> Property licenseIdRoundtrip x = - counterexample (prettyShow x) $ + counterexample (prettyShow x) $ Right x === eitherParsec (prettyShow x) licenseExceptionIdRoundtrip :: LicenseExceptionId -> Property licenseExceptionIdRoundtrip x = - counterexample (prettyShow x) $ + counterexample (prettyShow x) $ Right x === eitherParsec (prettyShow x) #if MIN_VERSION_binary(0,7,0) @@ -68,27 +69,27 @@ licenseExceptionIdBinaryGet w0 = licenseRefRoundtrip :: LicenseRef -> Property licenseRefRoundtrip x = - counterexample (prettyShow x) $ + counterexample (prettyShow x) $ Right x === eitherParsec (prettyShow x) simpleLicenseExpressionRoundtrip :: SimpleLicenseExpression -> Property simpleLicenseExpressionRoundtrip x = - counterexample (prettyShow x) $ + counterexample (prettyShow x) $ Right x === eitherParsec (prettyShow x) licenseExpressionRoundtrip :: LicenseExpression -> Property licenseExpressionRoundtrip x = - counterexample (prettyShow x) $ + counterexample (prettyShow x) $ Right (reassoc x) === eitherParsec (prettyShow x) -- Parser produces right biased trees of and/or expressions reassoc :: LicenseExpression -> LicenseExpression reassoc (EOr a b) = case reassoc a of - EOr x y -> EOr x (reassoc (EOr y b)) - x -> EOr x (reassoc b) + EOr x y -> EOr x (reassoc (EOr y b)) + x -> EOr x (reassoc b) reassoc (EAnd a b) = case reassoc a of - EAnd x y -> EAnd x (reassoc (EAnd y b)) - x -> EAnd x (reassoc b) + EAnd x y -> EAnd x (reassoc (EAnd y b)) + x -> EAnd x (reassoc b) reassoc l = l ------------------------------------------------------------------------------- @@ -96,7 +97,9 @@ reassoc l = l ------------------------------------------------------------------------------- shouldAccept :: [License] -shouldAccept = map License +shouldAccept = + map + License [ simpleLicenseExpression GPL_2_0_only , simpleLicenseExpression GPL_2_0_or_later , simpleLicenseExpression BSD_2_Clause @@ -110,7 +113,9 @@ shouldAccept = map License ] shouldReject :: [License] -shouldReject = map License +shouldReject = + map + License [ simpleLicenseExpression BSD_4_Clause , simpleLicenseExpression BSD_4_Clause `EAnd` simpleLicenseExpression MIT ] @@ -125,25 +130,26 @@ shouldReject = map License -- -- * There should be a way to interpert license as (conjunction of) -- OSI-accepted licenses or CC0 --- isAcceptableLicense :: License -> Bool -isAcceptableLicense NONE = False +isAcceptableLicense NONE = False isAcceptableLicense (License expr) = goExpr expr where - goExpr (EAnd a b) = goExpr a && goExpr b - goExpr (EOr a b) = goExpr a || goExpr b + goExpr (EAnd a b) = goExpr a && goExpr b + goExpr (EOr a b) = goExpr a || goExpr b goExpr (ELicense _ (Just _)) = False -- Don't allow exceptions - goExpr (ELicense s Nothing) = goSimple s + goExpr (ELicense s Nothing) = goSimple s - goSimple (ELicenseRef _) = False -- don't allow referenced licenses - goSimple (ELicenseIdPlus _) = False -- don't allow + licenses (use GPL-3.0-or-later e.g.) + goSimple (ELicenseRef _) = False -- don't allow referenced licenses + goSimple (ELicenseIdPlus _) = False -- don't allow + licenses (use GPL-3.0-or-later e.g.) goSimple (ELicenseId CC0_1_0) = True -- CC0 isn't OSI approved, but we allow it as "PublicDomain", this is eg. PublicDomain in http://hackage.haskell.org/package/string-qq-0.0.2/src/LICENSE - goSimple (ELicenseId lid) = licenseIsOsiApproved lid -- allow only OSI approved licenses. + goSimple (ELicenseId lid) = licenseIsOsiApproved lid -- allow only OSI approved licenses. shouldAcceptProp :: Property -shouldAcceptProp = conjoin $ +shouldAcceptProp = + conjoin $ map (\l -> counterexample (prettyShow l) (isAcceptableLicense l)) shouldAccept shouldRejectProp :: Property -shouldRejectProp = conjoin $ +shouldRejectProp = + conjoin $ map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs index fd60a79209e..1b768af1272 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs @@ -1,6 +1,6 @@ module UnitTests.Distribution.Simple.Command - ( tests - ) where + ( tests + ) where import Distribution.Simple.Command import qualified Distribution.Simple.Flag as Flag @@ -21,21 +21,22 @@ argumentTests = where -- evaluate command parse result, to force possible exceptions in 'f' evalParse p = case p of - CommandErrors _ -> Left "errors" - CommandHelp _ -> Left "help" - CommandList _ -> Left "list" + CommandErrors _ -> Left "errors" + CommandHelp _ -> Left "help" + CommandList _ -> Left "list" CommandReadyToGo (f, _) -> Right $ f Flag.NoFlag verbose = Flag.Flag Verbosity.verbose isGlobal = True - cmdUI = CommandUI - { commandName = "cmd" - , commandSynopsis = "the command" - , commandUsage = \name -> name ++ " cmd -v[N]" - , commandDescription = Nothing - , commandNotes = Nothing - , commandDefaultFlags = Flag.NoFlag - , commandOptions = const [ optField ] - } + cmdUI = + CommandUI + { commandName = "cmd" + , commandSynopsis = "the command" + , commandUsage = \name -> name ++ " cmd -v[N]" + , commandDescription = Nothing + , commandNotes = Nothing + , commandDefaultFlags = Flag.NoFlag + , commandOptions = const [optField] + } optField = optionVerbosity id const tests :: [TestTree] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index 22e3af46843..14482242282 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -1,17 +1,17 @@ module UnitTests.Distribution.Simple.Glob - ( tests - ) where + ( tests + ) where import Control.Monad import Data.Foldable (for_) import Data.Function (on) import Data.List (sort) import Data.Maybe (mapMaybe) +import Distribution.CabalSpecVersion import Distribution.Simple.Glob import qualified Distribution.Verbosity as Verbosity -import Distribution.CabalSpecVersion import System.Directory (createDirectoryIfMissing) -import System.FilePath ((), splitFileName, normalise) +import System.FilePath (normalise, splitFileName, ()) import System.IO.Temp (withSystemTempDirectory) import Test.Tasty import Test.Tasty.HUnit @@ -103,19 +103,23 @@ testMatchesVersion version pat expected = do checkPure globPat = do let actual = mapMaybe (fileGlobMatches globPat) sampleFileNames unless (sort expected == sort actual) $ - assertFailure $ "Unexpected result (pure matcher): " ++ show actual + assertFailure $ + "Unexpected result (pure matcher): " ++ show actual checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do makeSampleFiles tmpdir actual <- runDirFileGlob Verbosity.normal tmpdir globPat unless (isEqual actual expected) $ - assertFailure $ "Unexpected result (impure matcher): " ++ show actual + assertFailure $ + "Unexpected result (impure matcher): " ++ show actual testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion testFailParseVersion version pat expected = case parseFileGlob version pat of - Left err -> unless (expected == err) $ - assertFailure $ "Unexpected error: " ++ show err + Left err -> + unless (expected == err) $ + assertFailure $ + "Unexpected error: " ++ show err Right _ -> assertFailure "Unexpected success in parsing." globstarTests :: [TestTree] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs index 985c91f8eae..2ca1f2d43c0 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs @@ -1,38 +1,42 @@ module UnitTests.Distribution.Simple.Program.GHC (tests) where import Data.Algorithm.Diff (PolyDiff (..), getDiff) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit import Distribution.PackageDescription (emptyPackageDescription) import Distribution.Simple.Program.GHC (normaliseGhcArgs) -import Distribution.Version (mkVersion) +import Distribution.Version (mkVersion) tests :: TestTree -tests = testGroup "Distribution.Simple.Program.GHC" - [ testGroup "normaliseGhcArgs" +tests = + testGroup + "Distribution.Simple.Program.GHC" + [ testGroup + "normaliseGhcArgs" [ testCase "options added in GHC-8.8" $ do let flags :: [String] - flags = normaliseGhcArgs - (Just $ mkVersion [8,8,1]) + flags = + normaliseGhcArgs + (Just $ mkVersion [8, 8, 1]) emptyPackageDescription options_8_8_all assertListEquals flags options_8_8_affects - , testCase "options added in GHC-8.10" $ do let flags :: [String] - flags = normaliseGhcArgs - (Just $ mkVersion [8,10,1]) + flags = + normaliseGhcArgs + (Just $ mkVersion [8, 10, 1]) emptyPackageDescription options_8_10_all assertListEquals flags options_8_10_affects - , testCase "options added in GHC-9.0" $ do let flags :: [String] - flags = normaliseGhcArgs - (Just $ mkVersion [9,0,1]) + flags = + normaliseGhcArgs + (Just $ mkVersion [9, 0, 1]) emptyPackageDescription options_9_0_all @@ -42,15 +46,17 @@ tests = testGroup "Distribution.Simple.Program.GHC" assertListEquals :: (Eq a, Show a) => [a] -> [a] -> Assertion assertListEquals xs ys - | xs == ys = return () - | otherwise = assertFailure $ unlines $ - "Lists are not equal" : - [ case d of - First x -> "- " ++ show x - Second y -> "+ " ++ show y - Both x _ -> " " ++ show x - | d <- getDiff xs ys - ] + | xs == ys = return () + | otherwise = + assertFailure $ + unlines $ + "Lists are not equal" + : [ case d of + First x -> "- " ++ show x + Second y -> "+ " ++ show y + Both x _ -> " " ++ show x + | d <- getDiff xs ys + ] ------------------------------------------------------------------------------- -- GHC 8.8 @@ -68,47 +74,48 @@ assertListEquals xs ys -- - split into all and flags which may affect artifacts options_8_8_all :: [String] options_8_8_all = - [ "-ddump-cfg-weights" - , "-dno-suppress-stg-exts" - , "-dsuppress-stg-exts" - , "-Wmissed-extra-shared-lib" - , "-Wmissing-deriving-strategies" - , "-Wmissing-space-after-bang" - , "-Wno-missed-extra-shared-lib" - , "-Wno-missing-deriving-strategies" - , "-Wno-missing-space-after-bang" - , "-fno-show-docs-of-hole-fits" - , "-fshow-docs-of-hole-fits" - ] ++ options_8_8_affects + [ "-ddump-cfg-weights" + , "-dno-suppress-stg-exts" + , "-dsuppress-stg-exts" + , "-Wmissed-extra-shared-lib" + , "-Wmissing-deriving-strategies" + , "-Wmissing-space-after-bang" + , "-Wno-missed-extra-shared-lib" + , "-Wno-missing-deriving-strategies" + , "-Wno-missing-space-after-bang" + , "-fno-show-docs-of-hole-fits" + , "-fshow-docs-of-hole-fits" + ] + ++ options_8_8_affects options_8_8_affects :: [String] options_8_8_affects = - [ "-fblock-layout-cfg" - , "-fblock-layout-weightless" - , "-fblock-layout-weights" - , "-fclear-plugins" - , "-fkeep-cafs" - , "-fno-block-layout-cfg" - , "-fno-block-layout-weightless" - , "-fno-keep-cafs" - , "-fno-safe-haskell" - , "-fno-stg-lift-lams" - , "-fno-stg-lift-lams-known" - , "-fno-validate-ide-info" - , "-fno-write-ide-info" - , "-fstg-lift-lams" - , "-fstg-lift-lams-known" - , "-fstg-lift-lams-non-rec-args" - , "-fstg-lift-lams-non-rec-args-any" - , "-fstg-lift-lams-rec-args" - , "-fstg-lift-lams-rec-args-any" - , "-fvalidate-ide-info" - , "-fwrite-ide-info" - , "-hiedir" - , "-hiesuf" - , "-keep-hscpp-file" - , "-keep-hscpp-files" - ] + [ "-fblock-layout-cfg" + , "-fblock-layout-weightless" + , "-fblock-layout-weights" + , "-fclear-plugins" + , "-fkeep-cafs" + , "-fno-block-layout-cfg" + , "-fno-block-layout-weightless" + , "-fno-keep-cafs" + , "-fno-safe-haskell" + , "-fno-stg-lift-lams" + , "-fno-stg-lift-lams-known" + , "-fno-validate-ide-info" + , "-fno-write-ide-info" + , "-fstg-lift-lams" + , "-fstg-lift-lams-known" + , "-fstg-lift-lams-non-rec-args" + , "-fstg-lift-lams-non-rec-args-any" + , "-fstg-lift-lams-rec-args" + , "-fstg-lift-lams-rec-args-any" + , "-fvalidate-ide-info" + , "-fwrite-ide-info" + , "-hiedir" + , "-hiesuf" + , "-keep-hscpp-file" + , "-keep-hscpp-files" + ] ------------------------------------------------------------------------------- -- GHC 8.10 @@ -116,40 +123,41 @@ options_8_8_affects = options_8_10_all :: [String] options_8_10_all = - [ "-ddump-cmm-verbose-by-proc" - , "-ddump-stg-final" - , "-ddump-stg-unarised" - , "-Wderiving-defaults" - , "-Winferred-safe-imports" - , "-Wmissing-safe-haskell-mode" - , "-Wno-deriving-defaults" - , "-Wno-inferred-safe-imports" - , "-Wno-missing-safe-haskell-mode" - , "-Wno-prepositive-qualified-module" - , "-Wno-redundant-record-wildcards" - , "-Wno-unused-packages" - , "-Wno-unused-record-wildcards" - , "-Wprepositive-qualified-module" - , "-Wredundant-record-wildcards" - , "-Wunused-packages" - , "-Wunused-record-wildcards" - , "-fdefer-diagnostics" - , "-fkeep-going" - , "-fprint-axiom-incomps" - , "-fno-defer-diagnostics" - , "-fno-keep-going" - , "-fno-print-axiom-incomps" - ] ++ options_8_10_affects + [ "-ddump-cmm-verbose-by-proc" + , "-ddump-stg-final" + , "-ddump-stg-unarised" + , "-Wderiving-defaults" + , "-Winferred-safe-imports" + , "-Wmissing-safe-haskell-mode" + , "-Wno-deriving-defaults" + , "-Wno-inferred-safe-imports" + , "-Wno-missing-safe-haskell-mode" + , "-Wno-prepositive-qualified-module" + , "-Wno-redundant-record-wildcards" + , "-Wno-unused-packages" + , "-Wno-unused-record-wildcards" + , "-Wprepositive-qualified-module" + , "-Wredundant-record-wildcards" + , "-Wunused-packages" + , "-Wunused-record-wildcards" + , "-fdefer-diagnostics" + , "-fkeep-going" + , "-fprint-axiom-incomps" + , "-fno-defer-diagnostics" + , "-fno-keep-going" + , "-fno-print-axiom-incomps" + ] + ++ options_8_10_affects options_8_10_affects :: [String] options_8_10_affects = - [ "-dno-typeable-binds" - , "-fbinary-blob-threshold" - , "-fmax-pmcheck-models" - , "-fplugin-trustworthy" - , "-include-cpp-deps" - , "-optcxx" - ] + [ "-dno-typeable-binds" + , "-fbinary-blob-threshold" + , "-fmax-pmcheck-models" + , "-fplugin-trustworthy" + , "-include-cpp-deps" + , "-optcxx" + ] ------------------------------------------------------------------------------- -- GHC-9.0 @@ -157,19 +165,20 @@ options_8_10_affects = options_9_0_all :: [String] options_9_0_all = - [ "-ddump-cmm-opt" - , "-ddump-cpranal" - , "-ddump-cpr-signatures" - , "-ddump-hie" - -- NOTE: we filter out -dlinear-core-lint + [ "-ddump-cmm-opt" + , "-ddump-cpranal" + , "-ddump-cpr-signatures" + , "-ddump-hie" + , -- NOTE: we filter out -dlinear-core-lint -- we filter, -dcore-lint, -dstg-lint etc. - , "-dlinear-core-lint" - ] ++ options_9_0_affects + "-dlinear-core-lint" + ] + ++ options_9_0_affects options_9_0_affects :: [String] options_9_0_affects = - [ "-fcmm-static-pred" - ] + [ "-fcmm-static-pred" + ] ------------------------------------------------------------------------------- -- GHC-9.2 @@ -177,27 +186,28 @@ options_9_0_affects = options_9_2_all :: [String] options_9_2_all = - [ "-dynohi" - , "-ddump-c-backend" - , "-ddump-stg-from-core" - , "-ddump-stg" - , "-ddump-faststrings" - , "--run" - , "-ffamily-application-cache" - , "-fno-family-application-cache" - ] ++ options_9_2_affects + [ "-dynohi" + , "-ddump-c-backend" + , "-ddump-stg-from-core" + , "-ddump-stg" + , "-ddump-faststrings" + , "--run" + , "-ffamily-application-cache" + , "-fno-family-application-cache" + ] + ++ options_9_2_affects options_9_2_affects :: [String] options_9_2_affects = - [ "-fprof-callers" - , "-funfolding-case-threshold" - , "-funfolding-case-scaling" - , "-fdistinct-constructor-tables" - , "-finfo-table-map" - , "-fexpose-internal-symbols" - , "-finline-generics" - , "-finline-generics-aggressively" - , "-fno-expose-internal-symbols" - , "-fno-inline-generics" - , "-fno-inline-generics-aggressively" - ] + [ "-fprof-callers" + , "-funfolding-case-threshold" + , "-funfolding-case-scaling" + , "-fdistinct-constructor-tables" + , "-finfo-table-map" + , "-fexpose-internal-symbols" + , "-finline-generics" + , "-finline-generics-aggressively" + , "-fno-expose-internal-symbols" + , "-fno-inline-generics" + , "-fno-inline-generics-aggressively" + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs index 4766cbb36c5..e476c22162c 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/Internal.hs @@ -1,14 +1,15 @@ module UnitTests.Distribution.Simple.Program.Internal - ( tests - ) where + ( tests + ) where -import Distribution.Simple.Program.Internal ( stripExtractVersion ) +import Distribution.Simple.Program.Internal (stripExtractVersion) import Test.Tasty import Test.Tasty.HUnit v :: String -v = "GNU strip (GNU Binutils; openSUSE 13.2) 2.24.0.20140403-6.1\nCopyright 2013\ +v = + "GNU strip (GNU Binutils; openSUSE 13.2) 2.24.0.20140403-6.1\nCopyright 2013\ \ Free Software Foundation, Inc.\nThis program is free software; you may\ \ redistribute it under the terms of\nthe GNU General Public License version 3\ \ or (at your option) any later version.\nThis program has absolutely no\ @@ -25,12 +26,12 @@ v''' = "GNU strip (GNU (Binutils for) Ubuntu 12.04 ) 2.22" tests :: [TestTree] tests = - [ testCase "Handles parentheses" $ - (stripExtractVersion v) @=? "2.24" - , testCase "Handles dashes and alphabetic characters" $ - (stripExtractVersion v') @=? "2.17" - , testCase "Handles single-word parenthetical expressions" $ - (stripExtractVersion v'') @=? "2.23" - , testCase "Handles nested parentheses" $ + [ testCase "Handles parentheses" $ + (stripExtractVersion v) @=? "2.24" + , testCase "Handles dashes and alphabetic characters" $ + (stripExtractVersion v') @=? "2.17" + , testCase "Handles single-word parenthetical expressions" $ + (stripExtractVersion v'') @=? "2.23" + , testCase "Handles nested parentheses" $ (stripExtractVersion v''') @=? "2.22" - ] + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs index 2e544c8c52d..76d08b55f6b 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs @@ -1,21 +1,26 @@ {-# LANGUAGE GADTs #-} + module UnitTests.Distribution.Simple.Utils - ( tests - ) where + ( tests + ) where -import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.Utils -import Distribution.System ( buildPlatform ) +import Distribution.System (buildPlatform) import Distribution.Verbosity +import qualified Control.Exception as Exception import Data.IORef -import System.Directory ( doesDirectoryExist, doesFileExist - , getTemporaryDirectory - , removeDirectoryRecursive, removeFile ) -import System.FilePath ( (<.>) ) -import System.IO (hClose, localeEncoding, hPutStrLn) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , getTemporaryDirectory + , removeDirectoryRecursive + , removeFile + ) +import System.FilePath ((<.>)) +import System.IO (hClose, hPutStrLn, localeEncoding) import System.IO.Error -import qualified Control.Exception as Exception import Test.Tasty import Test.Tasty.HUnit @@ -23,7 +28,7 @@ import Test.Tasty.HUnit withTempFileTest :: Assertion withTempFileTest = do fileName <- newIORef "" - tempDir <- getTemporaryDirectory + tempDir <- getTemporaryDirectory withTempFile tempDir ".foo" $ \fileName' _handle -> do writeIORef fileName fileName' fileExists <- readIORef fileName >>= doesFileExist @@ -43,7 +48,8 @@ withTempDirTest = do withTempDirectory normal tempDir "foo" $ \dirName' -> do writeIORef dirName dirName' dirExists <- readIORef dirName >>= doesDirectoryExist - assertBool "Temporary directory not deleted by 'withTempDirectory'!" + assertBool + "Temporary directory not deleted by 'withTempDirectory'!" (not dirExists) withTempDirRemovedTest :: Assertion @@ -54,57 +60,66 @@ withTempDirRemovedTest = do rawSystemStdInOutTextDecodingTest :: FilePath -> Assertion rawSystemStdInOutTextDecodingTest ghcPath - -- We can only get this exception when the locale encoding is UTF-8 - -- so skip the test if it's not. - | show localeEncoding /= "UTF-8" = return () - | otherwise = do - tempDir <- getTemporaryDirectory - res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do - withTempFile tempDir ".exe" $ \filenameExe handleExe -> do - -- Small program printing not utf8 - hPutStrLn handleHs "import Data.ByteString" - hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])" - hClose handleHs + -- We can only get this exception when the locale encoding is UTF-8 + -- so skip the test if it's not. + | show localeEncoding /= "UTF-8" = return () + | otherwise = do + tempDir <- getTemporaryDirectory + res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do + withTempFile tempDir ".exe" $ \filenameExe handleExe -> do + -- Small program printing not utf8 + hPutStrLn handleHs "import Data.ByteString" + hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])" + hClose handleHs - -- We need to close exe handle as well, otherwise compilation (writing) may fail - hClose handleExe + -- We need to close exe handle as well, otherwise compilation (writing) may fail + hClose handleExe - -- Compile - (resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal - ghcPath ["-o", filenameExe, filenameHs] - Nothing Nothing Nothing - IODataModeText - print (resOutput, resErrors, resExitCode) + -- Compile + (resOutput, resErrors, resExitCode) <- + rawSystemStdInOut + normal + ghcPath + ["-o", filenameExe, filenameHs] + Nothing + Nothing + Nothing + IODataModeText + print (resOutput, resErrors, resExitCode) - -- Execute - Exception.try $ do - rawSystemStdInOut normal - filenameExe [] - Nothing Nothing Nothing - IODataModeText -- not binary mode output, ie utf8 text mode so try to decode - case res of - Right (x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3) - Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc! - | otherwise -> return () + -- Execute + Exception.try $ do + rawSystemStdInOut + normal + filenameExe + [] + Nothing + Nothing + Nothing + IODataModeText -- not binary mode output, ie utf8 text mode so try to decode + case res of + Right (x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1, x2, x3) + Left err + | isDoesNotExistError err -> Exception.throwIO err -- no ghc! + | otherwise -> return () dropExeExtensionTest :: Assertion dropExeExtensionTest = assertBool "dropExeExtension didn't drop exeExtension!" $ dropExeExtension ("foo" <.> exeExtension buildPlatform) == "foo" - tests :: FilePath -> [TestTree] tests ghcPath = - [ testCase "withTempFile works as expected" $ + [ testCase "withTempFile works as expected" $ withTempFileTest - , testCase "withTempFile can handle removed files" $ + , testCase "withTempFile can handle removed files" $ withTempFileRemovedTest - , testCase "withTempDirectory works as expected" $ + , testCase "withTempDirectory works as expected" $ withTempDirTest - , testCase "withTempDirectory can handle removed directories" $ + , testCase "withTempDirectory can handle removed directories" $ withTempDirRemovedTest - , testCase "rawSystemStdInOut reports text decoding errors" $ + , testCase "rawSystemStdInOut reports text decoding errors" $ rawSystemStdInOutTextDecodingTest ghcPath - , testCase "dropExeExtension drops exe extension" $ + , testCase "dropExeExtension drops exe extension" $ dropExeExtensionTest - ] + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/System.hs b/Cabal-tests/tests/UnitTests/Distribution/System.hs index d09b1b7f61b..b69016b3100 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/System.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/System.hs @@ -1,22 +1,23 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} + module UnitTests.Distribution.System - ( tests - ) where + ( tests + ) where import Distribution.Parsec import Distribution.Pretty import Distribution.System -import Test.Tasty -import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck (Property, (===)) import Test.QuickCheck.Instances.Cabal () +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) textRoundtrip :: (Show a, Eq a, Pretty a, Parsec a) => a -> Property textRoundtrip x = simpleParsec (prettyShow x) === Just x tests :: [TestTree] tests = - [ testProperty "Text OS round trip" (textRoundtrip :: OS -> Property) - , testProperty "Text Arch round trip" (textRoundtrip :: Arch -> Property) - , testProperty "Text Platform round trip" (textRoundtrip :: Platform -> Property) - ] + [ testProperty "Text OS round trip" (textRoundtrip :: OS -> Property) + , testProperty "Text Arch round trip" (textRoundtrip :: Arch -> Property) + , testProperty "Text Platform round trip" (textRoundtrip :: Platform -> Property) + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs b/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs index 65bd55cb7d3..bef34fba7ef 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Types/GenericPackageDescription.hs @@ -1,14 +1,15 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- for importing "Distribution.Compat.Prelude.Internal" +-- for importing "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} module UnitTests.Distribution.Types.GenericPackageDescription where -import Prelude () import Distribution.Compat.Prelude.Internal import Distribution.Types.GenericPackageDescription +import Prelude () +import qualified Control.Exception as C import Test.Tasty import Test.Tasty.HUnit -import qualified Control.Exception as C tests :: [TestTree] tests = @@ -17,21 +18,23 @@ tests = gpdFields :: [(String, GenericPackageDescription -> GenericPackageDescription)] gpdFields = - [ ("packageDescription", \gpd -> gpd { packageDescription = undefined }) - , ("genPackageFlags", \gpd -> gpd { genPackageFlags = undefined }) - , ("condLibrary", \gpd -> gpd { condLibrary = undefined }) - , ("condSubLibraries", \gpd -> gpd { condSubLibraries = undefined }) - , ("condForeignLibs", \gpd -> gpd { condForeignLibs = undefined }) - , ("condExecutables", \gpd -> gpd { condExecutables = undefined }) - , ("condTestSuites", \gpd -> gpd { condTestSuites = undefined }) - , ("condBenchmarks", \gpd -> gpd { condBenchmarks = undefined }) + [ ("packageDescription", \gpd -> gpd{packageDescription = undefined}) + , ("genPackageFlags", \gpd -> gpd{genPackageFlags = undefined}) + , ("condLibrary", \gpd -> gpd{condLibrary = undefined}) + , ("condSubLibraries", \gpd -> gpd{condSubLibraries = undefined}) + , ("condForeignLibs", \gpd -> gpd{condForeignLibs = undefined}) + , ("condExecutables", \gpd -> gpd{condExecutables = undefined}) + , ("condTestSuites", \gpd -> gpd{condTestSuites = undefined}) + , ("condBenchmarks", \gpd -> gpd{condBenchmarks = undefined}) ] gpdDeepseq :: Assertion -gpdDeepseq = sequence_ - [ throwsUndefined msg (f emptyGenericPackageDescription) | (msg, f) <- gpdFields ] +gpdDeepseq = + sequence_ + [throwsUndefined msg (f emptyGenericPackageDescription) | (msg, f) <- gpdFields] throwsUndefined :: NFData a => String -> a -> Assertion throwsUndefined field a = - C.catch (C.evaluate (rnf a) >> assertFailure ("Deepseq failed to evaluate " ++ show field)) - (\(C.ErrorCall _) -> return ()) + C.catch + (C.evaluate (rnf a) >> assertFailure ("Deepseq failed to evaluate " ++ show field)) + (\(C.ErrorCall _) -> return ()) diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs index c2180b630b7..5b041f42e95 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs @@ -1,28 +1,35 @@ {-# LANGUAGE CPP #-} + -- isAlpha and isAlphaNum definitions change from base to base #if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0) #define HAS_TESTS #endif module UnitTests.Distribution.Utils.CharSet where -import Prelude hiding (Foldable(..)) -import Data.Char (isAlpha, isAlphaNum) -import Data.Foldable (foldl') -import Test.Tasty (TestTree, testGroup) +import Data.Char (isAlpha, isAlphaNum) +import Data.Foldable (foldl') +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) +import Prelude hiding (Foldable (..)) import qualified Distribution.Utils.CharSet as CS tests :: TestTree -tests = testGroup "Distribution.Utils.CharSet" +tests = + testGroup + "Distribution.Utils.CharSet" [ testCase "alphanum" $ - CS.alphanum @?= foldl' (flip CS.insert) CS.empty - [ c | c <- [ minBound .. maxBound ], isAlphaNum c ] - + CS.alphanum + @?= foldl' + (flip CS.insert) + CS.empty + [c | c <- [minBound .. maxBound], isAlphaNum c] , testCase "alpha" $ - CS.alpha @?= foldl' (flip CS.insert) CS.empty - [ c | c <- [ minBound .. maxBound ], isAlpha c ] - + CS.alpha + @?= foldl' + (flip CS.insert) + CS.empty + [c | c <- [minBound .. maxBound], isAlpha c] , testCase "alpha is subset of alphanum" $ CS.union CS.alpha CS.alphanum @?= CS.alphanum ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs index 3eecc3c2a13..4ee9b9d152c 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Generic.hs @@ -1,12 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} - -- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} -module UnitTests.Distribution.Utils.Generic ( tests ) where +module UnitTests.Distribution.Utils.Generic (tests) where -import Prelude () import Distribution.Compat.Prelude.Internal +import Prelude () import Distribution.Utils.Generic @@ -20,19 +19,17 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = - [ -- fromUTF8BS / toUTF8BS - testCase "fromUTF8BS mempty" testFromUTF8BSEmpty - , testCase "toUTF8BS mempty" testToUTF8BSEmpty - , testCase "toUTF8BS [U+D800..U+DFFF]" testToUTF8BSSurr - , testCase "toUTF8BS [U+0000..U+7F]" testToUTF8BSAscii - , testCase "toUTF8BS [U+0000..U+10FFFF]" testToUTF8BSText - , testCase "fromUTF8BS.toUTF8BS [U+0000..U+10FFFF]" testToFromUTF8BS - - , testProperty "fromUTF8BS.toUTF8BS == id" prop_toFromUTF8BS - , testProperty "toUTF8BS == encodeUtf8" prop_toUTF8BS - - , testProperty "Nothing = validateUtf8 (encodeUtf8 x)" prop_validateUtf8 - ] + [ -- fromUTF8BS / toUTF8BS + testCase "fromUTF8BS mempty" testFromUTF8BSEmpty + , testCase "toUTF8BS mempty" testToUTF8BSEmpty + , testCase "toUTF8BS [U+D800..U+DFFF]" testToUTF8BSSurr + , testCase "toUTF8BS [U+0000..U+7F]" testToUTF8BSAscii + , testCase "toUTF8BS [U+0000..U+10FFFF]" testToUTF8BSText + , testCase "fromUTF8BS.toUTF8BS [U+0000..U+10FFFF]" testToFromUTF8BS + , testProperty "fromUTF8BS.toUTF8BS == id" prop_toFromUTF8BS + , testProperty "toUTF8BS == encodeUtf8" prop_toUTF8BS + , testProperty "Nothing = validateUtf8 (encodeUtf8 x)" prop_validateUtf8 + ] testFromUTF8BSEmpty :: Assertion testFromUTF8BSEmpty = mempty @=? fromUTF8BS mempty @@ -43,23 +40,23 @@ testToUTF8BSEmpty = mempty @=? toUTF8BS mempty testToUTF8BSSurr :: Assertion testToUTF8BSSurr = BS.concat (replicate 2048 u_fffd) @=? toUTF8BS surrogates where - surrogates = ['\xD800'..'\xDFFF'] + surrogates = ['\xD800' .. '\xDFFF'] u_fffd = "\xEF\xBF\xBD" testToUTF8BSText :: Assertion testToUTF8BSText = T.encodeUtf8 (T.pack txt) @=? toUTF8BS txt where - txt = ['\x00'..'\x10FFFF'] + txt = ['\x00' .. '\x10FFFF'] testToUTF8BSAscii :: Assertion testToUTF8BSAscii = BS.pack txt @=? toUTF8BS txt where - txt = ['\x00'..'\x7F'] + txt = ['\x00' .. '\x7F'] testToFromUTF8BS :: Assertion testToFromUTF8BS = txt @=? (fromUTF8BS . toUTF8BS) txt where - txt = ['\x0000'..'\xD7FF'] ++ ['\xE000'..'\x10FFFF'] + txt = ['\x0000' .. '\xD7FF'] ++ ['\xE000' .. '\x10FFFF'] prop_toFromUTF8BS :: [Char] -> Property prop_toFromUTF8BS txt = txt === (fromUTF8BS . toUTF8BS) txt diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs index 5609a72b555..09286f390bc 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs @@ -1,8 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} + module UnitTests.Distribution.Utils.Json - ( tests - ) where + ( tests + ) where import Distribution.Utils.Json @@ -11,32 +12,35 @@ import Test.Tasty.HUnit tests :: [TestTree] tests = - [ testCase "escapes strings correctly" $ + [ testCase "escapes strings correctly" $ renderJson (JsonString "foo\"bar") @?= "\"foo\\\"bar\"" - , testCase "renders empty list" $ + , testCase "renders empty list" $ renderJson (JsonArray []) @?= "[]" - , testCase "renders singleton list" $ + , testCase "renders singleton list" $ renderJson (JsonArray [JsonString "foo\"bar"]) @?= "[\"foo\\\"bar\"]" - , testCase "renders list" $ + , testCase "renders list" $ renderJson (JsonArray [JsonString "foo\"bar", JsonString "baz"]) @?= "[\"foo\\\"bar\",\"baz\"]" - , testCase "renders empty object" $ + , testCase "renders empty object" $ renderJson (JsonObject []) @?= "{}" - , testCase "renders singleton object" $ + , testCase "renders singleton object" $ renderJson (JsonObject [("key", JsonString "foo\"bar")]) @?= "{\"key\":\"foo\\\"bar\"}" - , testCase "renders object" $ - renderJson (JsonObject - [ ("key", JsonString "foo\"bar") - , ("key2", JsonString "baz")]) - @?= "{\"key\":\"foo\\\"bar\",\"key2\":\"baz\"}" - , testCase "renders number" $ + , testCase "renders object" $ + renderJson + ( JsonObject + [ ("key", JsonString "foo\"bar") + , ("key2", JsonString "baz") + ] + ) + @?= "{\"key\":\"foo\\\"bar\",\"key2\":\"baz\"}" + , testCase "renders number" $ renderJson (JsonNumber 0) @?= "0" - , testCase "renders negative number" $ + , testCase "renders negative number" $ renderJson (JsonNumber (-1)) @?= "-1" - , testCase "renders big number" $ + , testCase "renders big number" $ renderJson (JsonNumber 5000000) @?= "5000000" - , testCase "renders bool" $ do + , testCase "renders bool" $ do renderJson (JsonBool True) @?= "true" renderJson (JsonBool False) @?= "false" - , testCase "renders null" $ do + , testCase "renders null" $ do renderJson JsonNull @?= "null" - ] + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs index 61e25eec39b..b3352fc7805 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/NubList.hs @@ -1,11 +1,12 @@ -- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} + module UnitTests.Distribution.Utils.NubList - ( tests - ) where + ( tests + ) where -import Prelude () import Distribution.Compat.Prelude.Internal +import Prelude () import Distribution.Utils.NubList import Test.Tasty @@ -14,49 +15,49 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = - [ testCase "NubList retains ordering example" testOrdering - , testCase "NubList removes duplicates example" testDeDupe - , testProperty "NubList retains ordering" prop_Ordering - , testProperty "NubList removes duplicates" prop_DeDupe - , testProperty "fromNubList . toNubList = nub" prop_Nub - , testProperty "Monoid NubList Identity" prop_Identity - , testProperty "Monoid NubList Associativity" prop_Associativity - -- NubListR - , testProperty "NubListR removes duplicates from the right" prop_DeDupeR - ] + [ testCase "NubList retains ordering example" testOrdering + , testCase "NubList removes duplicates example" testDeDupe + , testProperty "NubList retains ordering" prop_Ordering + , testProperty "NubList removes duplicates" prop_DeDupe + , testProperty "fromNubList . toNubList = nub" prop_Nub + , testProperty "Monoid NubList Identity" prop_Identity + , testProperty "Monoid NubList Associativity" prop_Associativity + , -- NubListR + testProperty "NubListR removes duplicates from the right" prop_DeDupeR + ] someIntList :: [Int] -- This list must not have duplicate entries. -someIntList = [ 1, 3, 4, 2, 0, 7, 6, 5, 9, -1 ] +someIntList = [1, 3, 4, 2, 0, 7, 6, 5, 9, -1] testOrdering :: Assertion testOrdering = - assertBool "Maintains element ordering:" $ - fromNubList (toNubList someIntList) == someIntList + assertBool "Maintains element ordering:" $ + fromNubList (toNubList someIntList) == someIntList testDeDupe :: Assertion testDeDupe = - assertBool "De-duplicates a list:" $ - fromNubList (toNubList (someIntList ++ someIntList)) == someIntList + assertBool "De-duplicates a list:" $ + fromNubList (toNubList (someIntList ++ someIntList)) == someIntList -- --------------------------------------------------------------------------- -- QuickCheck properties for NubList prop_Ordering :: [Int] -> Property prop_Ordering xs = - mempty <> toNubList xs' === toNubList xs' <> mempty + mempty <> toNubList xs' === toNubList xs' <> mempty where xs' = nub xs prop_DeDupe :: [Int] -> Property prop_DeDupe xs = - fromNubList (toNubList (xs' ++ xs)) === xs' -- Note, we append primeless xs + fromNubList (toNubList (xs' ++ xs)) === xs' -- Note, we append primeless xs where xs' = nub xs prop_DeDupeR :: [Int] -> Property prop_DeDupeR xs = - fromNubListR (toNubListR (xs ++ xs')) === xs' -- Note, we prepend primeless xs + fromNubListR (toNubListR (xs ++ xs')) === xs' -- Note, we prepend primeless xs where xs' = nub xs @@ -68,9 +69,9 @@ prop_Nub xs = rhs === lhs prop_Identity :: [Int] -> Bool prop_Identity xs = - mempty `mappend` toNubList xs == toNubList xs `mappend` mempty + mempty `mappend` toNubList xs == toNubList xs `mappend` mempty prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool prop_Associativity xs ys zs = - (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs - == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs) + (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs + == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs) diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs index 73298f361de..4fffb3b23bb 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/ShortText.hs @@ -1,12 +1,12 @@ module UnitTests.Distribution.Utils.ShortText - ( tests - ) where + ( tests + ) where import Data.Monoid as Mon import Test.Tasty import Test.Tasty.QuickCheck -import Distribution.Compat.Binary (encode, decode) +import Distribution.Compat.Binary (decode, encode) import Distribution.Utils.ShortText @@ -26,8 +26,8 @@ prop_ShortTextBinaryId a = (decode . encode) a' == a' tests :: [TestTree] tests = - [ testProperty "ShortText Id" prop_ShortTextId - , testProperty "ShortText Ord" prop_ShortTextOrd - , testProperty "ShortText Monoid" prop_ShortTextMonoid - , testProperty "ShortText BinaryId" prop_ShortTextBinaryId - ] + [ testProperty "ShortText Id" prop_ShortTextId + , testProperty "ShortText Ord" prop_ShortTextOrd + , testProperty "ShortText Monoid" prop_ShortTextMonoid + , testProperty "ShortText BinaryId" prop_ShortTextBinaryId + ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index a396dea860c..1b550045d2f 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -1,22 +1,24 @@ {-# LANGUAGE CPP #-} + module UnitTests.Distribution.Utils.Structured (tests) where -import Data.Proxy (Proxy (..)) -import Distribution.Utils.MD5 (md5FromInteger) -import Distribution.Utils.Structured (structureHash, Structured) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=), Assertion) +import Data.Proxy (Proxy (..)) +import Distribution.Utils.MD5 (md5FromInteger) +import Distribution.Utils.Structured (Structured, structureHash) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import Distribution.SPDX.License (License) +import Distribution.SPDX.License (License) import Distribution.Types.VersionRange (VersionRange) #if MIN_VERSION_base(4,7,0) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) -import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) #endif import UnitTests.Orphans () +{- FOURMOLU_DISABLE -} tests :: TestTree tests = testGroup "Distribution.Utils.Structured" -- This test also verifies that structureHash doesn't loop. @@ -32,6 +34,7 @@ tests = testGroup "Distribution.Utils.Structured" md5Check (Proxy :: Proxy LocalBuildInfo) 0x0324f420f9fb98417098127a414cc7c0 #endif ] +{- FOURMOLU_ENABLE -} -- -------------------------------------------------------------------- -- -- utils diff --git a/Cabal-tests/tests/UnitTests/Distribution/Version.hs b/Cabal-tests/tests/UnitTests/Distribution/Version.hs index 27d9f440af8..3d84b5e4495 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Version.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Version.hs @@ -1,83 +1,76 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +-- FIXME {-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-deprecations - -fno-warn-unused-binds #-} --FIXME + -fno-warn-unused-binds #-} + module UnitTests.Distribution.Version (versionTests) where import Distribution.Compat.Prelude.Internal import Prelude () -import Distribution.Parsec (simpleParsec) +import Distribution.Parsec (simpleParsec) import Distribution.Pretty import Distribution.Types.VersionRange.Internal import Distribution.Utils.Generic import Distribution.Version - -import Data.Maybe (fromJust) -import Data.Typeable (typeOf) -import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, counterexample, property, (===), (==>), vectorOf, sized, choose, arbitrarySizedNatural) +import Data.Maybe (fromJust) +import Data.Typeable (typeOf) +import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, arbitrarySizedNatural, choose, counterexample, property, sized, vectorOf, (===), (==>)) import Test.QuickCheck.Instances.Cabal () -import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) -import qualified Distribution.Types.VersionInterval as New +import qualified Distribution.Types.VersionInterval as New import qualified Distribution.Types.VersionInterval.Legacy as Old -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp versionTests :: [TestTree] versionTests = - -- test 'Version' type - [ tp "versionNumbers . mkVersion = id @[NonNegative Int]" prop_VersionId - , tp "versionNumbers . mkVersion = id @Base.Version" prop_VersionId2 - , tp "(==) = (==) `on` versionNumbers" prop_VersionEq - , tp "(==) = (==) `on` mkVersion" prop_VersionEq2 - , tp "compare = compare `on` versionNumbers" prop_VersionOrd - , tp "compare = compare `on` mkVersion" prop_VersionOrd2 - - , tp "readMaybe . show = Just" prop_ShowRead - , tp "read example" prop_ShowRead_example - - , tp "parsec . prettyShow involutive" prop_parsec_disp_inv - - , tp "normaliseVersionRange involutive" prop_normalise_inv - , tp "normaliseVersionRange equivalent" prop_normalise_equiv - , tp "normaliseVersionRange caretequiv" prop_normalise_caret_equiv - , tp "normaliseVersionRange model" prop_normalise_model - - , tp "simplifyVersionRange involutive" prop_simplify_inv - , tp "simplifyVersionRange equivalent" prop_simplify_equiv - -- , tp "simplifyVersionRange caretequiv" prop_simplify_caret_equiv - - , tp "simpleParsec . prettyShow = Just" prop_parse_disp - ] - - ++ - zipWith - (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p) - [1::Int ..] + -- test 'Version' type + [ tp "versionNumbers . mkVersion = id @[NonNegative Int]" prop_VersionId + , tp "versionNumbers . mkVersion = id @Base.Version" prop_VersionId2 + , tp "(==) = (==) `on` versionNumbers" prop_VersionEq + , tp "(==) = (==) `on` mkVersion" prop_VersionEq2 + , tp "compare = compare `on` versionNumbers" prop_VersionOrd + , tp "compare = compare `on` mkVersion" prop_VersionOrd2 + , tp "readMaybe . show = Just" prop_ShowRead + , tp "read example" prop_ShowRead_example + , tp "parsec . prettyShow involutive" prop_parsec_disp_inv + , tp "normaliseVersionRange involutive" prop_normalise_inv + , tp "normaliseVersionRange equivalent" prop_normalise_equiv + , tp "normaliseVersionRange caretequiv" prop_normalise_caret_equiv + , tp "normaliseVersionRange model" prop_normalise_model + , tp "simplifyVersionRange involutive" prop_simplify_inv + , tp "simplifyVersionRange equivalent" prop_simplify_equiv + , -- , tp "simplifyVersionRange caretequiv" prop_simplify_caret_equiv + + tp "simpleParsec . prettyShow = Just" prop_parse_disp + ] + ++ zipWith + (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p) + [1 :: Int ..] -- properties to validate the test framework - [ typProperty prop_nonNull - , typProperty prop_gen_intervals1 - , typProperty prop_gen_intervals2 - - , typProperty prop_anyVersion - , typProperty prop_noVersion - , typProperty prop_thisVersion - , typProperty prop_notThisVersion - , typProperty prop_laterVersion - , typProperty prop_orLaterVersion - , typProperty prop_earlierVersion - , typProperty prop_orEarlierVersion - , typProperty prop_unionVersionRanges - , typProperty prop_intersectVersionRanges - , typProperty prop_withinVersion - , typProperty prop_foldVersionRange - - -- converting between version ranges and version intervals - , typProperty prop_to_from_intervals - ] + [ typProperty prop_nonNull + , typProperty prop_gen_intervals1 + , typProperty prop_gen_intervals2 + , typProperty prop_anyVersion + , typProperty prop_noVersion + , typProperty prop_thisVersion + , typProperty prop_notThisVersion + , typProperty prop_laterVersion + , typProperty prop_orLaterVersion + , typProperty prop_earlierVersion + , typProperty prop_orEarlierVersion + , typProperty prop_unionVersionRanges + , typProperty prop_intersectVersionRanges + , typProperty prop_withinVersion + , typProperty prop_foldVersionRange + , -- converting between version ranges and version intervals + typProperty prop_to_from_intervals + ] where tp :: Testable p => String -> p -> TestTree tp = testProperty @@ -89,24 +82,26 @@ versionTests = ------------------------------------------------------------------------------- newtype VersionArb = VersionArb [Int] - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) -- | 'Version' instance as used by QC 2.9 instance Arbitrary VersionArb where arbitrary = sized $ \n -> - do k <- choose (0, log2 n) - xs <- vectorOf (k+1) arbitrarySizedNatural - return (VersionArb xs) + do + k <- choose (0, log2 n) + xs <- vectorOf (k + 1) arbitrarySizedNatural + return (VersionArb xs) where log2 :: Int -> Int - log2 n | n <= 1 = 0 - | otherwise = 1 + log2 (n `div` 2) + log2 n + | n <= 1 = 0 + | otherwise = 1 + log2 (n `div` 2) shrink (VersionArb xs) = [ VersionArb xs' | xs' <- shrink xs , length xs' > 0 - , all (>=0) xs' + , all (>= 0) xs' ] --------------------- @@ -115,34 +110,34 @@ instance Arbitrary VersionArb where prop_VersionId :: [NonNegative Int] -> Bool prop_VersionId lst0 = - (versionNumbers . mkVersion) lst == lst + (versionNumbers . mkVersion) lst == lst where lst = map getNonNegative lst0 prop_VersionId2 :: VersionArb -> Bool prop_VersionId2 (VersionArb lst) = - (versionNumbers . mkVersion) lst == lst + (versionNumbers . mkVersion) lst == lst prop_VersionEq :: Version -> Version -> Bool prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2 prop_VersionEq2 :: VersionArb -> VersionArb -> Bool prop_VersionEq2 (VersionArb v1) (VersionArb v2) = - (==) v1 v2 == ((==) `on` mkVersion) v1 v2 + (==) v1 v2 == ((==) `on` mkVersion) v1 v2 prop_VersionOrd :: Version -> Version -> Bool prop_VersionOrd v1 v2 = - compare v1 v2 == (compare `on` versionNumbers) v1 v2 + compare v1 v2 == (compare `on` versionNumbers) v1 v2 prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool prop_VersionOrd2 (VersionArb v1) (VersionArb v2) = - (==) v1 v2 == ((==) `on` mkVersion) v1 v2 + (==) v1 v2 == ((==) `on` mkVersion) v1 v2 prop_ShowRead :: Version -> Property prop_ShowRead v = Just v === readMaybe (show v) prop_ShowRead_example :: Bool -prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]" +prop_ShowRead_example = show (mkVersion [1, 2, 3]) == "mkVersion [1,2,3]" --------------------------- -- VersionRange properties @@ -153,16 +148,17 @@ prop_normalise_inv vr = normaliseVersionRange vr === normaliseVersionRange (norm prop_normalise_equiv :: VersionRange -> Version -> Property prop_normalise_equiv vr = - prop_equivalentVersionRange vr (normaliseVersionRange vr) + prop_equivalentVersionRange vr (normaliseVersionRange vr) prop_normalise_caret_equiv :: VersionRange -> Version -> Property -prop_normalise_caret_equiv vr = prop_equivalentVersionRange +prop_normalise_caret_equiv vr = + prop_equivalentVersionRange (transformCaretUpper vr) (transformCaretUpper (normaliseVersionRange vr)) prop_normalise_model :: VersionRange -> Property prop_normalise_model vr = - oldNormaliseVersionRange vr' === newNormaliseVersionRange vr' + oldNormaliseVersionRange vr' === newNormaliseVersionRange vr' where vr' = transformCaret vr @@ -174,11 +170,11 @@ prop_normalise_model vr = prop_simplify_inv :: VersionRange -> Property prop_simplify_inv vr = - simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr) + simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr) prop_simplify_equiv :: VersionRange -> Version -> Property prop_simplify_equiv vr v = - counterexample (show vr') $ prop_equivalentVersionRange vr vr' v + counterexample (show vr') $ prop_equivalentVersionRange vr vr' v where vr' = simplifyVersionRange vr @@ -201,76 +197,79 @@ prop_noVersion v' = prop_thisVersion :: Version -> Version -> Bool prop_thisVersion v v' = - withinRange v' (thisVersion v) - == (v' == v) + withinRange v' (thisVersion v) + == (v' == v) prop_notThisVersion :: Version -> Version -> Bool prop_notThisVersion v v' = - withinRange v' (notThisVersion v) - == (v' /= v) + withinRange v' (notThisVersion v) + == (v' /= v) prop_laterVersion :: Version -> Version -> Bool prop_laterVersion v v' = - withinRange v' (laterVersion v) - == (v' > v) + withinRange v' (laterVersion v) + == (v' > v) prop_orLaterVersion :: Version -> Version -> Bool prop_orLaterVersion v v' = - withinRange v' (orLaterVersion v) - == (v' >= v) + withinRange v' (orLaterVersion v) + == (v' >= v) prop_earlierVersion :: Version -> Version -> Bool prop_earlierVersion v v' = - withinRange v' (earlierVersion v) - == (v' < v) + withinRange v' (earlierVersion v) + == (v' < v) prop_orEarlierVersion :: Version -> Version -> Bool prop_orEarlierVersion v v' = - withinRange v' (orEarlierVersion v) - == (v' <= v) + withinRange v' (orEarlierVersion v) + == (v' <= v) prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool prop_unionVersionRanges vr1 vr2 v' = - withinRange v' (unionVersionRanges vr1 vr2) - == (withinRange v' vr1 || withinRange v' vr2) + withinRange v' (unionVersionRanges vr1 vr2) + == (withinRange v' vr1 || withinRange v' vr2) prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool prop_intersectVersionRanges vr1 vr2 v' = - withinRange v' (intersectVersionRanges vr1 vr2) - == (withinRange v' vr1 && withinRange v' vr2) + withinRange v' (intersectVersionRanges vr1 vr2) + == (withinRange v' vr1 && withinRange v' vr2) prop_withinVersion :: Version -> Version -> Property prop_withinVersion v v' = - withinRange v' (withinVersion v) - === - (v' >= v && v' < upper v) + withinRange v' (withinVersion v) + === (v' >= v && v' < upper v) where upper = alterVersion $ \numbers -> case unsnoc numbers of - Nothing -> [] + Nothing -> [] Just (xs, x) -> xs ++ [x + 1] prop_foldVersionRange :: VersionRange -> Property prop_foldVersionRange range = - expandVR range - === foldVersionRange anyVersion thisVersion - laterVersion earlierVersion - unionVersionRanges intersectVersionRanges - range + expandVR range + === foldVersionRange + anyVersion + thisVersion + laterVersion + earlierVersion + unionVersionRanges + intersectVersionRanges + range where expandVR (MajorBoundVersion v) = - intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v)) + intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v)) expandVR (OrEarlierVersion v) = - unionVersionRanges (thisVersion v) (earlierVersion v) + unionVersionRanges (thisVersion v) (earlierVersion v) expandVR (OrLaterVersion v) = - unionVersionRanges (thisVersion v) (laterVersion v) - expandVR (UnionVersionRanges v1 v2) = + unionVersionRanges (thisVersion v) (laterVersion v) + expandVR (UnionVersionRanges v1 v2) = UnionVersionRanges (expandVR v1) (expandVR v2) expandVR (IntersectVersionRanges v1 v2) = IntersectVersionRanges (expandVR v1) (expandVR v2) expandVR v = v upper = alterVersion $ \numbers -> case unsnoc numbers of - Nothing -> [] + Nothing -> [] Just (xs, x) -> xs ++ [x + 1] prop_isAnyVersion1 :: VersionRange -> Version -> Property @@ -280,8 +279,13 @@ prop_isAnyVersion1 range version = prop_isAnyVersion2 :: VersionRange -> Property prop_isAnyVersion2 range = isAnyVersion range ==> - foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False) - (\_ _ -> False) (\_ _ -> False) + foldVersionRange + True + (\_ -> False) + (\_ -> False) + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (simplifyVersionRange range) prop_isNoVersion :: VersionRange -> Version -> Property @@ -293,24 +297,27 @@ prop_isSpecificVersion1 range (NonEmpty versions) = isJust version && not (null versions') ==> allEqual (fromJust version) versions' where - version = isSpecificVersion range - versions' = filter (`withinRange` range) versions - allEqual x xs = and (zipWith (==) (x:xs) xs) + version = isSpecificVersion range + versions' = filter (`withinRange` range) versions + allEqual x xs = and (zipWith (==) (x : xs) xs) prop_isSpecificVersion2 :: VersionRange -> Property prop_isSpecificVersion2 range = isJust version ==> - foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing) - (\_ _ -> Nothing) (\_ _ -> Nothing) + foldVersionRange + Nothing + Just + (\_ -> Nothing) + (\_ -> Nothing) + (\_ _ -> Nothing) + (\_ _ -> Nothing) (simplifyVersionRange range) - == version - + == version where version = isSpecificVersion range -- | Check that our VersionIntervals' arbitrary instance generates intervals -- that satisfies the invariant. --- prop_gen_intervals1 :: VersionIntervals -> Property prop_gen_intervals1 = property . New.invariantVersionIntervals @@ -318,14 +325,14 @@ prop_gen_intervals1 = property . New.invariantVersionIntervals -- 'VersionRange' and then into the true intervals type gives us back -- the exact same sequence of intervals. This tells us that our arbitrary -- instance for 'VersionIntervals'' is ok. --- prop_gen_intervals2 :: VersionIntervals -> Property prop_gen_intervals2 intervals = - toVersionIntervals (fromVersionIntervals intervals) === intervals + toVersionIntervals (fromVersionIntervals intervals) === intervals + -- + -- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on -- 'VersionIntervals'. --- prop_to_from_intervals :: VersionIntervals -> Bool prop_to_from_intervals intervals = toVersionIntervals (fromVersionIntervals intervals) == intervals @@ -334,21 +341,22 @@ prop_to_from_intervals intervals = -- equivalentVersionRange helper prop_equivalentVersionRange - :: VersionRange -> VersionRange -> Version -> Property + :: VersionRange -> VersionRange -> Version -> Property prop_equivalentVersionRange range range' version = - withinRange version range === withinRange version range' + withinRange version range === withinRange version range' -------------------------------- -- Parsing and pretty printing -- prop_parsec_disp_inv :: VersionRange -> Property prop_parsec_disp_inv vr = - parseDisp vr === (parseDisp vr >>= parseDisp) + parseDisp vr === (parseDisp vr >>= parseDisp) where parseDisp = simpleParsec . prettyShow prop_parse_disp :: VersionRange -> Property -prop_parse_disp vr = counterexample (show (prettyShow vr')) $ +prop_parse_disp vr = + counterexample (show (prettyShow vr')) $ fmap s (simpleParsec (prettyShow vr')) === Just vr' where -- we have to strip parens, because arbitrary 'VersionRange' may have @@ -358,62 +366,61 @@ prop_parse_disp vr = counterexample (show (prettyShow vr')) $ prop_parse_disp1 :: VersionRange -> Bool prop_parse_disp1 vr = - simpleParsec (prettyShow vr) == Just (normaliseVersionRange vr) + simpleParsec (prettyShow vr) == Just (normaliseVersionRange vr) prop_parse_disp2 :: VersionRange -> Property prop_parse_disp2 vr = let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr)) a = Just (prettyShow vr) - in - counterexample ("Expected: " ++ show a) $ - counterexample ("But got: " ++ show b) $ - b == a + in counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a prop_parse_disp3 :: VersionRange -> Property prop_parse_disp3 vr = let a = Just (prettyShow vr) b = fmap displayRaw (simpleParsec (prettyShow vr)) - in - counterexample ("Expected: " ++ show a) $ - counterexample ("But got: " ++ show b) $ - b == a + in counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a prop_parse_disp4 :: VersionRange -> Property prop_parse_disp4 vr = let a = Just vr b = (simpleParsec (prettyShow vr)) - in - counterexample ("Expected: " ++ show a) $ - counterexample ("But got: " ++ show b) $ - b == a + in counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a prop_parse_disp5 :: VersionRange -> Property prop_parse_disp5 vr = let a = Just vr b = simpleParsec (displayRaw vr) - in - counterexample ("Expected: " ++ show a) $ - counterexample ("But got: " ++ show b) $ - b == a + in counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a displayRaw :: VersionRange -> String displayRaw = - Disp.render - . cataVersionRange alg . normaliseVersionRange + Disp.render + . cataVersionRange alg + . normaliseVersionRange where - -- precedence: -- All the same as the usual pretty printer, except for the parens - alg (ThisVersionF v) = Disp.text "==" <<>> pretty v - alg (LaterVersionF v) = Disp.char '>' <<>> pretty v - alg (EarlierVersionF v) = Disp.char '<' <<>> pretty v - alg (OrLaterVersionF v) = Disp.text ">=" <<>> pretty v - alg (OrEarlierVersionF v) = Disp.text "<=" <<>> pretty v - alg (MajorBoundVersionF v) = Disp.text "^>=" <<>> pretty v - alg (UnionVersionRangesF r1 r2) = r1 <+> Disp.text "||" <+> r2 + alg (ThisVersionF v) = Disp.text "==" <<>> pretty v + alg (LaterVersionF v) = Disp.char '>' <<>> pretty v + alg (EarlierVersionF v) = Disp.char '<' <<>> pretty v + alg (OrLaterVersionF v) = Disp.text ">=" <<>> pretty v + alg (OrEarlierVersionF v) = Disp.text "<=" <<>> pretty v + alg (MajorBoundVersionF v) = Disp.text "^>=" <<>> pretty v + alg (UnionVersionRangesF r1 r2) = r1 <+> Disp.text "||" <+> r2 alg (IntersectVersionRangesF r1 r2) = r1 <+> Disp.text "&&" <+> r2 dispWild v = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int (versionNumbers v))) + Disp.hcat + ( Disp.punctuate + (Disp.char '.') + (map Disp.int (versionNumbers v)) + ) <<>> Disp.text ".*" diff --git a/Cabal-tests/tests/UnitTests/Orphans.hs b/Cabal-tests/tests/UnitTests/Orphans.hs index d6b49a91929..8171f7e8b9d 100644 --- a/Cabal-tests/tests/UnitTests/Orphans.hs +++ b/Cabal-tests/tests/UnitTests/Orphans.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module UnitTests.Orphans where #if !MIN_VERSION_base(4,7,0) diff --git a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs index 5992a61d0d0..3a69f546f25 100644 --- a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs +++ b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs @@ -1,6 +1,5 @@ -- This is Distribution.Extra.Doctest module from cabal-doctest-1.0.4 -- This isn't technically a Custom-Setup script, but it /was/. - {- Copyright (c) 2017, Oleg Grenrus @@ -35,9 +34,9 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} + -- | The provided 'generateBuildModule' generates 'Build_doctests' module. -- That module exports enough configuration, so your doctests could be simply -- @@ -68,14 +67,13 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -- /Note:/ you don't need to depend on @Cabal@ if you use only -- 'defaultMainWithDoctests' in the @Setup.hs@. --- -module CabalDoctestSetup ( - defaultMainWithDoctests, - defaultMainAutoconfWithDoctests, - addDoctestsUserHook, - doctestsUserHooks, - generateBuildModule, - ) where +module CabalDoctestSetup + ( defaultMainWithDoctests + , defaultMainAutoconfWithDoctests + , addDoctestsUserHook + , doctestsUserHooks + , generateBuildModule + ) where -- Hacky way to suppress few deprecation warnings. #if MIN_VERSION_Cabal(1,24,0) @@ -83,43 +81,79 @@ module CabalDoctestSetup ( #endif import Control.Monad - (when) + ( when + ) import Data.IORef - (modifyIORef, newIORef, readIORef) + ( modifyIORef + , newIORef + , readIORef + ) import Data.List - (nub) + ( nub + ) import Data.Maybe - (mapMaybe, maybeToList) + ( mapMaybe + , maybeToList + ) import Data.String - (fromString) + ( fromString + ) import Distribution.Package - (InstalledPackageId, Package (..)) + ( InstalledPackageId + , Package (..) + ) import Distribution.PackageDescription - (BuildInfo (..), Executable (..), GenericPackageDescription, - Library (..), PackageDescription, TestSuite (..)) + ( BuildInfo (..) + , Executable (..) + , GenericPackageDescription + , Library (..) + , PackageDescription + , TestSuite (..) + ) import Distribution.Simple - (UserHooks (..), autoconfUserHooks, defaultMainWithHooks, - simpleUserHooks) + ( UserHooks (..) + , autoconfUserHooks + , defaultMainWithHooks + , simpleUserHooks + ) import Distribution.Simple.Compiler - (CompilerFlavor (GHC), CompilerId (..), PackageDB (..), compilerId) + ( CompilerFlavor (GHC) + , CompilerId (..) + , PackageDB (..) + , compilerId + ) import Distribution.Simple.LocalBuildInfo - (ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo, - compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI) + ( ComponentLocalBuildInfo (componentPackageDeps) + , LocalBuildInfo + , compiler + , withExeLBI + , withLibLBI + , withPackageDB + , withTestLBI + ) import Distribution.Simple.Setup - (BuildFlags (buildDistPref, buildVerbosity), - HaddockFlags (haddockDistPref, haddockVerbosity), emptyBuildFlags, - fromFlag) + ( BuildFlags (buildDistPref, buildVerbosity) + , HaddockFlags (haddockDistPref, haddockVerbosity) + , emptyBuildFlags + , fromFlag + ) import Distribution.Simple.Utils - (createDirectoryIfMissingVerbose, info) + ( createDirectoryIfMissingVerbose + , info + ) import Distribution.Text - (display) + ( display + ) import System.FilePath - (()) + ( () + ) -import qualified Data.Foldable as F - (for_) +import qualified Data.Foldable as F + ( for_ + ) import qualified Data.Traversable as T - (traverse) + ( traverse + ) #if MIN_VERSION_Cabal(1,25,0) import Distribution.Simple.BuildPaths @@ -213,38 +247,42 @@ getSymbolicPath = id -- main = defaultMainWithDoctests "doctests" -- @ defaultMainWithDoctests - :: String -- ^ doctests test-suite name - -> IO () + :: String + -- ^ doctests test-suite name + -> IO () defaultMainWithDoctests = defaultMainWithHooks . doctestsUserHooks -- | Like 'defaultMainWithDoctests', for 'build-type: Configure' packages. -- -- @since 1.0.2 defaultMainAutoconfWithDoctests - :: String -- ^ doctests test-suite name - -> IO () + :: String + -- ^ doctests test-suite name + -> IO () defaultMainAutoconfWithDoctests n = - defaultMainWithHooks (addDoctestsUserHook n autoconfUserHooks) + defaultMainWithHooks (addDoctestsUserHook n autoconfUserHooks) -- | 'simpleUserHooks' with 'generateBuildModule' prepended to the 'buildHook'. doctestsUserHooks - :: String -- ^ doctests test-suite name - -> UserHooks + :: String + -- ^ doctests test-suite name + -> UserHooks doctestsUserHooks testsuiteName = - addDoctestsUserHook testsuiteName simpleUserHooks + addDoctestsUserHook testsuiteName simpleUserHooks -- | -- -- @since 1.0.2 addDoctestsUserHook :: String -> UserHooks -> UserHooks -addDoctestsUserHook testsuiteName uh = uh +addDoctestsUserHook testsuiteName uh = + uh { buildHook = \pkg lbi hooks flags -> do generateBuildModule testsuiteName flags pkg lbi buildHook uh pkg lbi hooks flags - -- We use confHook to add "Build_Doctests" to otherModules and autogenModules. - -- - -- We cannot use HookedBuildInfo as it let's alter only the library and executables. - , confHook = \(gpd, hbi) flags -> + , -- We use confHook to add "Build_Doctests" to otherModules and autogenModules. + -- + -- We cannot use HookedBuildInfo as it let's alter only the library and executables. + confHook = \(gpd, hbi) flags -> confHook uh (amendGPD testsuiteName gpd, hbi) flags , haddockHook = \pkg lbi hooks flags -> do generateBuildModule testsuiteName (haddockToBuildFlags flags) pkg lbi @@ -253,9 +291,10 @@ addDoctestsUserHook testsuiteName uh = uh -- | Convert only flags used by 'generateBuildModule'. haddockToBuildFlags :: HaddockFlags -> BuildFlags -haddockToBuildFlags f = emptyBuildFlags +haddockToBuildFlags f = + emptyBuildFlags { buildVerbosity = haddockVerbosity f - , buildDistPref = haddockDistPref f + , buildDistPref = haddockDistPref f } data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show) @@ -272,10 +311,10 @@ nameToString n = case n of -- allowed in Haskell identifier names. fixchar :: Char -> Char fixchar '-' = '_' - fixchar c = c + fixchar c = c data Component = Component Name [String] [String] [String] - deriving Show + deriving (Show) -- | Generate a build module for the test suite. -- @@ -292,18 +331,23 @@ data Component = Component Name [String] [String] [String] -- buildHook simpleUserHooks pkg lbi hooks flags -- } -- @ +{- FOURMOLU_DISABLE -} generateBuildModule - :: String -- ^ doctests test-suite name - -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () + :: String + -- ^ doctests test-suite name + -> BuildFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () generateBuildModule testSuiteName flags pkg lbi = do let verbosity = fromFlag (buildVerbosity flags) let distPref = fromFlag (buildDistPref flags) -- Package DBs & environments - let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref "package.conf.inplace" ] + let dbStack = withPackageDB lbi ++ [SpecificPackageDB $ distPref "package.conf.inplace"] let dbFlags = "-hide-all-packages" : packageDbArgs dbStack let envFlags - | ghcCanBeToldToIgnorePkgEnvs = [ "-package-env=-" ] + | ghcCanBeToldToIgnorePkgEnvs = ["-package-env=-"] | otherwise = [] withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do @@ -312,7 +356,6 @@ generateBuildModule testSuiteName flags pkg lbi = do #else let testAutogenDir = autogenModulesDir lbi #endif - createDirectoryIfMissingVerbose verbosity True testAutogenDir let buildDoctestsFile = testAutogenDir "Build_doctests.hs" @@ -320,15 +363,16 @@ generateBuildModule testSuiteName flags pkg lbi = do -- First, we create the autogen'd module Build_doctests. -- Initially populate Build_doctests with a simple preamble. info verbosity $ "cabal-doctest: writing Build_doctests to " ++ buildDoctestsFile - writeFile buildDoctestsFile $ unlines - [ "module Build_doctests where" - , "" - , "import Prelude" - , "" - , "data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)" - , "data Component = Component Name [String] [String] [String] deriving (Eq, Show)" - , "" - ] + writeFile buildDoctestsFile $ + unlines + [ "module Build_doctests where" + , "" + , "import Prelude" + , "" + , "data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)" + , "data Component = Component Name [String] [String] [String] deriving (Eq, Show)" + , "" + ] -- we cannot traverse, only traverse_ -- so we use IORef to collect components @@ -337,85 +381,83 @@ generateBuildModule testSuiteName flags pkg lbi = do let testBI = testBuildInfo suite -- TODO: `words` is not proper parser (no support for quotes) - let additionalFlags = maybe [] words - $ lookup "x-doctest-options" - $ customFieldsBI testBI + let additionalFlags = + maybe [] words $ + lookup "x-doctest-options" $ + customFieldsBI testBI - let additionalModules = maybe [] words - $ lookup "x-doctest-modules" - $ customFieldsBI testBI + let additionalModules = + maybe [] words $ + lookup "x-doctest-modules" $ + customFieldsBI testBI - let additionalDirs' = maybe [] words - $ lookup "x-doctest-source-dirs" - $ customFieldsBI testBI + let additionalDirs' = + maybe [] words $ + lookup "x-doctest-source-dirs" $ + customFieldsBI testBI additionalDirs <- mapM (fmap ("-i" ++) . makeAbsolute) additionalDirs' -- Next, for each component (library or executable), we get to Build_doctests -- the sets of flags needed to run doctest on that component. let getBuildDoctests withCompLBI mbCompName compExposedModules compMainIs compBuildInfo = - withCompLBI pkg lbi $ \comp compCfg -> do - let compBI = compBuildInfo comp - - -- modules - let modules = compExposedModules comp ++ otherModules compBI - -- it seems that doctest is happy to take in module names, not actual files! - let module_sources = modules - - -- We need the directory with the component's cabal_macros.h! -#if MIN_VERSION_Cabal(1,25,0) - let compAutogenDir = autogenComponentModulesDir lbi compCfg -#else - let compAutogenDir = autogenModulesDir lbi -#endif - - -- Lib sources and includes - iArgsNoPrefix - <- mapM makeAbsolute - $ compAutogenDir -- autogenerated files - : (distPref ++ "/build") -- preprocessed files (.hsc -> .hs); "build" is hardcoded in Cabal. - : map getSymbolicPath (hsSourceDirs compBI) - includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI - -- We clear all includes, so the CWD isn't used. - let iArgs' = map ("-i"++) iArgsNoPrefix - iArgs = "-i" : iArgs' - - -- default-extensions - let extensionArgs = map (("-X"++) . display) $ defaultExtensions compBI - - -- CPP includes, i.e. include cabal_macros.h - let cppFlags = map ("-optP"++) $ - [ "-include", compAutogenDir ++ "/cabal_macros.h" ] - ++ cppOptions compBI - - -- Unlike other modules, the main-is module of an executable is not - -- guaranteed to share a module name with its filepath name. That is, - -- even though the main-is module is named Main, its filepath might - -- actually be Something.hs. To account for this possibility, we simply - -- pass the full path to the main-is module instead. - mainIsPath <- T.traverse (findFileEx verbosity iArgsNoPrefix) (compMainIs comp) - - let all_sources = map display module_sources - ++ additionalModules - ++ maybeToList mainIsPath - - let component = Component - (mbCompName comp) - (formatDeps $ testDeps compCfg suitecfg) - (concat - [ iArgs - , additionalDirs - , includeArgs - , envFlags - , dbFlags - , cppFlags - , extensionArgs - , additionalFlags - ]) - all_sources - - -- modify IORef, append component - modifyIORef componentsRef (\cs -> cs ++ [component]) + withCompLBI pkg lbi $ \comp compCfg -> do + let compBI = compBuildInfo comp + + -- modules + let modules = compExposedModules comp ++ otherModules compBI + -- it seems that doctest is happy to take in module names, not actual files! + let module_sources = modules + + -- We need the directory with the component's cabal_macros.h! + + let compAutogenDir = autogenComponentModulesDir lbi compCfg + -- Lib sources and includes + iArgsNoPrefix <- mapM makeAbsolute + $ compAutogenDir -- autogenerated files + : (distPref ++ "/build") -- preprocessed files (.hsc -> .hs); "build" is hardcoded in Cabal. + : map getSymbolicPath (hsSourceDirs compBI) + includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI + -- We clear all includes, so the CWD isn't used. + let iArgs' = map ("-i"++) iArgsNoPrefix + iArgs = "-i" : iArgs' + + -- default-extensions + let extensionArgs = map (("-X"++) . display) $ defaultExtensions compBI + + -- CPP includes, i.e. include cabal_macros.h + let cppFlags = map ("-optP"++) $ + [ "-include", compAutogenDir ++ "/cabal_macros.h" ] + ++ cppOptions compBI + + -- Unlike other modules, the main-is module of an executable is not + -- guaranteed to share a module name with its filepath name. That is, + -- even though the main-is module is named Main, its filepath might + -- actually be Something.hs. To account for this possibility, we simply + -- pass the full path to the main-is module instead. + mainIsPath <- T.traverse (findFileEx verbosity iArgsNoPrefix) (compMainIs comp) + + let all_sources = map display module_sources + ++ additionalModules + ++ maybeToList mainIsPath + + let component = Component + (mbCompName comp) + (formatDeps $ testDeps compCfg suitecfg) + (concat + [ iArgs + , additionalDirs + , includeArgs + , envFlags + , dbFlags + , cppFlags + , extensionArgs + , additionalFlags + ]) + all_sources + + -- modify IORef, append component + modifyIORef componentsRef (\cs -> cs ++ [component]) -- For now, we only check for doctests in libraries and executables. getBuildDoctests withLibLBI mbLibraryName exposedModules (const Nothing) libBuildInfo diff --git a/Cabal-tests/tests/custom-setup/CustomSetupTests.hs b/Cabal-tests/tests/custom-setup/CustomSetupTests.hs index ef989a3b630..df1fea1b301 100644 --- a/Cabal-tests/tests/custom-setup/CustomSetupTests.hs +++ b/Cabal-tests/tests/custom-setup/CustomSetupTests.hs @@ -1,6 +1,7 @@ -- This test-suite verifies some custom-setup scripts compile ok -- so we don't break them by accident, i.e. when breakage can be prevented. module Main (main) where + import CabalDoctestSetup () import IdrisSetup () diff --git a/Cabal-tests/tests/custom-setup/IdrisSetup.hs b/Cabal-tests/tests/custom-setup/IdrisSetup.hs index 8fc21c80ece..e54400b4722 100644 --- a/Cabal-tests/tests/custom-setup/IdrisSetup.hs +++ b/Cabal-tests/tests/custom-setup/IdrisSetup.hs @@ -1,5 +1,4 @@ -- This is Setup.hs script from idris-1.1.1 - {- Copyright (c) 2011 Edwin Brady @@ -33,12 +32,12 @@ 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. -*** End of disclaimer. *** +\*** End of disclaimer. *** -} - {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} + module IdrisSetup (main) where #if !defined(MIN_VERSION_Cabal) @@ -49,27 +48,26 @@ module IdrisSetup (main) where # define MIN_VERSION_base(x,y,z) 0 #endif +import Control.Exception (SomeException, catch) import Control.Monad import Data.IORef -import Control.Exception (SomeException, catch) import Data.String (fromString) +import Distribution.Compiler +import Distribution.PackageDescription import Distribution.Simple import Distribution.Simple.BuildPaths import Distribution.Simple.InstallDirs as I import Distribution.Simple.LocalBuildInfo as L -import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P -import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, notice, installOrdinaryFiles) -import Distribution.Simple.Utils (rewriteFileEx) -import Distribution.Compiler -import Distribution.PackageDescription +import qualified Distribution.Simple.Setup as S +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, installOrdinaryFiles, notice, rewriteFileEx) import Distribution.Text +import System.Directory import System.Environment import System.Exit -import System.FilePath ((), splitDirectories,isAbsolute) -import System.Directory +import System.FilePath (isAbsolute, splitDirectories, ()) import qualified System.FilePath.Posix as Px import System.Process @@ -110,7 +108,7 @@ mymake = "gmake" mymake = "make" #endif make verbosity = - P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake + P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake #ifdef mingw32_HOST_OS windres verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "windres" @@ -134,10 +132,10 @@ execOnly flags = isRelease :: S.ConfigFlags -> Bool isRelease flags = - case lookup (mkFlagName "release") (configConfigurationsFlags flags) of - Just True -> True - Just False -> False - Nothing -> False + case lookup (mkFlagName "release") (configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False isFreestanding :: S.ConfigFlags -> Bool isFreestanding flags = @@ -155,96 +153,112 @@ mkFlagName = FlagName -- Clean idrisClean _ flags _ _ = cleanStdLib - where - verbosity = S.fromFlag $ S.cleanVerbosity flags + where + verbosity = S.fromFlag $ S.cleanVerbosity flags - cleanStdLib = makeClean "libs" + cleanStdLib = makeClean "libs" - makeClean dir = make verbosity [ "-C", dir, "clean", "IDRIS=idris" ] + makeClean dir = make verbosity ["-C", dir, "clean", "IDRIS=idris"] -- ----------------------------------------------------------------------------- -- Configure gitHash :: IO String -gitHash = do h <- Control.Exception.catch (readProcess "git" ["rev-parse", "--short", "HEAD"] "") - (\e -> let e' = (e :: SomeException) in return "PRE") - return $ takeWhile (/= '\n') h +gitHash = do + h <- + Control.Exception.catch + (readProcess "git" ["rev-parse", "--short", "HEAD"] "") + (\e -> let e' = (e :: SomeException) in return "PRE") + return $ takeWhile (/= '\n') h -- Put the Git hash into a module for use in the program -- For release builds, just put the empty string in the module generateVersionModule verbosity dir release = do - hash <- gitHash - let versionModulePath = dir "Version_idris" Px.<.> "hs" - putStrLn $ "Generating " ++ versionModulePath ++ - if release then " for release" else " for prerelease " ++ hash - createDirectoryIfMissingVerbose verbosity True dir - rewriteFileEx verbosity versionModulePath (versionModuleContents hash) - - where versionModuleContents h = "module Version_idris where\n\n" ++ - "gitHash :: String\n" ++ - if release - then "gitHash = \"\"\n" - else "gitHash = \"git:" ++ h ++ "\"\n" + hash <- gitHash + let versionModulePath = dir "Version_idris" Px.<.> "hs" + putStrLn $ + "Generating " + ++ versionModulePath + ++ if release then " for release" else " for prerelease " ++ hash + createDirectoryIfMissingVerbose verbosity True dir + rewriteFileEx verbosity versionModulePath (versionModuleContents hash) + where + versionModuleContents h = + "module Version_idris where\n\n" + ++ "gitHash :: String\n" + ++ if release + then "gitHash = \"\"\n" + else "gitHash = \"git:" ++ h ++ "\"\n" -- Generate a module that contains the lib path for a freestanding Idris generateTargetModule verbosity dir targetDir = do - let absPath = isAbsolute targetDir - let targetModulePath = dir "Target_idris" Px.<.> "hs" - putStrLn $ "Generating " ++ targetModulePath - createDirectoryIfMissingVerbose verbosity True dir - rewriteFileEx verbosity targetModulePath (versionModuleContents absPath targetDir) - where versionModuleContents absolute td = "module Target_idris where\n\n" ++ - "import System.FilePath\n" ++ - "import System.Environment\n" ++ - "getDataDir :: IO String\n" ++ - if absolute - then "getDataDir = return \"" ++ td ++ "\"\n" - else "getDataDir = do \n" ++ - " expath <- getExecutablePath\n" ++ - " execDir <- return $ dropFileName expath\n" ++ - " return $ execDir ++ \"" ++ td ++ "\"\n" - ++ "getDataFileName :: FilePath -> IO FilePath\n" - ++ "getDataFileName name = do\n" - ++ " dir <- getDataDir\n" - ++ " return (dir ++ \"/\" ++ name)" + let absPath = isAbsolute targetDir + let targetModulePath = dir "Target_idris" Px.<.> "hs" + putStrLn $ "Generating " ++ targetModulePath + createDirectoryIfMissingVerbose verbosity True dir + rewriteFileEx verbosity targetModulePath (versionModuleContents absPath targetDir) + where + versionModuleContents absolute td = + "module Target_idris where\n\n" + ++ "import System.FilePath\n" + ++ "import System.Environment\n" + ++ "getDataDir :: IO String\n" + ++ if absolute + then "getDataDir = return \"" ++ td ++ "\"\n" + else + "getDataDir = do \n" + ++ " expath <- getExecutablePath\n" + ++ " execDir <- return $ dropFileName expath\n" + ++ " return $ execDir ++ \"" + ++ td + ++ "\"\n" + ++ "getDataFileName :: FilePath -> IO FilePath\n" + ++ "getDataFileName name = do\n" + ++ " dir <- getDataDir\n" + ++ " return (dir ++ \"/\" ++ name)" -- a module that has info about existence and location of a bundled toolchain generateToolchainModule verbosity srcDir toolDir = do - let commonContent = "module Tools_idris where\n\n" - let toolContent = case toolDir of - Just dir -> "hasBundledToolchain = True\n" ++ - "getToolchainDir = \"" ++ dir ++ "\"\n" - Nothing -> "hasBundledToolchain = False\n" ++ - "getToolchainDir = \"\"" - let toolPath = srcDir "Tools_idris" Px.<.> "hs" - createDirectoryIfMissingVerbose verbosity True srcDir - rewriteFileEx verbosity toolPath (commonContent ++ toolContent) + let commonContent = "module Tools_idris where\n\n" + let toolContent = case toolDir of + Just dir -> + "hasBundledToolchain = True\n" + ++ "getToolchainDir = \"" + ++ dir + ++ "\"\n" + Nothing -> + "hasBundledToolchain = False\n" + ++ "getToolchainDir = \"\"" + let toolPath = srcDir "Tools_idris" Px.<.> "hs" + createDirectoryIfMissingVerbose verbosity True srcDir + rewriteFileEx verbosity toolPath (commonContent ++ toolContent) idrisConfigure _ flags pkgdesc local = do - configureRTS - withLibLBI pkgdesc local $ \_ libcfg -> do - let libAutogenDir = autogenComponentModulesDir local libcfg - generateVersionModule verbosity libAutogenDir (isRelease (configFlags local)) - if isFreestanding $ configFlags local - then do - toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR" - generateToolchainModule verbosity libAutogenDir toolDir - targetDir <- lookupEnv "IDRIS_LIB_DIR" - case targetDir of - Just d -> generateTargetModule verbosity libAutogenDir d - Nothing -> error $ "Trying to build freestanding without a target directory." - ++ " Set it by defining IDRIS_LIB_DIR." - else - generateToolchainModule verbosity libAutogenDir Nothing - where - verbosity = S.fromFlag $ S.configVerbosity flags - version = pkgVersion . package $ localPkgDescr local - - -- This is a hack. I don't know how to tell cabal that a data file needs - -- installing but shouldn't be in the distribution. And it won't make the - -- distribution if it's not there, so instead I just delete - -- the file after configure. - configureRTS = make verbosity ["-C", "rts", "clean"] + configureRTS + withLibLBI pkgdesc local $ \_ libcfg -> do + let libAutogenDir = autogenComponentModulesDir local libcfg + generateVersionModule verbosity libAutogenDir (isRelease (configFlags local)) + if isFreestanding $ configFlags local + then do + toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR" + generateToolchainModule verbosity libAutogenDir toolDir + targetDir <- lookupEnv "IDRIS_LIB_DIR" + case targetDir of + Just d -> generateTargetModule verbosity libAutogenDir d + Nothing -> + error $ + "Trying to build freestanding without a target directory." + ++ " Set it by defining IDRIS_LIB_DIR." + else generateToolchainModule verbosity libAutogenDir Nothing + where + verbosity = S.fromFlag $ S.configVerbosity flags + version = pkgVersion . package $ localPkgDescr local + + -- This is a hack. I don't know how to tell cabal that a data file needs + -- installing but shouldn't be in the distribution. And it won't make the + -- distribution if it's not there, so instead I just delete + -- the file after configure. + configureRTS = make verbosity ["-C", "rts", "clean"] #if !(MIN_VERSION_Cabal(2,0,0)) autogenComponentModulesDir lbi _ = autogenModulesDir lbi @@ -286,9 +300,9 @@ idrisPostSDist args flags desc lbi = do getVersion :: Args -> S.BuildFlags -> IO HookedBuildInfo getVersion args flags = do - hash <- gitHash - let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo - return (Just buildinfo, []) + hash <- gitHash + let buildinfo = (emptyBuildInfo{cppOptions = ["-DVERSION=" ++ hash]}) :: BuildInfo + return (Just buildinfo, []) idrisPreBuild args flags = do #ifdef mingw32_HOST_OS @@ -302,53 +316,61 @@ idrisPreBuild args flags = do return (Nothing, []) #endif -idrisBuild _ flags _ local - = if (execOnly (configFlags local)) then buildRTS - else do buildStdLib - buildRTS - where - verbosity = S.fromFlag $ S.buildVerbosity flags - - buildStdLib = do - putStrLn "Building libraries..." - makeBuild "libs" - where - makeBuild dir = make verbosity [ "-C", dir, "build" , "IDRIS=" ++ idrisCmd local] - - buildRTS = make verbosity (["-C", "rts", "build"] ++ - gmpflag (usesGMP (configFlags local))) - - gmpflag False = [] - gmpflag True = ["GMP=-DIDRIS_GMP"] +idrisBuild _ flags _ local = + if (execOnly (configFlags local)) + then buildRTS + else do + buildStdLib + buildRTS + where + verbosity = S.fromFlag $ S.buildVerbosity flags + + buildStdLib = do + putStrLn "Building libraries..." + makeBuild "libs" + where + makeBuild dir = make verbosity ["-C", dir, "build", "IDRIS=" ++ idrisCmd local] + + buildRTS = + make + verbosity + ( ["-C", "rts", "build"] + ++ gmpflag (usesGMP (configFlags local)) + ) + + gmpflag False = [] + gmpflag True = ["GMP=-DIDRIS_GMP"] -- ----------------------------------------------------------------------------- -- Copy/Install -idrisInstall verbosity copy pkg local - = if (execOnly (configFlags local)) then installRTS - else do installStdLib - installRTS - installManPage - where - target = datadir $ L.absoluteInstallDirs pkg local copy - - installStdLib = do - let target' = target -- "libs" - putStrLn $ "Installing libraries in " ++ target' - makeInstall "libs" target' - - installRTS = do - let target' = target "rts" - putStrLn $ "Installing run time system in " ++ target' - makeInstall "rts" target' - - installManPage = do - let mandest = mandir (L.absoluteInstallDirs pkg local copy) ++ "/man1" - notice verbosity $ unwords ["Copying man page to", mandest] - installOrdinaryFiles verbosity mandest [("man", "idris.1")] - - makeInstall src target = - make verbosity [ "-C", src, "install" , "TARGET=" ++ target, "IDRIS=" ++ idrisCmd local] +idrisInstall verbosity copy pkg local = + if (execOnly (configFlags local)) + then installRTS + else do + installStdLib + installRTS + installManPage + where + target = datadir $ L.absoluteInstallDirs pkg local copy + + installStdLib = do + let target' = target -- "libs" + putStrLn $ "Installing libraries in " ++ target' + makeInstall "libs" target' + + installRTS = do + let target' = target "rts" + putStrLn $ "Installing run time system in " ++ target' + makeInstall "rts" target' + + installManPage = do + let mandest = mandir (L.absoluteInstallDirs pkg local copy) ++ "/man1" + notice verbosity $ unwords ["Copying man page to", mandest] + installOrdinaryFiles verbosity mandest [("man", "idris.1")] + + makeInstall src target = + make verbosity ["-C", src, "install", "TARGET=" ++ target, "IDRIS=" ++ idrisCmd local] -- ----------------------------------------------------------------------------- -- Test @@ -357,7 +379,7 @@ idrisInstall verbosity copy pkg local -- When fetching modules, idris uses the second path (in the pkg record), -- which by default is the root folder of the project. -- We want it to be the install directory where we put the idris libraries. -fixPkg pkg target = pkg { dataDir = target } +fixPkg pkg target = pkg{dataDir = target} idrisTestHook args pkg local hooks flags = do let target = datadir $ L.absoluteInstallDirs pkg local NoCopyDest @@ -368,6 +390,7 @@ idrisTestHook args pkg local hooks flags = do -- Install libraries during both copy and install -- See https://github.com/haskell/cabal/issues/709 +{- FOURMOLU_DISABLE -} main = defaultMainWithHooks $ simpleUserHooks { postClean = idrisClean , postConf = idrisConfigure @@ -386,3 +409,4 @@ main = defaultMainWithHooks $ simpleUserHooks #endif , testHook = idrisTestHook } +{- FOURMOLU_ENABLE -} diff --git a/Cabal-tests/tests/misc/ghc-supported-languages.hs b/Cabal-tests/tests/misc/ghc-supported-languages.hs index e8036a0364b..94edc799b8c 100644 --- a/Cabal-tests/tests/misc/ghc-supported-languages.hs +++ b/Cabal-tests/tests/misc/ghc-supported-languages.hs @@ -1,78 +1,77 @@ -- | A test program to check that ghc has got all of its extensions registered --- module Main where -import Language.Haskell.Extension -import Distribution.Text import Distribution.Simple.Utils +import Distribution.Text import Distribution.Verbosity +import Language.Haskell.Extension -import Data.List ((\\)) -import Data.Maybe import Control.Applicative import Control.Monad +import Data.List ((\\)) +import Data.Maybe import System.Environment import System.Exit -- | A list of GHC extensions that are deliberately not registered, -- e.g. due to being experimental and not ready for public consumption --- exceptions = map readExtension [] checkProblems :: [Extension] -> [String] checkProblems implemented = - - let unregistered = - [ ext | ext <- implemented -- extensions that ghc knows about - , not (registered ext) -- but that are not registered - , ext `notElem` exceptions ] -- except for the exceptions + let unregistered = + [ ext | ext <- implemented, not (registered ext), ext `notElem` exceptions -- extensions that ghc knows about + -- but that are not registered + -- except for the exceptions + ] -- check if someone has forgotten to update the exceptions list... -- exceptions that are not implemented - badExceptions = exceptions \\ implemented + badExceptions = exceptions \\ implemented -- exceptions that are now registered badExceptions' = filter registered exceptions - in catMaybes - [ check unregistered $ unlines - [ "The following extensions are known to GHC but are not in the " - , "extension registry in Language.Haskell.Extension." - , " " ++ intercalate "\n " (map display unregistered) - , "If these extensions are ready for public consumption then they " - , "should be registered. If they are still experimental and you " - , "think they are not ready to be registered then please add them " - , "to the exceptions list in this test program along with an " - , "explanation." - ] - , check badExceptions $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions but are not even implemented by GHC:" - , " " ++ intercalate "\n " (map display badExceptions) - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - , check badExceptions' $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions to registration but they are in fact" - , "now registered in Language.Haskell.Extension:" - , " " ++ intercalate "\n " (map display badExceptions') - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - ] + [ check unregistered $ + unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ + unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ + unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] where - registered (UnknownExtension _) = False - registered _ = True - - check [] _ = Nothing - check _ i = Just i + registered (UnknownExtension _) = False + registered _ = True + check [] _ = Nothing + check _ i = Just i main = topHandler $ do [ghcPath] <- getArgs - exts <- getExtensions ghcPath + exts <- getExtensions ghcPath let problems = checkProblems exts putStrLn (intercalate "\n" problems) if null problems @@ -81,17 +80,17 @@ main = topHandler $ do getExtensions :: FilePath -> IO [Extension] getExtensions ghcPath = - map readExtension . lines + map readExtension . lines <$> rawSystemStdout normal ghcPath ["--supported-languages"] readExtension :: String -> Extension readExtension str = handleNoParse $ do - -- GHC defines extensions in a positive way, Cabal defines them - -- relative to H98 so we try parsing ("No" ++ extName) first - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext where handleNoParse :: Maybe Extension -> Extension handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index 67966cb6f90..24fd4434bba 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + module Data.TreeDiff.Instances.Cabal () where import Data.TreeDiff @@ -11,26 +12,26 @@ import Data.TreeDiff.Instances.CabalVersion () ------------------------------------------------------------------------------- -import Distribution.Backpack (OpenModule, OpenUnitId) -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor) -import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.ModuleName (ModuleName) +import Distribution.Backpack (OpenModule, OpenUnitId) +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor) +import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) +import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription -import Distribution.Simple.Compiler (DebugInfoLevel, OptimisationLevel, ProfDetailLevel) -import Distribution.Simple.Flag (Flag) +import Distribution.Simple.Compiler (DebugInfoLevel, OptimisationLevel, ProfDetailLevel) +import Distribution.Simple.Flag (Flag) import Distribution.Simple.InstallDirs import Distribution.Simple.InstallDirs.Internal -import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) +import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) import Distribution.System -import Distribution.Types.AbiHash (AbiHash) -import Distribution.Types.ComponentId (ComponentId) -import Distribution.Types.DumpBuildInfo (DumpBuildInfo) +import Distribution.Types.AbiHash (AbiHash) +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.DumpBuildInfo (DumpBuildInfo) import Distribution.Types.PackageVersionConstraint -import Distribution.Types.UnitId (DefUnitId, UnitId) -import Distribution.Utils.NubList (NubList) -import Distribution.Utils.Path (SymbolicPath) -import Distribution.Utils.ShortText (ShortText, fromShortText) +import Distribution.Types.UnitId (DefUnitId, UnitId) +import Distribution.Utils.NubList (NubList) +import Distribution.Utils.Path (SymbolicPath) +import Distribution.Utils.ShortText (ShortText, fromShortText) import Distribution.Verbosity import Distribution.Verbosity.Internal @@ -43,17 +44,17 @@ import qualified Distribution.Compat.NonEmptySet as NES instance (Eq a, Show a) => ToExpr (Condition a) where toExpr = defaultExprViaShow instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondTree a b c) instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondBranch a b c) -instance (ToExpr a) => ToExpr (NubList a) -instance (ToExpr a) => ToExpr (Flag a) +instance ToExpr a => ToExpr (NubList a) +instance ToExpr a => ToExpr (Flag a) instance ToExpr a => ToExpr (NES.NonEmptySet a) where - toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs] + toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs] instance ToExpr a => ToExpr (PerCompilerFlavor a) instance ToExpr Dependency where - toExpr d@(Dependency pn vr cs) - | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []] - | otherwise = genericToExpr d + toExpr d@(Dependency pn vr cs) + | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []] + | otherwise = genericToExpr d instance ToExpr (SymbolicPath from to) diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs index 78f6a7e5aa8..df59b5b1323 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalLanguage.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + module Data.TreeDiff.Instances.CabalLanguage () where import Data.TreeDiff diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs index 2926129cb3d..147b570269f 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalSPDX.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + module Data.TreeDiff.Instances.CabalSPDX () where import Data.TreeDiff diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs index 3c2ac454dde..f3596743bce 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + module Data.TreeDiff.Instances.CabalVersion where import Data.TreeDiff diff --git a/Makefile b/Makefile index 91ade431fa7..1f9b15d3ed5 100644 --- a/Makefile +++ b/Makefile @@ -19,13 +19,18 @@ init: ## Set up git hooks and ignored revisions ## TODO style: ## Run the code styler - @find Cabal Cabal-syntax cabal-install -name '*.hs' \ - ! -path Cabal-syntax/src/Distribution/Fields/Lexer.hs \ - ! -path Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs \ - ! -path Cabal-syntax/src/Distribution/SPDX/LicenseId.hs \ - ! -path Cabal/src/Distribution/Simple/Build/Macros/Z.hs \ - ! -path Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs \ - | xargs -P $(PROCS) -I {} fourmolu -q -i {} + @find Cabal Cabal-syntax cabal-install Cabal-syntax \ + Cabal-QuickCheck Cabal-described \ + Cabal-tests Cabal-tree-diff cabal-benchmarks \ + cabal-dev-scripts cabal-install-solver \ + solver-benchmarks -name '*.hs' \ + ! -path Cabal-syntax/src/Distribution/Fields/Lexer.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseId.hs \ + ! -path Cabal/src/Distribution/Simple/Build/Macros/Z.hs \ + ! -path Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs \ + ! -path cabal-testsuite \ + | xargs -P $(PROCS) -I {} fourmolu -q -i {} # source generation: Lexer diff --git a/cabal-benchmarks/bench/CabalBenchmarks.hs b/cabal-benchmarks/bench/CabalBenchmarks.hs index 4d8bbddd0fd..de04e3138d5 100644 --- a/cabal-benchmarks/bench/CabalBenchmarks.hs +++ b/cabal-benchmarks/bench/CabalBenchmarks.hs @@ -1,31 +1,35 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} + module Main where -import Criterion.Main (bench, bgroup, defaultMain, env, nf, whnf) +import Criterion.Main (bench, bgroup, defaultMain, env, nf, whnf) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) -import Distribution.Parsec (eitherParsec) +import Distribution.Parsec (eitherParsec) import Distribution.Version import qualified Data.ByteString as BS +import qualified Distribution.Types.VersionInterval as New import qualified Distribution.Types.VersionInterval.Legacy as Old -import qualified Distribution.Types.VersionInterval as New ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- main :: IO () -main = defaultMain - [ bgroup "parseGPD" +main = + defaultMain + [ bgroup + "parseGPD" [ env (BS.readFile "Cabal/Cabal.cabal") $ \bs -> - bench "Cabal" $ whnf parseGenericPackageDescriptionMaybe bs + bench "Cabal" $ whnf parseGenericPackageDescriptionMaybe bs , env (BS.readFile "cabal-benchmarks/cabal-benchmarks.cabal") $ \bs -> - bench "cabal-benchmarks" $ whnf parseGenericPackageDescriptionMaybe bs + bench "cabal-benchmarks" $ whnf parseGenericPackageDescriptionMaybe bs ] - , bgroup "normaliseVersionRange" $ - let suite name f = bgroup name + let suite name f = + bgroup + name [ env bigVersionRange1 $ \vr -> bench "dnf1" $ nf f vr , env bigVersionRange2 $ \vr -> bench "dnf2" $ nf f vr , env bigVersionRange3 $ \vr -> bench "cnf1" $ nf f vr @@ -37,7 +41,7 @@ main = defaultMain , env bigVersionRange9 $ \vr -> bench "pat3" $ nf f vr , env bigVersionRangeA $ \vr -> bench "pat4" $ nf f vr ] - in [ suite "def" normaliseVersionRange + in [ suite "def" normaliseVersionRange , suite "old" oldNormaliseVersionRange , suite "new" newNormaliseVersionRange ] @@ -54,31 +58,44 @@ newNormaliseVersionRange :: VersionRange -> VersionRange newNormaliseVersionRange = New.normaliseVersionRange2 bigVersionRange1 :: IO VersionRange -bigVersionRange1 = either fail return $ eitherParsec - "(>=1.2.0 && <1.3) || (>=1.3.0 && <1.4) || (>=1.4.0.0 && <1.5) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" +bigVersionRange1 = + either fail return $ + eitherParsec + "(>=1.2.0 && <1.3) || (>=1.3.0 && <1.4) || (>=1.4.0.0 && <1.5) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" bigVersionRange2 :: IO VersionRange -bigVersionRange2 = either fail return $ eitherParsec - "(>=1.2.0 && <1.3) || (>=1.4.0.0 && <1.5) || (>=1.3.0 && <1.4) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" +bigVersionRange2 = + either fail return $ + eitherParsec + "(>=1.2.0 && <1.3) || (>=1.4.0.0 && <1.5) || (>=1.3.0 && <1.4) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)" bigVersionRange3 :: IO VersionRange -bigVersionRange3 = either fail return $ eitherParsec - ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || >=1.4.0.0) && (<1.5 || >=1.5.0.0) && (<1.6 || >=1.7.0.0) && <1.8" +bigVersionRange3 = + either fail return $ + eitherParsec + ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || >=1.4.0.0) && (<1.5 || >=1.5.0.0) && (<1.6 || >=1.7.0.0) && <1.8" bigVersionRange4 :: IO VersionRange -bigVersionRange4 = either fail return $ eitherParsec - ">=1.2.0 && <1.8 && (<1.4 || >=1.4.0.0) && (<1.3 || >=1.3.0) && (<1.5 || >=1.5.0.0) || (<1.6 && >=1.7.0.0)" +bigVersionRange4 = + either fail return $ + eitherParsec + ">=1.2.0 && <1.8 && (<1.4 || >=1.4.0.0) && (<1.3 || >=1.3.0) && (<1.5 || >=1.5.0.0) || (<1.6 && >=1.7.0.0)" bigVersionRange5 :: IO VersionRange -bigVersionRange5 = either fail return $ eitherParsec - ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || (>=1.4.0.0 && <1.5) || >=1.5.0.0) && (<1.6 || (>=1.7.0.0 && (<1.8 || >=1.9) && <1.10) || >=1.11) && <1.12" +bigVersionRange5 = + either fail return $ + eitherParsec + ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || (>=1.4.0.0 && <1.5) || >=1.5.0.0) && (<1.6 || (>=1.7.0.0 && (<1.8 || >=1.9) && <1.10) || >=1.11) && <1.12" bigVersionRange6 :: IO VersionRange bigVersionRange6 = fmap New.normaliseVersionRange2 bigVersionRange5 bigVersionRange7 :: IO VersionRange -bigVersionRange7 = return $ - i2 $ i2 $ u (b 0 1) (b 0 1) +bigVersionRange7 = + return $ + i2 $ + i2 $ + u (b 0 1) (b 0 1) where i2 x = i x x i = intersectVersionRanges @@ -87,8 +104,12 @@ bigVersionRange7 = return $ v x = mkVersion [x] bigVersionRange8 :: IO VersionRange -bigVersionRange8 = return $ - i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) +bigVersionRange8 = + return $ + i2 $ + i2 $ + i2 $ + u (b 0 1) (b 0 1) where i2 x = i x x i = intersectVersionRanges @@ -97,8 +118,13 @@ bigVersionRange8 = return $ v x = mkVersion [x] bigVersionRange9 :: IO VersionRange -bigVersionRange9 = return $ - i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) +bigVersionRange9 = + return $ + i2 $ + i2 $ + i2 $ + i2 $ + u (b 0 1) (b 0 1) where i2 x = i x x i = intersectVersionRanges @@ -107,8 +133,14 @@ bigVersionRange9 = return $ v x = mkVersion [x] bigVersionRangeA :: IO VersionRange -bigVersionRangeA = return $ - i2 $ i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1) +bigVersionRangeA = + return $ + i2 $ + i2 $ + i2 $ + i2 $ + i2 $ + u (b 0 1) (b 0 1) where i2 x = i x x i = intersectVersionRanges diff --git a/cabal-dev-scripts/Setup.hs b/cabal-dev-scripts/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-dev-scripts/Setup.hs +++ b/cabal-dev-scripts/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-dev-scripts/src/AnalyseImports.hs b/cabal-dev-scripts/src/AnalyseImports.hs index 5c96155527b..173585eb70b 100644 --- a/cabal-dev-scripts/src/AnalyseImports.hs +++ b/cabal-dev-scripts/src/AnalyseImports.hs @@ -1,62 +1,75 @@ {-# LANGUAGE LambdaCase #-} + module Main (main) where -import Control.Applicative (liftA2, many, (<|>)) -import Control.Monad (void) -import Data.Foldable (for_) -import Data.List (sortBy) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) +import Control.Applicative (liftA2, many, (<|>)) +import Control.Monad (void) +import Data.Foldable (for_) +import Data.List (sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) import Language.Haskell.Lexer (PosToken, Token (..), lexerPass0) -import System.Environment (getArgs) +import System.Environment (getArgs) import Text.Regex.Applicative (RE) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import qualified Text.Regex.Applicative as RE main :: IO () main = do - args <- getArgs - - data_ <- traverse processFile args - - putStrLn "Modules" - let modules = sortBy (flip $ comparing snd) $ Map.toList $ Map.fromListWith (+) - [ (mn, 1 :: Int) - | xs <- data_ - , (mn, _) <- xs - ] - - for_ (take 30 modules) $ \(mn, n) -> - putStrLn $ mn ++ " " ++ show n - - putStrLn "" - - putStrLn "Symbols" - let symbols = sortBy (flip $ comparing snd) $ Map.toList $ Map.fromListWith (+) - [ ((mn,sym), 1 :: Int) - | xs <- data_ - , (mn, syms) <- xs - , sym <- syms - ] - - for_ (take 50 symbols) $ \((mn,sym), n) -> - putStrLn $ mn ++ "." ++ sym ++ " " ++ show n + args <- getArgs + + data_ <- traverse processFile args + + putStrLn "Modules" + let modules = + sortBy (flip $ comparing snd) $ + Map.toList $ + Map.fromListWith + (+) + [ (mn, 1 :: Int) + | xs <- data_ + , (mn, _) <- xs + ] + + for_ (take 30 modules) $ \(mn, n) -> + putStrLn $ mn ++ " " ++ show n + + putStrLn "" + + putStrLn "Symbols" + let symbols = + sortBy (flip $ comparing snd) $ + Map.toList $ + Map.fromListWith + (+) + [ ((mn, sym), 1 :: Int) + | xs <- data_ + , (mn, syms) <- xs + , sym <- syms + ] + + for_ (take 50 symbols) $ \((mn, sym), n) -> + putStrLn $ mn ++ "." ++ sym ++ " " ++ show n processFile :: FilePath -> IO [(String, [String])] processFile fp = do - contents <- readFile fp - let tokens = filter (\(t, _) -> t `notElem` [Whitespace, Comment, Commentstart, NestedComment]) - $ lexerPass0 contents + contents <- readFile fp + let tokens = + filter (\(t, _) -> t `notElem` [Whitespace, Comment, Commentstart, NestedComment]) $ + lexerPass0 contents - return $ fromMaybe [] $ RE.match (somewhere imports) tokens + return $ fromMaybe [] $ RE.match (somewhere imports) tokens imports :: RE PosToken (String, [String]) -imports = (,) - <$ reservedid "import" <*> (conid <|> qconid) <*> msymbols +imports = + (,) + <$ reservedid "import" + <*> (conid <|> qconid) + <*> msymbols where msymbols :: RE PosToken [String] - msymbols =special "(" *> symbols <* special ")" <|> pure [] + msymbols = special "(" *> symbols <* special ")" <|> pure [] symbols :: RE PosToken [String] symbols = liftA2 (:) symbol $ many (special "," *> symbol) @@ -64,7 +77,6 @@ imports = (,) symbol :: RE PosToken String symbol = varid <|> special "(" *> varsym <* special ")" - ------------------------------------------------------------------------------- -- regex-applicative + haskell-lexer ------------------------------------------------------------------------------- @@ -77,30 +89,30 @@ somewhere re = anything *> RE.few (re <* anything) reservedid :: String -> RE PosToken () reservedid k = RE.msym $ \case - (Reservedid, (_, k')) | k == k' -> Just () - _ -> Nothing + (Reservedid, (_, k')) | k == k' -> Just () + _ -> Nothing special :: String -> RE PosToken () special k = RE.msym $ \case - (Special, (_, k')) | k == k' -> Just () - _ -> Nothing + (Special, (_, k')) | k == k' -> Just () + _ -> Nothing conid :: RE PosToken String conid = RE.msym $ \case - (Conid, (_, k)) -> Just k - _ -> Nothing + (Conid, (_, k)) -> Just k + _ -> Nothing qconid :: RE PosToken String qconid = RE.msym $ \case - (Qconid, (_, k)) -> Just k - _ -> Nothing + (Qconid, (_, k)) -> Just k + _ -> Nothing varid :: RE PosToken String varid = RE.msym $ \case - (Varid, (_, k)) -> Just k - _ -> Nothing + (Varid, (_, k)) -> Just k + _ -> Nothing varsym :: RE PosToken String varsym = RE.msym $ \case - (Varsym, (_, k)) -> Just k - _ -> Nothing + (Varsym, (_, k)) -> Just k + _ -> Nothing diff --git a/cabal-dev-scripts/src/Capture.hs b/cabal-dev-scripts/src/Capture.hs index 886fb035023..211f65db66f 100644 --- a/cabal-dev-scripts/src/Capture.hs +++ b/cabal-dev-scripts/src/Capture.hs @@ -1,31 +1,33 @@ module Capture (capture) where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (NameFlavour (..), Name (..)) import Control.Monad.IO.Class +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Name (..), NameFlavour (..)) import Data.Generics as SYB -- | Capture the source code of declarations in the variable capture - :: String -- ^ variable name - -> Q [Dec] -- ^ definitions - -> Q [Dec] + :: String + -- ^ variable name + -> Q [Dec] + -- ^ definitions + -> Q [Dec] capture name decls = do - decls1 <- decls + decls1 <- decls - -- mangle all names to drop unique suffixes and module prefixes - let decls2 = SYB.everywhere (SYB.mkT mangleName) decls1 - let declsStr = pprint decls2 - -- liftIO (putStrLn declsStr) + -- mangle all names to drop unique suffixes and module prefixes + let decls2 = SYB.everywhere (SYB.mkT mangleName) decls1 + let declsStr = pprint decls2 + -- liftIO (putStrLn declsStr) - let nameTyDecl :: Dec - nameTyDecl = SigD (mkName name) (ConT (mkName "String")) + let nameTyDecl :: Dec + nameTyDecl = SigD (mkName name) (ConT (mkName "String")) - nameDecl :: Dec - nameDecl = ValD (VarP $ mkName name) (NormalB (LitE (StringL declsStr))) [] + nameDecl :: Dec + nameDecl = ValD (VarP $ mkName name) (NormalB (LitE (StringL declsStr))) [] - return $ nameTyDecl : nameDecl : decls1 + return $ nameTyDecl : nameDecl : decls1 where mangleName :: Name -> Name mangleName (Name occ _) = Name occ NameS diff --git a/cabal-dev-scripts/src/GenCabalInstallCabal.hs b/cabal-dev-scripts/src/GenCabalInstallCabal.hs index 5c944e63723..26d36615959 100644 --- a/cabal-dev-scripts/src/GenCabalInstallCabal.hs +++ b/cabal-dev-scripts/src/GenCabalInstallCabal.hs @@ -1,49 +1,49 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} + module Main (main) where -import Control.Exception (SomeException (..), catch, displayException) -import GHC.Generics (Generic) +import Control.Exception (SomeException (..), catch, displayException) +import GHC.Generics (Generic) import System.Environment (getArgs) -import System.Exit (exitFailure) +import System.Exit (exitFailure) import qualified Zinza as Z withIO :: (Bool -> FilePath -> FilePath -> IO a) -> IO a withIO k = do - args <- getArgs - case args of - [dev',src,tgt] - | Just dev <- parseBool dev' - -> k dev src tgt `catch` \(SomeException e) -> do - putStrLn $ "Exception: " ++ displayException e - exitFailure - _ -> do - putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" + args <- getArgs + case args of + [dev', src, tgt] + | Just dev <- parseBool dev' -> + k dev src tgt `catch` \(SomeException e) -> do + putStrLn $ "Exception: " ++ displayException e exitFailure + _ -> do + putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" + exitFailure where - parseBool "True" = Just True + parseBool "True" = Just True parseBool "False" = Just False - parseBool _ = Nothing - + parseBool _ = Nothing main :: IO () main = withIO $ \dev src tgt -> do - render <- Z.parseAndCompileTemplateIO src - contents <- render $ Z dev () - writeFile tgt contents + render <- Z.parseAndCompileTemplateIO src + contents <- render $ Z dev () + writeFile tgt contents ------------------------------------------------------------------------------- -- Data ------------------------------------------------------------------------------- data Z = Z - { zDev :: Bool - , zUnused :: () - } + { zDev :: Bool + , zUnused :: () + } deriving (Generic) instance Z.Zinza Z where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP diff --git a/cabal-dev-scripts/src/GenCabalMacros.hs b/cabal-dev-scripts/src/GenCabalMacros.hs index d4679b8a426..fad222f50ec 100644 --- a/cabal-dev-scripts/src/GenCabalMacros.hs +++ b/cabal-dev-scripts/src/GenCabalMacros.hs @@ -1,19 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Main (main) where -import Control.Exception (SomeException (..), catch, displayException) +import Control.Exception (SomeException (..), catch, displayException) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) -import GHC.Generics (Generic) -import System.Environment (getArgs) -import System.Exit (exitFailure) +import Distribution.Types.Version (Version) +import GHC.Generics (Generic) +import System.Environment (getArgs) +import System.Exit (exitFailure) import Zinza - (ModuleConfig (..), Ty (..), Zinza (..), genericFromValueSFP, genericToTypeSFP, - genericToValueSFP, parseAndCompileModuleIO) + ( ModuleConfig (..) + , Ty (..) + , Zinza (..) + , genericFromValueSFP + , genericToTypeSFP + , genericToValueSFP + , parseAndCompileModuleIO + ) import Capture @@ -21,37 +28,40 @@ import Capture -- Inputs ------------------------------------------------------------------------------- -$(capture "decls" [d| - data Z = Z - { zPackages :: [ZPackage] - , zTools :: [ZTool] - , zPackageKey :: String - , zComponentId :: String - , zPackageVersion :: Version - , zNotNull :: String -> Bool - , zManglePkgName :: PackageName -> String - , zMangleStr :: String -> String +$( capture + "decls" + [d| + data Z = Z + { zPackages :: [ZPackage] + , zTools :: [ZTool] + , zPackageKey :: String + , zComponentId :: String + , zPackageVersion :: Version + , zNotNull :: String -> Bool + , zManglePkgName :: PackageName -> String + , zMangleStr :: String -> String } - deriving (Generic) + deriving (Generic) - data ZPackage = ZPackage - { zpkgName :: PackageName + data ZPackage = ZPackage + { zpkgName :: PackageName , zpkgVersion :: Version - , zpkgX :: String - , zpkgY :: String - , zpkgZ :: String + , zpkgX :: String + , zpkgY :: String + , zpkgZ :: String } - deriving (Generic) + deriving (Generic) - data ZTool = ZTool - { ztoolName :: String + data ZTool = ZTool + { ztoolName :: String , ztoolVersion :: Version - , ztoolX :: String - , ztoolY :: String - , ztoolZ :: String + , ztoolX :: String + , ztoolY :: String + , ztoolZ :: String } - deriving (Generic) - |]) + deriving (Generic) + |] + ) ------------------------------------------------------------------------------- -- Main @@ -59,22 +69,24 @@ $(capture "decls" [d| withIO :: (FilePath -> FilePath -> IO a) -> IO a withIO k = do - args <- getArgs - case args of - [src,tgt] -> k src tgt `catch` \(SomeException e) -> do - putStrLn $ "Exception: " ++ displayException e - exitFailure - _ -> do - putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" - exitFailure + args <- getArgs + case args of + [src, tgt] -> + k src tgt `catch` \(SomeException e) -> do + putStrLn $ "Exception: " ++ displayException e + exitFailure + _ -> do + putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" + exitFailure main :: IO () main = withIO $ \src tgt -> do - mdl <- parseAndCompileModuleIO config src - writeFile tgt mdl + mdl <- parseAndCompileModuleIO config src + writeFile tgt mdl config :: ModuleConfig Z -config = ModuleConfig +config = + ModuleConfig { mcRender = "render" , mcHeader = [ "{-# LANGUAGE DeriveGeneric #-}" @@ -90,30 +102,30 @@ config = ModuleConfig ------------------------------------------------------------------------------- instance Zinza Z where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP + toType = genericToTypeSFP + toValue = genericToValueSFP + fromValue = genericFromValueSFP instance Zinza ZPackage where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP + toType = genericToTypeSFP + toValue = genericToValueSFP + fromValue = genericFromValueSFP instance Zinza ZTool where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP + toType = genericToTypeSFP + toValue = genericToValueSFP + fromValue = genericFromValueSFP ------------------------------------------------------------------------------- -- Orphans ------------------------------------------------------------------------------- instance Zinza PackageName where - toType _ = TyString (Just "prettyShow") - toValue _ = error "not needed" - fromValue _ = error "not needed" + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" instance Zinza Version where - toType _ = TyString (Just "prettyShow") - toValue _ = error "not needed" - fromValue _ = error "not needed" + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" diff --git a/cabal-dev-scripts/src/GenPathsModule.hs b/cabal-dev-scripts/src/GenPathsModule.hs index e4b930635c4..7d3a8d9f416 100644 --- a/cabal-dev-scripts/src/GenPathsModule.hs +++ b/cabal-dev-scripts/src/GenPathsModule.hs @@ -1,19 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Main (main) where -import Control.Exception (SomeException (..), catch, displayException) +import Control.Exception (SomeException (..), catch, displayException) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) -import GHC.Generics (Generic) -import System.Environment (getArgs) -import System.Exit (exitFailure) +import Distribution.Types.Version (Version) +import GHC.Generics (Generic) +import System.Environment (getArgs) +import System.Exit (exitFailure) import Zinza - (ModuleConfig (..), Ty (..), Zinza (..), genericFromValueSFP, genericToTypeSFP, - genericToValueSFP, parseAndCompileModuleIO) + ( ModuleConfig (..) + , Ty (..) + , Zinza (..) + , genericFromValueSFP + , genericToTypeSFP + , genericToValueSFP + , parseAndCompileModuleIO + ) import Capture @@ -21,31 +28,32 @@ import Capture -- Inputs ------------------------------------------------------------------------------- -$(capture "decls" [d| - data Z = Z - { zPackageName :: PackageName - , zVersionDigits :: String - , zSupportsCpp :: Bool +$( capture + "decls" + [d| + data Z = Z + { zPackageName :: PackageName + , zVersionDigits :: String + , zSupportsCpp :: Bool , zSupportsNoRebindableSyntax :: Bool - , zAbsolute :: Bool - , zRelocatable :: Bool - , zIsWindows :: Bool - , zIsI386 :: Bool - , zIsX8664 :: Bool - - , zPrefix :: FilePath - , zBindir :: FilePath - , zLibdir :: FilePath - , zDynlibdir :: FilePath - , zDatadir :: FilePath + , zAbsolute :: Bool + , zRelocatable :: Bool + , zIsWindows :: Bool + , zIsI386 :: Bool + , zIsX8664 :: Bool + , zPrefix :: FilePath + , zBindir :: FilePath + , zLibdir :: FilePath + , zDynlibdir :: FilePath + , zDatadir :: FilePath , zLibexecdir :: FilePath , zSysconfdir :: FilePath - - , zNot :: Bool -> Bool - , zManglePkgName :: PackageName -> String + , zNot :: Bool -> Bool + , zManglePkgName :: PackageName -> String } - deriving (Generic) - |]) + deriving (Generic) + |] + ) ------------------------------------------------------------------------------- -- Main @@ -53,22 +61,24 @@ $(capture "decls" [d| withIO :: (FilePath -> FilePath -> IO a) -> IO a withIO k = do - args <- getArgs - case args of - [src,tgt] -> k src tgt `catch` \(SomeException e) -> do - putStrLn $ "Exception: " ++ displayException e - exitFailure - _ -> do - putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" - exitFailure + args <- getArgs + case args of + [src, tgt] -> + k src tgt `catch` \(SomeException e) -> do + putStrLn $ "Exception: " ++ displayException e + exitFailure + _ -> do + putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext" + exitFailure main :: IO () main = withIO $ \src tgt -> do - mdl <- parseAndCompileModuleIO config src - writeFile tgt mdl + mdl <- parseAndCompileModuleIO config src + writeFile tgt mdl config :: ModuleConfig Z -config = ModuleConfig +config = + ModuleConfig { mcRender = "render" , mcHeader = [ "{-# LANGUAGE DeriveGeneric #-}" @@ -84,20 +94,20 @@ config = ModuleConfig ------------------------------------------------------------------------------- instance Zinza Z where - toType = genericToTypeSFP - toValue = genericToValueSFP - fromValue = genericFromValueSFP + toType = genericToTypeSFP + toValue = genericToValueSFP + fromValue = genericFromValueSFP ------------------------------------------------------------------------------- -- Orphans ------------------------------------------------------------------------------- instance Zinza PackageName where - toType _ = TyString (Just "prettyShow") - toValue _ = error "not needed" - fromValue _ = error "not needed" + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" instance Zinza Version where - toType _ = TyString (Just "prettyShow") - toValue _ = error "not needed" - fromValue _ = error "not needed" + toType _ = TyString (Just "prettyShow") + toValue _ = error "not needed" + fromValue _ = error "not needed" diff --git a/cabal-dev-scripts/src/GenSPDX.hs b/cabal-dev-scripts/src/GenSPDX.hs index 288a0643a9c..7614ae54ebb 100644 --- a/cabal-dev-scripts/src/GenSPDX.hs +++ b/cabal-dev-scripts/src/GenSPDX.hs @@ -1,35 +1,40 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} + module Main (main) where -import Control.Lens (imap) -import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.!=), (.:), (.:?)) -import Data.List (sortOn) -import Data.Semigroup ((<>)) -import Data.Text (Text) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.!=), (.:), (.:?)) +import Data.List (sortOn) +import Data.Semigroup ((<>)) +import Data.Text (Text) import Data.Traversable (for) import qualified Data.ByteString.Lazy as LBS -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Options.Applicative as O -import qualified Zinza as Z +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Options.Applicative as O +import qualified Zinza as Z import GenUtils data Opts = Opts FilePath (PerV FilePath) FilePath main :: IO () -main = generate =<< O.execParser opts where - opts = O.info (O.helper <*> parser) $ mconcat - [ O.fullDesc - , O.progDesc "Generate SPDX LicenseId module" - ] +main = generate =<< O.execParser opts + where + opts = + O.info (O.helper <*> parser) $ + mconcat + [ O.fullDesc + , O.progDesc "Generate SPDX LicenseId module" + ] parser :: O.Parser Opts parser = Opts <$> template <*> licensesAll <*> output - licensesAll = PerV + licensesAll = + PerV <$> licenses "3.0" <*> licenses "3.2" <*> licenses "3.6" @@ -37,93 +42,105 @@ main = generate =<< O.execParser opts where <*> licenses "3.10" <*> licenses "3.16" - template = O.strArgument $ mconcat - [ O.metavar "SPDX.LicenseId.template.hs" - , O.help "Module template file" - ] - - licenses ver = O.strArgument $ mconcat - [ O.metavar $ "licenses-" ++ ver ++ ".json" - , O.help "Licenses JSON. https://github.com/spdx/license-list-data" - ] - - output = O.strArgument $ mconcat - [ O.metavar "Output.hs" - , O.help "Output file" - ] + template = + O.strArgument $ + mconcat + [ O.metavar "SPDX.LicenseId.template.hs" + , O.help "Module template file" + ] + + licenses ver = + O.strArgument $ + mconcat + [ O.metavar $ "licenses-" ++ ver ++ ".json" + , O.help "Licenses JSON. https://github.com/spdx/license-list-data" + ] + + output = + O.strArgument $ + mconcat + [ O.metavar "Output.hs" + , O.help "Output file" + ] generate :: Opts -> IO () generate (Opts tmplFile fns out) = do - lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn - template <- Z.parseAndCompileTemplateIO tmplFile - output <- generate' lss template - writeFile out (header <> "\n" <> output) - putStrLn $ "Generated file " ++ out + lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn + template <- Z.parseAndCompileTemplateIO tmplFile + output <- generate' lss template + writeFile out (header <> "\n" <> output) + putStrLn $ "Generated file " ++ out generate' - :: PerV LicenseList - -> (Input -> IO String) - -> IO String -generate' lss template = template $ Input - { inputLicenseIds = licenseIds - , inputLicenses = licenseValues - , inputLicenseList_all = mkLicenseList (== allVers) - , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList - (\vers -> vers /= allVers && Set.member ver vers) - } + :: PerV LicenseList + -> (Input -> IO String) + -> IO String +generate' lss template = + template $ + Input + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_perv = tabulate $ \ver -> + mkLicenseList + (\vers -> vers /= allVers && Set.member ver vers) + } where constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)] - constructorNames - = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) - $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss + constructorNames = + map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) $ + combine licenseId $ + \ver -> filterDeprecated $ unLL $ index ver lss filterDeprecated = filter (not . licenseDeprecated) licenseValues :: [InputLicense] - licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense - { ilConstructor = c - , ilId = textShow (licenseId l) - , ilName = textShow (licenseName l) + licenseValues = flip map constructorNames $ \(c, l, _) -> + InputLicense + { ilConstructor = c + , ilId = textShow (licenseId l) + , ilName = textShow (licenseName l) , ilIsOsiApproved = licenseOsiApproved l - , ilIsFsfLibre = licenseFsfLibre l + , ilIsFsfLibre = licenseFsfLibre l } licenseIds :: Text licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) -> - let pfx = if i == 0 then " = " else " | " - versInfo - | vers == allVers = "" - | otherwise = foldMap (\v -> ", " <> prettyVer v) vers - in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo + let pfx = if i == 0 then " = " else " | " + versInfo + | vers == allVers = "" + | otherwise = foldMap (\v -> ", " <> prettyVer v) vers + in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo mkLicenseList :: (Set.Set SPDXLicenseListVersion -> Bool) -> Text - mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ] + mkLicenseList p = mkList [n | (n, _, vers) <- constructorNames, p vers] ------------------------------------------------------------------------------- -- JSON inputs ------------------------------------------------------------------------------- data License = License - { licenseId :: !Text - , licenseName :: !Text - , licenseOsiApproved :: !Bool - , licenseFsfLibre :: !Bool - , licenseDeprecated :: !Bool - } + { licenseId :: !Text + , licenseName :: !Text + , licenseOsiApproved :: !Bool + , licenseFsfLibre :: !Bool + , licenseDeprecated :: !Bool + } deriving (Show) -newtype LicenseList = LL { unLL :: [License] } +newtype LicenseList = LL {unLL :: [License]} deriving (Show) instance FromJSON License where - parseJSON = withObject "License" $ \obj -> License - <$> obj .: "licenseId" - <*> obj .: "name" - <*> obj .: "isOsiApproved" - <*> obj .:? "isFsfLibre" .!= False - <*> obj .: "isDeprecatedLicenseId" + parseJSON = withObject "License" $ \obj -> + License + <$> obj .: "licenseId" + <*> obj .: "name" + <*> obj .: "isOsiApproved" + <*> obj .:? "isFsfLibre" .!= False + <*> obj .: "isDeprecatedLicenseId" instance FromJSON LicenseList where - parseJSON = withObject "License list" $ \obj -> - LL . sortOn (OrdT . T.toLower . licenseId) - <$> obj .: "licenses" + parseJSON = withObject "License list" $ \obj -> + LL . sortOn (OrdT . T.toLower . licenseId) + <$> obj .: "licenses" diff --git a/cabal-dev-scripts/src/GenSPDXExc.hs b/cabal-dev-scripts/src/GenSPDXExc.hs index c0fa0f3861d..cd54defa180 100644 --- a/cabal-dev-scripts/src/GenSPDXExc.hs +++ b/cabal-dev-scripts/src/GenSPDXExc.hs @@ -1,34 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} + module Main (main) where -import Control.Lens (imap) -import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) -import Data.List (sortOn) -import Data.Semigroup ((<>)) -import Data.Text (Text) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) +import Data.List (sortOn) +import Data.Semigroup ((<>)) +import Data.Text (Text) import Data.Traversable (for) import qualified Data.ByteString.Lazy as LBS -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Options.Applicative as O -import qualified Zinza as Z +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Options.Applicative as O +import qualified Zinza as Z import GenUtils data Opts = Opts FilePath (PerV FilePath) FilePath main :: IO () -main = generate =<< O.execParser opts where - opts = O.info (O.helper <*> parser) $ mconcat - [ O.fullDesc - , O.progDesc "Generate SPDX LicenseExceptionId module" - ] +main = generate =<< O.execParser opts + where + opts = + O.info (O.helper <*> parser) $ + mconcat + [ O.fullDesc + , O.progDesc "Generate SPDX LicenseExceptionId module" + ] parser :: O.Parser Opts parser = Opts <$> template <*> licensesAll <*> output - licensesAll = PerV + licensesAll = + PerV <$> licenses "3.0" <*> licenses "3.2" <*> licenses "3.6" @@ -36,92 +41,104 @@ main = generate =<< O.execParser opts where <*> licenses "3.10" <*> licenses "3.16" - template = O.strArgument $ mconcat - [ O.metavar "SPDX.LicenseExceptionId.template.hs" - , O.help "Module template file" - ] - - licenses ver = O.strArgument $ mconcat - [ O.metavar $ "exceptions" ++ ver ++ ".json" - , O.help "Exceptions JSON. https://github.com/spdx/license-list-data" - ] - - output = O.strArgument $ mconcat - [ O.metavar "Output.hs" - , O.help "Output file" - ] + template = + O.strArgument $ + mconcat + [ O.metavar "SPDX.LicenseExceptionId.template.hs" + , O.help "Module template file" + ] + + licenses ver = + O.strArgument $ + mconcat + [ O.metavar $ "exceptions" ++ ver ++ ".json" + , O.help "Exceptions JSON. https://github.com/spdx/license-list-data" + ] + + output = + O.strArgument $ + mconcat + [ O.metavar "Output.hs" + , O.help "Output file" + ] generate :: Opts -> IO () generate (Opts tmplFile fns out) = do - lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn - template <- Z.parseAndCompileTemplateIO tmplFile - output <- generate' lss template - writeFile out (header <> "\n" <> output) - putStrLn $ "Generated file " ++ out + lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn + template <- Z.parseAndCompileTemplateIO tmplFile + output <- generate' lss template + writeFile out (header <> "\n" <> output) + putStrLn $ "Generated file " ++ out generate' - :: PerV LicenseList - -> (Input -> IO String) - -> IO String -generate' lss template = template $ Input - { inputLicenseIds = licenseIds - , inputLicenses = licenseValues - , inputLicenseList_all = mkLicenseList (== allVers) - , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList - (\vers -> vers /= allVers && Set.member ver vers) - } + :: PerV LicenseList + -> (Input -> IO String) + -> IO String +generate' lss template = + template $ + Input + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_perv = tabulate $ \ver -> + mkLicenseList + (\vers -> vers /= allVers && Set.member ver vers) + } where constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)] - constructorNames - = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) - $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss + constructorNames = + map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags)) $ + combine licenseId $ + \ver -> filterDeprecated $ unLL $ index ver lss filterDeprecated = filter (not . licenseDeprecated) licenseValues :: [InputLicense] - licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense - { ilConstructor = c - , ilId = textShow (licenseId l) - , ilName = textShow (licenseName l) + licenseValues = flip map constructorNames $ \(c, l, _) -> + InputLicense + { ilConstructor = c + , ilId = textShow (licenseId l) + , ilName = textShow (licenseName l) , ilIsOsiApproved = False -- not used in exceptions - , ilIsFsfLibre = False -- not used in exceptions + , ilIsFsfLibre = False -- not used in exceptions } licenseIds :: Text licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) -> - let pfx = if i == 0 then " = " else " | " - versInfo - | vers == allVers = "" - | otherwise = foldMap (\v -> ", " <> prettyVer v) vers - in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo + let pfx = if i == 0 then " = " else " | " + versInfo + | vers == allVers = "" + | otherwise = foldMap (\v -> ", " <> prettyVer v) vers + in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo mkLicenseList :: (Set.Set SPDXLicenseListVersion -> Bool) -> Text - mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ] + mkLicenseList p = mkList [n | (n, _, vers) <- constructorNames, p vers] ------------------------------------------------------------------------------- -- JSON inputs ------------------------------------------------------------------------------- data License = License - { licenseId :: !Text - , licenseName :: !Text - , licenseDeprecated :: !Bool - } + { licenseId :: !Text + , licenseName :: !Text + , licenseDeprecated :: !Bool + } deriving (Show) instance FromJSON License where - parseJSON = withObject "License" $ \obj -> License - <$> obj .: "licenseExceptionId" - <*> fmap (T.map fixSpace) (obj .: "name") - <*> obj .: "isDeprecatedLicenseId" - where - fixSpace '\n' = ' ' - fixSpace c = c - -newtype LicenseList = LL { unLL :: [License] } + parseJSON = withObject "License" $ \obj -> + License + <$> obj .: "licenseExceptionId" + <*> fmap (T.map fixSpace) (obj .: "name") + <*> obj .: "isDeprecatedLicenseId" + where + fixSpace '\n' = ' ' + fixSpace c = c + +newtype LicenseList = LL {unLL :: [License]} deriving (Show) instance FromJSON LicenseList where - parseJSON = withObject "Exceptions list" $ \obj -> - LL . sortOn (OrdT . T.toLower . licenseId) - <$> obj .: "exceptions" + parseJSON = withObject "Exceptions list" $ \obj -> + LL . sortOn (OrdT . T.toLower . licenseId) + <$> obj .: "exceptions" diff --git a/cabal-dev-scripts/src/GenUtils.hs b/cabal-dev-scripts/src/GenUtils.hs index 41834ef517a..78c6f4a0351 100644 --- a/cabal-dev-scripts/src/GenUtils.hs +++ b/cabal-dev-scripts/src/GenUtils.hs @@ -1,24 +1,25 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module GenUtils where import Control.Lens (each, ix, (%~), (&)) -import Data.Char (toUpper) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) +import Data.Char (toUpper) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) import GHC.Generics (Generic) import qualified Data.Algorithm.Diff as Diff -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Zinza as Z +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Zinza as Z ------------------------------------------------------------------------------- -- License List version @@ -26,32 +27,32 @@ import qualified Zinza as Z -- | SPDX license list version data SPDXLicenseListVersion - = SPDXLicenseListVersion_3_0 - | SPDXLicenseListVersion_3_2 - | SPDXLicenseListVersion_3_6 - | SPDXLicenseListVersion_3_9 - | SPDXLicenseListVersion_3_10 - | SPDXLicenseListVersion_3_16 + = SPDXLicenseListVersion_3_0 + | SPDXLicenseListVersion_3_2 + | SPDXLicenseListVersion_3_6 + | SPDXLicenseListVersion_3_9 + | SPDXLicenseListVersion_3_10 + | SPDXLicenseListVersion_3_16 deriving (Eq, Ord, Show, Enum, Bounded) allVers :: Set.Set SPDXLicenseListVersion -allVers = Set.fromList [minBound .. maxBound] +allVers = Set.fromList [minBound .. maxBound] prettyVer :: SPDXLicenseListVersion -> Text prettyVer SPDXLicenseListVersion_3_16 = "SPDX License List 3.16" prettyVer SPDXLicenseListVersion_3_10 = "SPDX License List 3.10" -prettyVer SPDXLicenseListVersion_3_9 = "SPDX License List 3.9" -prettyVer SPDXLicenseListVersion_3_6 = "SPDX License List 3.6" -prettyVer SPDXLicenseListVersion_3_2 = "SPDX License List 3.2" -prettyVer SPDXLicenseListVersion_3_0 = "SPDX License List 3.0" +prettyVer SPDXLicenseListVersion_3_9 = "SPDX License List 3.9" +prettyVer SPDXLicenseListVersion_3_6 = "SPDX License List 3.6" +prettyVer SPDXLicenseListVersion_3_2 = "SPDX License List 3.2" +prettyVer SPDXLicenseListVersion_3_0 = "SPDX License List 3.0" suffixVer :: SPDXLicenseListVersion -> String suffixVer SPDXLicenseListVersion_3_16 = "_3_16" suffixVer SPDXLicenseListVersion_3_10 = "_3_10" -suffixVer SPDXLicenseListVersion_3_9 = "_3_9" -suffixVer SPDXLicenseListVersion_3_6 = "_3_6" -suffixVer SPDXLicenseListVersion_3_2 = "_3_2" -suffixVer SPDXLicenseListVersion_3_0 = "_3_0" +suffixVer SPDXLicenseListVersion_3_9 = "_3_9" +suffixVer SPDXLicenseListVersion_3_6 = "_3_6" +suffixVer SPDXLicenseListVersion_3_2 = "_3_2" +suffixVer SPDXLicenseListVersion_3_0 = "_3_0" ------------------------------------------------------------------------------- -- Per version @@ -61,24 +62,25 @@ data PerV a = PerV a a a a a a deriving (Show, Functor, Foldable, Traversable) class Functor f => Representable i f | f -> i where - index :: i -> f a -> a - tabulate :: (i -> a) -> f a + index :: i -> f a -> a + tabulate :: (i -> a) -> f a instance Representable SPDXLicenseListVersion PerV where - index SPDXLicenseListVersion_3_0 (PerV x _ _ _ _ _) = x - index SPDXLicenseListVersion_3_2 (PerV _ x _ _ _ _) = x - index SPDXLicenseListVersion_3_6 (PerV _ _ x _ _ _) = x - index SPDXLicenseListVersion_3_9 (PerV _ _ _ x _ _) = x - index SPDXLicenseListVersion_3_10 (PerV _ _ _ _ x _) = x - index SPDXLicenseListVersion_3_16 (PerV _ _ _ _ _ x) = x - - tabulate f = PerV - (f SPDXLicenseListVersion_3_0) - (f SPDXLicenseListVersion_3_2) - (f SPDXLicenseListVersion_3_6) - (f SPDXLicenseListVersion_3_9) - (f SPDXLicenseListVersion_3_10) - (f SPDXLicenseListVersion_3_16) + index SPDXLicenseListVersion_3_0 (PerV x _ _ _ _ _) = x + index SPDXLicenseListVersion_3_2 (PerV _ x _ _ _ _) = x + index SPDXLicenseListVersion_3_6 (PerV _ _ x _ _ _) = x + index SPDXLicenseListVersion_3_9 (PerV _ _ _ x _ _) = x + index SPDXLicenseListVersion_3_10 (PerV _ _ _ _ x _) = x + index SPDXLicenseListVersion_3_16 (PerV _ _ _ _ _ x) = x + + tabulate f = + PerV + (f SPDXLicenseListVersion_3_0) + (f SPDXLicenseListVersion_3_2) + (f SPDXLicenseListVersion_3_6) + (f SPDXLicenseListVersion_3_9) + (f SPDXLicenseListVersion_3_10) + (f SPDXLicenseListVersion_3_16) ------------------------------------------------------------------------------- -- Sorting @@ -87,11 +89,11 @@ instance Representable SPDXLicenseListVersion PerV where newtype OrdT = OrdT Text deriving (Eq) instance Ord OrdT where - compare (OrdT a) (OrdT b) - | a == b = EQ - | a `T.isPrefixOf` b = GT - | b `T.isPrefixOf` a = LT - | otherwise = compare a b + compare (OrdT a) (OrdT b) + | a == b = EQ + | a `T.isPrefixOf` b = GT + | b `T.isPrefixOf` a = LT + | otherwise = compare a b ------------------------------------------------------------------------------- -- Commons @@ -105,19 +107,19 @@ header = "-- This file is generated. See Makefile's spdx rule" ------------------------------------------------------------------------------- combine - :: forall a b tag. (Ord b, Ord tag, Enum tag, Bounded tag) - => (a -> b) - -> (tag -> [a]) - -> [(a, Set.Set tag)] -combine f t - = map addTags - $ foldr process [] [ minBound .. maxBound ] + :: forall a b tag + . (Ord b, Ord tag, Enum tag, Bounded tag) + => (a -> b) + -> (tag -> [a]) + -> [(a, Set.Set tag)] +combine f t = + map addTags $ + foldr process [] [minBound .. maxBound] where unDiff :: Diff.Diff a -> a - unDiff (Diff.First a) = a + unDiff (Diff.First a) = a unDiff (Diff.Second a) = a unDiff (Diff.Both _ a) = a -- important we prefer latter versions! - addTags :: a -> (a, Set.Set tag) addTags a = (a, fromMaybe Set.empty (Map.lookup (f a) tags)) @@ -125,18 +127,21 @@ combine f t process tag as = map unDiff $ Diff.getDiffBy (\x y -> f x == f y) (t tag) as tags :: Map.Map b (Set.Set tag) - tags = Map.fromListWith Set.union + tags = + Map.fromListWith + Set.union [ (f a, Set.singleton tag) - | tag <- [ minBound .. maxBound ] + | tag <- [minBound .. maxBound] , a <- t tag ] ordNubOn :: Ord b => (a -> b) -> [a] -> [a] -ordNubOn f = go Set.empty where - go _ [] = [] - go past (a:as) - | b `Set.member` past = go past as - | otherwise = a : go (Set.insert b past) as +ordNubOn f = go Set.empty + where + go _ [] = [] + go past (a : as) + | b `Set.member` past = go past as + | otherwise = a : go (Set.insert b past) as where b = f a @@ -144,7 +149,8 @@ textShow :: Text -> Text textShow = T.pack . show toConstructorName :: Text -> Text -toConstructorName t = t +toConstructorName t = + t & each %~ f & ix 0 %~ toUpper & special @@ -152,17 +158,19 @@ toConstructorName t = t f '.' = '_' f '-' = '_' f '+' = '\'' - f c = c + f c = c special :: Text -> Text - special "0BSD" = "NullBSD" + special "0BSD" = "NullBSD" special "389_exception" = "DS389_exception" - special u = u + special u = u mkList :: [Text] -> Text -mkList [] = " []" -mkList (x:xs) = - " [ " <> x <> "\n" +mkList [] = " []" +mkList (x : xs) = + " [ " + <> x + <> "\n" <> foldMap (\x' -> " , " <> x' <> "\n") xs <> " ]" @@ -171,41 +179,45 @@ mkList (x:xs) = ------------------------------------------------------------------------------- data Input = Input - { inputLicenseIds :: Text - , inputLicenses :: [InputLicense] - , inputLicenseList_all :: Text - , inputLicenseList_perv :: PerV Text - } + { inputLicenseIds :: Text + , inputLicenses :: [InputLicense] + , inputLicenseList_all :: Text + , inputLicenseList_perv :: PerV Text + } deriving (Show, Generic) instance Z.Zinza Input where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP data InputLicense = InputLicense - { ilConstructor :: Text - , ilId :: Text - , ilName :: Text - , ilIsOsiApproved :: Bool - , ilIsFsfLibre :: Bool - } + { ilConstructor :: Text + , ilId :: Text + , ilName :: Text + , ilIsOsiApproved :: Bool + , ilIsFsfLibre :: Bool + } deriving (Show, Generic) instance Z.Zinza InputLicense where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP instance Z.Zinza a => Z.Zinza (PerV a) where - toType _ = Z.TyRecord $ Map.fromList + toType _ = + Z.TyRecord $ + Map.fromList [ ("v" ++ suffixVer v, ("index " ++ show v, Z.toType (Proxy :: Proxy a))) - | v <- [ minBound .. maxBound ] + | v <- [minBound .. maxBound] ] - toValue x = Z.VRecord $ Map.fromList + toValue x = + Z.VRecord $ + Map.fromList [ ("v" ++ suffixVer v, Z.toValue (index v x)) - | v <- [ minBound .. maxBound ] + | v <- [minBound .. maxBound] ] - fromValue = error "fromExpr @PerV not implemented" + fromValue = error "fromExpr @PerV not implemented" diff --git a/cabal-dev-scripts/src/GenValidateDockerfile.hs b/cabal-dev-scripts/src/GenValidateDockerfile.hs index 10041b7cc5c..9a5fbdf93b0 100644 --- a/cabal-dev-scripts/src/GenValidateDockerfile.hs +++ b/cabal-dev-scripts/src/GenValidateDockerfile.hs @@ -1,50 +1,51 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} + module Main (main) where -import Control.Exception (SomeException (..), catch, displayException) -import GHC.Generics (Generic) +import Control.Exception (SomeException (..), catch, displayException) +import GHC.Generics (Generic) import System.Environment (getArgs) -import System.Exit (exitFailure) +import System.Exit (exitFailure) import qualified Data.Map as Map import qualified Zinza as Z withIO :: (String -> FilePath -> FilePath -> IO a) -> IO a withIO k = do - args <- getArgs - case args of - [version,src,tgt] - -> k version src tgt `catch` \(SomeException e) -> do - putStrLn $ "Exception: " ++ displayException e - exitFailure - _ -> do - putStrLn "Usage cabal v2-run ... version" - exitFailure + args <- getArgs + case args of + [version, src, tgt] -> + k version src tgt `catch` \(SomeException e) -> do + putStrLn $ "Exception: " ++ displayException e + exitFailure + _ -> do + putStrLn "Usage cabal v2-run ... version" + exitFailure main :: IO () main = withIO $ \version src tgt -> do - render <- Z.parseAndCompileTemplateIO src - case Map.lookup version params of - Just z -> do - contents <- render z - writeFile tgt contents - - Nothing -> do - putStrLn $ "Unknown version " ++ version - exitFailure + render <- Z.parseAndCompileTemplateIO src + case Map.lookup version params of + Just z -> do + contents <- render z + writeFile tgt contents + Nothing -> do + putStrLn $ "Unknown version " ++ version + exitFailure ------------------------------------------------------------------------------- -- Params ------------------------------------------------------------------------------- params :: Map.Map String Z -params = Map.fromList - [ pair "8.10.4" $ Z "ghc-8.10.4" "8.10.4-bionic" False True False True "" - , pair "8.8.4" $ Z "ghc-8.8.4" "8.8.4-bionic" False True False True "--doctest --solver-benchmarks --complete-hackage" - , pair "8.6.5" $ Z "ghc-8.6.5" "8.6.5-bionic" False True False True "" - , pair "8.4.4" $ Z "ghc-8.4.4" "8.4.4-bionic" False True False True "" - , pair "8.2.2" $ Z "ghc-8.2.2" "8.2.2-bionic" True True False True "" +params = + Map.fromList + [ pair "8.10.4" $ Z "ghc-8.10.4" "8.10.4-bionic" False True False True "" + , pair "8.8.4" $ Z "ghc-8.8.4" "8.8.4-bionic" False True False True "--doctest --solver-benchmarks --complete-hackage" + , pair "8.6.5" $ Z "ghc-8.6.5" "8.6.5-bionic" False True False True "" + , pair "8.4.4" $ Z "ghc-8.4.4" "8.4.4-bionic" False True False True "" + , pair "8.2.2" $ Z "ghc-8.2.2" "8.2.2-bionic" True True False True "" ] where pair = (,) @@ -54,17 +55,17 @@ params = Map.fromList ------------------------------------------------------------------------------- data Z = Z - { zGhc :: String - , zImage :: String - , zParsecCompat :: Bool - , zHasTransformers :: Bool - , zNeedsDynamic :: Bool - , zClient :: Bool - , zArgs :: String - } + { zGhc :: String + , zImage :: String + , zParsecCompat :: Bool + , zHasTransformers :: Bool + , zNeedsDynamic :: Bool + , zClient :: Bool + , zArgs :: String + } deriving (Generic) instance Z.Zinza Z where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP diff --git a/cabal-install-solver/Setup.hs b/cabal-install-solver/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/cabal-install-solver/Setup.hs +++ b/cabal-install-solver/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs b/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs index 05dc0e8fe54..00df90c4e66 100644 --- a/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs +++ b/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module Distribution.Client.Utils.Assertion (expensiveAssert) where +module Distribution.Client.Utils.Assertion (expensiveAssert) where #ifdef DEBUG_EXPENSIVE_ASSERTIONS import Prelude (Bool) diff --git a/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs b/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs index abcae0c7242..a4bb6948325 100644 --- a/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs +++ b/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs @@ -9,11 +9,10 @@ -- -- This module is a superset of "Distribution.Compat.Prelude" (which -- this module re-exports) --- module Distribution.Solver.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , Prelude.IO ) where -import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) +import Prelude (IO) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 2aac240318f..c11dea1a8fb 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -1,8 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where +module Distribution.Solver.Modular (modularResolver, SolverConfig (..), PruneAfterFirstSuccess (..)) where -- Here, we try to map between the external cabal-install solver -- interface and the internal interface that the solver actually @@ -12,73 +11,89 @@ module Distribution.Solver.Modular -- and finally, we have to convert back the resulting install -- plan. -import Prelude () import Distribution.Solver.Compat.Prelude +import Prelude () import qualified Data.Map as M import Data.Set (isSubsetOf) import Distribution.Compat.Graph - ( IsNode(..) ) + ( IsNode (..) + ) import Distribution.Compiler - ( CompilerInfo ) + ( CompilerInfo + ) +import Distribution.Simple.Setup + ( BooleanFlag (..) + ) +import Distribution.Simple.Utils + ( ordNubBy + ) import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) + ( Assignment + , toCPs + ) import Distribution.Solver.Modular.ConfiguredConversion - ( convCP ) + ( convCP + ) import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.IndexConversion - ( convPIs ) + ( convPIs + ) import Distribution.Solver.Modular.Log - ( SolverFailure(..), displayLogMessages ) + ( SolverFailure (..) + , displayLogMessages + ) import Distribution.Solver.Modular.Package - ( PN ) + ( PN + ) import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Solver - ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) + ( PruneAfterFirstSuccess (..) + , SolverConfig (..) + , solve + ) import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb ) + ( PkgConfigDb + ) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.Variable import Distribution.System - ( Platform(..) ) -import Distribution.Simple.Setup - ( BooleanFlag(..) ) -import Distribution.Simple.Utils - ( ordNubBy ) + ( Platform (..) + ) import Distribution.Verbosity - -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - uncurry postprocess <$> -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns - where - -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx - -- Constraints have to be converted into a finite map indexed by PN. - gcs = M.fromListWith (++) (map pair pcs) - where - pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) + uncurry postprocess + <$> solve' sc cinfo idx pkgConfigDB pprefs gcs pns -- convert install plan + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map pair pcs) + where + pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) - -- Results have to be converted into an install plan. 'convCP' removes - -- package qualifiers, which means that linked packages become duplicates - -- and can be removed. - postprocess a rdm = ordNubBy nodeKey $ - map (convCP iidx sidx) (toCPs a rdm) + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + postprocess a rdm = + ordNubBy nodeKey $ + map (convCP iidx sidx) (toCPs a rdm) - -- Helper function to extract the PN from a constraint. - pcName :: PackageConstraint -> PN - pcName (PackageConstraint scope _) = scopeToPackageName scope + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraint scope _) = scopeToPackageName scope -- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display -- in the error case. @@ -113,75 +128,90 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- Using the full log from a rerun of the solver ensures that the log is -- complete, i.e., it shows the whole chain of dependencies from the user -- targets to the conflicting packages. -solve' :: SolverConfig - -> CompilerInfo - -> Index - -> PkgConfigDb - -> (PN -> PackagePreferences) - -> Map PN [LabeledPackageConstraint] - -> Set PN - -> Progress String String (Assignment, RevDepMap) +solve' + :: SolverConfig + -> CompilerInfo + -> Index + -> PkgConfigDb + -> (PN -> PackagePreferences) + -> Map PN [LabeledPackageConstraint] + -> Set PN + -> Progress String String (Assignment, RevDepMap) solve' sc cinfo idx pkgConfigDB pprefs gcs pns = - toProgress $ retry (runSolver printFullLog sc) createErrorMsg + toProgress $ retry (runSolver printFullLog sc) createErrorMsg where - runSolver :: Bool -> SolverConfig - -> RetryLog String SolverFailure (Assignment, RevDepMap) + runSolver + :: Bool + -> SolverConfig + -> RetryLog String SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = - displayLogMessages keepLog $ + displayLogMessages keepLog $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns - createErrorMsg :: SolverFailure - -> RetryLog String String (Assignment, RevDepMap) + createErrorMsg + :: SolverFailure + -> RetryLog String String (Assignment, RevDepMap) createErrorMsg failure@(ExhaustiveSearch cs cm) = if asBool $ minimizeConflictSet sc - then continueWith ("Found no solution after exhaustively searching the " - ++ "dependency tree. Rerunning the dependency solver " - ++ "to minimize the conflict set ({" - ++ showConflictSet cs ++ "}).") $ - retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ - \case - ExhaustiveSearch cs' cm' -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs' - ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') - BackjumpLimitReached -> - fromProgress $ Fail $ - "Reached backjump limit while trying to minimize the " - ++ "conflict set to create a better error message. " - ++ "Original error message:\n" - ++ rerunSolverForErrorMsg cs - ++ finalErrorMsg sc failure - else fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - createErrorMsg failure@BackjumpLimitReached = - continueWith - ("Backjump limit reached. Rerunning dependency solver to generate " - ++ "a final conflict set for the search tree containing the " - ++ "first backjump.") $ - retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ - \case - ExhaustiveSearch cs _ -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - BackjumpLimitReached -> - -- This case is possible when the number of goals involved in - -- conflicts is greater than the backjump limit. - fromProgress $ Fail $ finalErrorMsg sc failure - ++ "Failed to generate a summarized dependency solver " - ++ "log due to low backjump limit." + then continueWith + ( "Found no solution after exhaustively searching the " + ++ "dependency tree. Rerunning the dependency solver " + ++ "to minimize the conflict set ({" + ++ showConflictSet cs + ++ "})." + ) + $ retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) + $ \case + ExhaustiveSearch cs' cm' -> + fromProgress $ + Fail $ + rerunSolverForErrorMsg cs' + ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') + BackjumpLimitReached -> + fromProgress $ + Fail $ + "Reached backjump limit while trying to minimize the " + ++ "conflict set to create a better error message. " + ++ "Original error message:\n" + ++ rerunSolverForErrorMsg cs + ++ finalErrorMsg sc failure + else + fromProgress $ + Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + createErrorMsg failure@BackjumpLimitReached = + continueWith + ( "Backjump limit reached. Rerunning dependency solver to generate " + ++ "a final conflict set for the search tree containing the " + ++ "first backjump." + ) + $ retry (runSolver printFullLog sc{pruneAfterFirstSuccess = PruneAfterFirstSuccess True}) + $ \case + ExhaustiveSearch cs _ -> + fromProgress $ + Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + BackjumpLimitReached -> + -- This case is possible when the number of goals involved in + -- conflicts is greater than the backjump limit. + fromProgress $ + Fail $ + finalErrorMsg sc failure + ++ "Failed to generate a summarized dependency solver " + ++ "log due to low backjump limit." rerunSolverForErrorMsg :: ConflictSet -> String rerunSolverForErrorMsg cs = - let sc' = sc { - goalOrder = Just goalOrder' - , maxBackjumps = Just 0 - } + let sc' = + sc + { goalOrder = Just goalOrder' + , maxBackjumps = Just 0 + } -- Preferring goals from the conflict set takes precedence over the -- original goal order. goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) - - in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) + in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) printFullLog = solverVerbosity sc >= verbose @@ -219,15 +249,18 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns = -- solver to add new unnecessary variables to the conflict set. This function -- discards the result from any run that adds new variables to the conflict -- set, but the end result may not be completely minimized. -tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) - -> SolverConfig - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a +tryToMinimizeConflictSet + :: forall a + . (SolverConfig -> RetryLog String SolverFailure a) + -> SolverConfig + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a tryToMinimizeConflictSet runSolver sc cs cm = - foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) - (fromProgress $ Fail $ ExhaustiveSearch cs cm) - (CS.toList cs) + foldl + (\r v -> retryNoSolution r $ tryToRemoveOneVar v) + (fromProgress $ Fail $ ExhaustiveSearch cs cm) + (CS.toList cs) where -- This function runs the solver and makes it prefer goals in the following -- order: @@ -246,61 +279,82 @@ tryToMinimizeConflictSet runSolver sc cs cm = -- function prevents the conflict set from growing by checking that the new -- conflict set is a subset of the old one and falling back to using the old -- conflict set when that check fails. - tryToRemoveOneVar :: Var QPN - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a + tryToRemoveOneVar + :: Var QPN + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a tryToRemoveOneVar v smallestKnownCS smallestKnownCM - -- Check whether v is still present, because it may have already been - -- removed in a previous solver rerun. + -- Check whether v is still present, because it may have already been + -- removed in a previous solver rerun. | not (v `CS.member` smallestKnownCS) = fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM | otherwise = - continueWith ("Trying to remove variable " ++ varStr ++ " from the " - ++ "conflict set.") $ - retry (runSolver sc') $ \case - err@(ExhaustiveSearch cs' _) - | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> - let msg = if not $ CS.member v cs' - then "Successfully removed " ++ varStr ++ " from " - ++ "the conflict set." - else "Failed to remove " ++ varStr ++ " from the " - ++ "conflict set." - in -- Use the new conflict set, even if v wasn't removed, - -- because other variables may have been removed. - failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err - | otherwise -> - failWith ("Failed to find a smaller conflict set. The new " - ++ "conflict set is not a subset of the previous " - ++ "conflict set: " ++ showCS cs') $ - ExhaustiveSearch smallestKnownCS smallestKnownCM - BackjumpLimitReached -> - failWith "Reached backjump limit while minimizing conflict set." - BackjumpLimitReached + continueWith + ( "Trying to remove variable " + ++ varStr + ++ " from the " + ++ "conflict set." + ) + $ retry (runSolver sc') + $ \case + err@(ExhaustiveSearch cs' _) + | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> + let msg = + if not $ CS.member v cs' + then + "Successfully removed " + ++ varStr + ++ " from " + ++ "the conflict set." + else + "Failed to remove " + ++ varStr + ++ " from the " + ++ "conflict set." + in -- Use the new conflict set, even if v wasn't removed, + -- because other variables may have been removed. + failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err + | otherwise -> + failWith + ( "Failed to find a smaller conflict set. The new " + ++ "conflict set is not a subset of the previous " + ++ "conflict set: " + ++ showCS cs' + ) + $ ExhaustiveSearch smallestKnownCS smallestKnownCM + BackjumpLimitReached -> + failWith + "Reached backjump limit while minimizing conflict set." + BackjumpLimitReached where varStr = "\"" ++ showVar v ++ "\"" showCS cs' = "{" ++ showConflictSet cs' ++ "}" - sc' = sc { goalOrder = Just goalOrder' } + sc' = sc{goalOrder = Just goalOrder'} goalOrder' = - preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) - <> preferGoal v - <> fromMaybe mempty (goalOrder sc) + preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) + <> preferGoal v + <> fromMaybe mempty (goalOrder sc) -- Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. - retryNoSolution :: RetryLog step SolverFailure done - -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) - -> RetryLog step SolverFailure done + retryNoSolution + :: RetryLog step SolverFailure done + -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) + -> RetryLog step SolverFailure done retryNoSolution lg f = retry lg $ \case - ExhaustiveSearch cs' cm' -> f cs' cm' - BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) + ExhaustiveSearch cs' cm' -> f cs' cm' + BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) -- | Goal ordering that chooses goals contained in the conflict set before -- other goals. -preferGoalsFromConflictSet :: ConflictSet - -> Variable QPN -> Variable QPN -> Ordering +preferGoalsFromConflictSet + :: ConflictSet + -> Variable QPN + -> Variable QPN + -> Ordering preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs -- | Goal ordering that chooses the given goal first. @@ -308,31 +362,35 @@ preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering preferGoal preferred = comparing $ \v -> toVar v /= preferred toVar :: Variable QPN -> Var QPN -toVar (PackageVar qpn) = P qpn -toVar (FlagVar qpn fn) = F (FN qpn fn) -toVar (StanzaVar qpn sn) = S (SN qpn sn) +toVar (PackageVar qpn) = P qpn +toVar (FlagVar qpn fn) = F (FN qpn fn) +toVar (StanzaVar qpn sn) = S (SN qpn sn) finalErrorMsg :: SolverConfig -> SolverFailure -> String finalErrorMsg sc failure = - case failure of - ExhaustiveSearch cs cm -> - "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ showCS cm cs - ++ flagSuggestion - where - showCS = if solverVerbosity sc > normal - then CS.showCSWithFrequency - else CS.showCSSortedByFrequency - flagSuggestion = - -- Don't suggest --minimize-conflict-set if the conflict set is - -- already small, because it is unlikely to be reduced further. - if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) - then "\nTry running with --minimize-conflict-set to improve the " - ++ "error message." - else "" - BackjumpLimitReached -> - "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ - "change with --max-backjumps or try to run with --reorder-goals).\n" - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" + case failure of + ExhaustiveSearch cs cm -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + ++ flagSuggestion + where + showCS = + if solverVerbosity sc > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + flagSuggestion = + -- Don't suggest --minimize-conflict-set if the conflict set is + -- already small, because it is unlikely to be reduced further. + if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) + then + "\nTry running with --minimize-conflict-set to improve the " + ++ "error message." + else "" + BackjumpLimitReached -> + "Backjump limit reached (" + ++ currlimit (maxBackjumps sc) + ++ "change with --max-backjumps or try to run with --reorder-goals).\n" + where + currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs index d1ae64e5b38..4b4643ed5b1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs @@ -1,13 +1,13 @@ module Distribution.Solver.Modular.Assignment - ( Assignment(..) - , PAssignment - , FAssignment - , SAssignment - , toCPs - ) where + ( Assignment (..) + , PAssignment + , FAssignment + , SAssignment + , toCPs + ) where -import Prelude () import Distribution.Solver.Compat.Prelude hiding (pi) +import Prelude () import qualified Data.Array as A import qualified Data.List as L @@ -17,7 +17,7 @@ import Data.Maybe (fromJust) import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal -import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) +import Distribution.Solver.Types.ComponentDeps (Component, ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath @@ -30,10 +30,10 @@ import Distribution.Solver.Modular.Package -- | A (partial) package assignment. Qualified package names -- are associated with instances. -type PAssignment = Map QPN I +type PAssignment = Map QPN I -type FAssignment = Map QFN Bool -type SAssignment = Map QSN Bool +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool -- | A (partial) assignment of variables. data Assignment = A PAssignment FAssignment SAssignment @@ -49,12 +49,16 @@ toCPs :: Assignment -> RevDepMap -> [CP QPN] toCPs (A pa fa sa) rdm = let -- get hold of the graph - g :: Graph Component - vm :: Vertex -> ((), QPN, [(Component, QPN)]) + g :: Graph Component + vm :: Vertex -> ((), QPN, [(Component, QPN)]) cvm :: QPN -> Maybe Vertex -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. - (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) - (M.toList rdm)) + (g, vm, cvm) = + graphFromEdges + ( L.map + (\(x, xs) -> ((), x, nub xs)) + (M.toList rdm) + ) tg :: Graph Component tg = transposeG g -- Topsort the dependency graph, yielding a list of pkgs in the right order. @@ -62,33 +66,41 @@ toCPs (A pa fa sa) rdm = -- contain duplicates, because several variables might actually resolve to -- the same package in the presence of qualified package names. ps :: [PI QPN] - ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ - topSort g + ps = + L.map ((\(_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g -- Determine the flags per package, by walking over and regrouping the -- complete flag assignment by package. fapp :: Map QPN FlagAssignment - fapp = M.fromListWith mappend $ - L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ - M.toList $ - fa + fapp = + M.fromListWith mappend $ + L.map (\((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ + M.toList $ + fa -- Stanzas per package. sapp :: Map QPN OptionalStanzaSet - sapp = M.fromListWith mappend - $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty)) - $ M.toList sa + sapp = + M.fromListWith mappend $ + L.map (\((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty)) $ + M.toList sa -- Dependencies per package. depp :: QPN -> [(Component, PI QPN)] - depp qpn = let v :: Vertex - v = fromJust (cvm qpn) -- TODO: why this is safe? - dvs :: [(Component, Vertex)] - dvs = tg A.! v - in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs + depp qpn = + let v :: Vertex + v = fromJust (cvm qpn) -- TODO: why this is safe? + dvs :: [(Component, Vertex)] + dvs = tg A.! v + in L.map (\(comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs -- Translated to PackageDeps depp' :: QPN -> ComponentDeps [PI QPN] depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp - in - L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault mempty qpn fapp) - (M.findWithDefault mempty qpn sapp) - (depp' qpn)) - ps + in + L.map + ( \pi@(PI qpn _) -> + CP + pi + (M.findWithDefault mempty qpn fapp) + (M.findWithDefault mempty qpn sapp) + (depp' qpn) + ) + ps diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 5d196f4fd9f..f75a015b467 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Builder ( - buildTree + +module Distribution.Solver.Modular.Builder + ( buildTree , splits -- for testing ) where @@ -28,8 +29,8 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W @@ -40,19 +41,24 @@ import Distribution.Solver.Types.Settings -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build -- the tree. -data Linker a = Linker { - buildState :: a, - linkingState :: LinkingState -} +data Linker a = Linker + { buildState :: a + , linkingState :: LinkingState + } -- | The state needed to build the search tree without creating any linked nodes. -data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options -} +data BuildState = BS + { index :: Index + -- ^ information about packages and their dependencies + , rdeps :: RevDepMap + -- ^ set of all package goals, completed and open, with reverse dependencies + , open :: [OpenGoal] + -- ^ set of still open goals (flag and package goals) + , next :: BuildType + -- ^ kind of node to generate next + , qualifyOptions :: QualifyOptions + -- ^ qualification options + } -- | Map of available linking targets. type LinkingState = M.Map (PN, I) [PackagePath] @@ -62,33 +68,33 @@ type LinkingState = M.Map (PN, I) [PackagePath] -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs +extendOpen qpn' gs s@(BS{rdeps = gs', open = o'}) = go gs' o' gs where go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = - go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o ((Stanza sn@(SN qpn _) t) : ngs) = - go g (StanzaGoal sn t (flagGR qpn) : o) ngs + go g o [] = s{rdeps = g, open = o} + go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = + go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go g o ((Stanza sn@(SN qpn _) t) : ngs) = + go g (StanzaGoal sn t (flagGR qpn) : o) ngs go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) - | qpn == qpn' = - -- We currently only add a self-dependency to the graph if it is - -- between a package and its setup script. The edge creates a cycle - -- and causes the solver to backtrack and choose a different - -- instance for the setup script. We may need to track other - -- self-dependencies once we implement component-based solving. + | qpn == qpn' = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. case c of ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs - _ -> go g o ngs - | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs + _ -> go g o ngs + | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs + | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs + -- code above is correct; insert/adjust have different arg order + go g o ((Simple (LDep _dr (Ext _ext)) _) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Lang _lang)) _) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Pkg _pn _vr)) _) : ngs) = go g o ngs addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs @@ -100,26 +106,34 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> - BuildState -> BuildState +scopedExtendOpen + :: QPN + -> FlaggedDeps PN + -> FlagInfo + -> BuildState + -> BuildState scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps -- Introduce all package flags - qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs + qfdefs = L.map (\(fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals - gs = qfdefs ++ qfdeps - -- NOTE: - -- - -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially - -- multiple times, both via the flag declaration and via dependencies. + gs = qfdefs ++ qfdeps + +-- NOTE: +-- +-- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially +-- multiple times, both via the flag declaration and via dependencies. -- | Datatype that encodes what to build next -data BuildType = - Goals -- ^ build a goal choice node - | OneGoal OpenGoal -- ^ build a node for this goal - | Instance QPN PInfo -- ^ build a tree for a concrete instance +data BuildType + = -- | build a goal choice node + Goals + | -- | build a node for this goal + OneGoal OpenGoal + | -- | build a tree for a concrete instance + Instance QPN PInfo build :: Linker BuildState -> Tree () QGoalReason build = ana go @@ -128,37 +142,57 @@ build = ana go go s = addLinking (linkingState s) $ addChildren (buildState s) addChildren :: BuildState -> TreeF () QGoalReason BuildState - -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. -addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) +addChildren bs@(BS{rdeps = rdm, open = gs, next = Goals}) | L.null gs = DoneF rdm () - | otherwise = GoalChoiceF rdm $ P.fromList - $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) - $ splits gs - + | otherwise = + GoalChoiceF rdm $ + P.fromList $ + L.map (\(g, gs') -> (close g, bs{next = OneGoal g, open = gs'})) $ + splits gs -- If we have already picked a goal, then the choice depends on the kind -- of goal. -- -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn. -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = +addChildren bs@(BS{rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr)}) = case M.lookup pn idx of - Nothing -> FailF - (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) - UnknownPackage - Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn info })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here + Nothing -> + FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage + Just pis -> + PChoiceF + qpn + rdm + gr + ( W.fromList + ( L.map + ( \(i, info) -> + ([], POption i Nothing, bs{next = Instance qpn info}) + ) + (M.toList pis) + ) + ) +-- TODO: data structure conversion is rather ugly here -- For a flag, we create only two subtrees, and we create them in the order -- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = - FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) +addChildren bs@(BS{rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr)}) = + FChoiceF + qfn + rdm + gr + weak + m + b + ( W.fromList + [ ([if b then 0 else 1], True, (extendOpen qpn t bs){next = Goals}) + , ([if b then 1 else 0], False, (extendOpen qpn f bs){next = Goals}) + ] + ) where trivial = L.null t && L.null f weak = WeakOrTrivial $ unWeakOrTrivial w || trivial @@ -168,10 +202,17 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo -- the stanza by replacing the False branch with failure) or preferences -- (try enabling the stanza if possible by moving the True branch first). -addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = - SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn t bs) { next = Goals })]) +addChildren bs@(BS{rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr)}) = + SChoiceF + qsn + rdm + gr + trivial + ( W.fromList + [ ([0], False, bs{next = Goals}) + , ([1], True, (extendOpen qpn t bs){next = Goals}) + ] + ) where trivial = WeakOrTrivial (L.null t) @@ -179,9 +220,12 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr -- and furthermore we update the set of goals. -- -- TODO: We could inline this above. -addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = - addChildren ((scopedExtendOpen qpn fdeps fdefs bs) - { next = Goals }) +addChildren bs@(BS{next = Instance qpn (PInfo fdeps _ fdefs _)}) = + addChildren + ( (scopedExtendOpen qpn fdeps fdefs bs) + { next = Goals + } + ) {------------------------------------------------------------------------------- Add linking @@ -215,8 +259,10 @@ addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) -- The only nodes of interest are package nodes addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = - let linkedCs = fmap (\bs -> Linker bs ls) $ - W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) + let linkedCs = + fmap (\bs -> Linker bs ls) $ + W.fromList $ + concatMap (linkChoices ls qpn) (W.toList cs) unlinkedCs = W.mapWithKey goP cs allCs = unlinkedCs `W.union` linkedCs @@ -224,21 +270,23 @@ addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = -- that we record the package choice so that it is available below goP :: POption -> a -> Linker a goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls - goP _ _ = alreadyLinked - in PChoiceF qpn rdm gr allCs + goP _ _ = alreadyLinked + in PChoiceF qpn rdm gr allCs addLinking ls t = fmap (\bs -> Linker bs ls) t -linkChoices :: forall a w . LinkingState - -> QPN - -> (w, POption, a) - -> [(w, POption, a)] +linkChoices + :: forall a w + . LinkingState + -> QPN + -> (w, POption, a) + -> [(w, POption, a)] linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = - L.map aux (M.findWithDefault [] (pn, i) related) + L.map aux (M.findWithDefault [] (pn, i) related) where aux :: PackagePath -> (w, POption, a) aux pp = (weight, POption i (Just pp), subtree) linkChoices _ _ (_, POption _ (Just _), _) = - alreadyLinked + alreadyLinked alreadyLinked :: a alreadyLinked = error "addLinking called on tree that already contains linked nodes" @@ -249,38 +297,41 @@ alreadyLinked = error "addLinking called on tree that already contains linked no -- and computes the initial state and then the tree from there. buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason buildTree idx (IndependentGoals ind) igs = - build Linker { - buildState = BS { - index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = L.map topLevelGoal qpns - , next = Goals - , qualifyOptions = defaultQualifyOptions idx - } + build + Linker + { buildState = + BS + { index = idx + , rdeps = M.fromList (L.map (\qpn -> (qpn, [])) qpns) + , open = L.map topLevelGoal qpns + , next = Goals + , qualifyOptions = defaultQualifyOptions idx + } , linkingState = M.empty } where topLevelGoal qpn = PkgGoal qpn UserGoal - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + qpns + | ind = L.map makeIndependent igs + | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs {------------------------------------------------------------------------------- Goals -------------------------------------------------------------------------------} -- | Information needed about a dependency before it is converted into a Goal. -data OpenGoal = - FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason - | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason - | PkgGoal QPN QGoalReason +data OpenGoal + = FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason + | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason + | PkgGoal QPN QGoalReason -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal -> Goal QPN -close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr -close (StanzaGoal qsn _ gr) = Goal (S qsn) gr -close (PkgGoal qpn gr) = Goal (P qpn) gr +close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr +close (StanzaGoal qsn _ gr) = Goal (S qsn) gr +close (PkgGoal qpn gr) = Goal (P qpn) gr {------------------------------------------------------------------------------- Auxiliary diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs index ae399323b40..7ed6ef72bc5 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs @@ -1,6 +1,6 @@ module Distribution.Solver.Modular.Configured - ( CP(..) - ) where + ( CP (..) + ) where import Distribution.PackageDescription (FlagAssignment) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 0e2e8ad5baa..a6072637220 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -1,10 +1,10 @@ module Distribution.Solver.Modular.ConfiguredConversion - ( convCP - ) where + ( convCP + ) where +import Data.Either (partitionEithers) import Data.Maybe import Prelude hiding (pi) -import Data.Either (partitionEithers) import Distribution.Package (UnitId, packageId) @@ -13,60 +13,65 @@ import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured import Distribution.Solver.Modular.Package -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.InstSolverPackage import qualified Distribution.Solver.Types.PackageIndex as CI -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. -convCP :: SI.InstalledPackageIndex -> - CI.PackageIndex (SourcePackage loc) -> - CP QPN -> ResolverPackage loc +convCP + :: SI.InstalledPackageIndex + -> CI.PackageIndex (SourcePackage loc) + -> CP QPN + -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = case convPI qpi of - Left pi -> PreExisting $ - InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, - instSolverPkgLibDeps = fmap fst ds', - instSolverPkgExeDeps = fmap snd ds' - } - Right pi -> Configured $ - SolverPackage { - solverPkgSource = srcpkg, - solverPkgFlags = fa, - solverPkgStanzas = es, - solverPkgLibDeps = fmap fst ds', - solverPkgExeDeps = fmap snd ds' - } + Left pi -> + PreExisting $ + InstSolverPackage + { instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi + , instSolverPkgLibDeps = fmap fst ds' + , instSolverPkgExeDeps = fmap snd ds' + } + Right pi -> + Configured $ + SolverPackage + { solverPkgSource = srcpkg + , solverPkgFlags = fa + , solverPkgStanzas = es + , solverPkgLibDeps = fmap fst ds' + , solverPkgExeDeps = fmap snd ds' + } where srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where - ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) + ds' :: ComponentDeps ([SolverId {- lib -}], [SolverId {- exe -}]) ds' = fmap (partitionEithers . map convConfId) ds convPI :: PI QPN -> Either UnitId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi -convPI pi = Right (packageId (either id id (convConfId pi))) +convPI pi = Right (packageId (either id id (convConfId pi))) convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = - case loc of - Inst pi -> Left (PreExistingId sourceId pi) - _otherwise - | QualExe _ pn' <- q - -- NB: the dependencies of the executable are also - -- qualified. So the way to tell if this is an executable - -- dependency is to make sure the qualifier is pointing - -- at the actual thing. Fortunately for us, I was - -- silly and didn't allow arbitrarily nested build-tools - -- dependencies, so a shallow check works. - , pn == pn' -> Right (PlannedId sourceId) - | otherwise -> Left (PlannedId sourceId) + case loc of + Inst pi -> Left (PreExistingId sourceId pi) + _otherwise + | QualExe _ pn' <- q + , -- NB: the dependencies of the executable are also + -- qualified. So the way to tell if this is an executable + -- dependency is to make sure the qualifier is pointing + -- at the actual thing. Fortunately for us, I was + -- silly and didn't allow arbitrarily nested build-tools + -- dependencies, so a shallow check works. + pn == pn' -> + Right (PlannedId sourceId) + | otherwise -> Left (PlannedId sourceId) where - sourceId = PackageIdentifier pn v + sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs index 190e811f06f..b2e376a12ed 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs @@ -8,6 +8,7 @@ -- -- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) -- > import qualified Distribution.Solver.Modular.ConflictSet as CS +{- FOURMOLU_DISABLE -} module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque , Conflict(..) @@ -74,34 +75,31 @@ data ConflictSet = CS { #endif } deriving (Show) +{- FOURMOLU_ENABLE -} -- | More detailed information about how a conflict set variable caused a -- conflict. This information can be used to determine whether a second value -- for that variable would lead to the same conflict. -- -- TODO: Handle dependencies under flags or stanzas. -data Conflict = - - -- | The conflict set variable represents a package which depends on the +data Conflict + = -- | The conflict set variable represents a package which depends on the -- specified problematic package. For example, the conflict set entry -- '(P x, GoalConflict y)' means that package x introduced package y, and y -- led to a conflict. GoalConflict QPN - - -- | The conflict set variable represents a package with a constraint that + | -- | The conflict set variable represents a package with a constraint that -- excluded the specified package and version. For example, the conflict set -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that -- package x's constraint on y excluded y-2.0. - | VersionConstraintConflict QPN Ver - - -- | The conflict set variable represents a package that was excluded by a + VersionConstraintConflict QPN Ver + | -- | The conflict set variable represents a package that was excluded by a -- constraint from the specified package. For example, the conflict set -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' -- means that package y's constraint 'x >= 2.0' excluded some version of x. - | VersionConflict QPN OrderedVersionRange - - -- | Any other conflict. - | OtherConflict + VersionConflict QPN OrderedVersionRange + | -- | Any other conflict. + OtherConflict deriving (Eq, Ord, Show) -- | Version range with an 'Ord' instance. @@ -129,13 +127,13 @@ showCSWithFrequency = showCS True showCS :: Bool -> ConflictMap -> ConflictSet -> String showCS showCount cm = - intercalate ", " . map showWithFrequency . indexByFrequency + intercalate ", " . map showWithFrequency . indexByFrequency where indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of Just frequency | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" - _ -> showVar conflict + _ -> showVar conflict {------------------------------------------------------------------------------- Set-like operations @@ -147,6 +145,7 @@ toSet = M.keysSet . conflictSetToMap toList :: ConflictSet -> [Var QPN] toList = M.keys . conflictSetToMap +{- FOURMOLU_DISABLE -} union :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs index b82e39a0d26..1ed134b9586 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -1,18 +1,19 @@ {-# LANGUAGE TypeFamilies #-} -module Distribution.Solver.Modular.Cycles ( - detectCyclesPhase + +module Distribution.Solver.Modular.Cycles + ( detectCyclesPhase ) where -import Prelude hiding (cycle) import qualified Data.Map as M import qualified Data.Set as S +import Prelude hiding (cycle) import qualified Distribution.Compat.Graph as G import Distribution.Simple.Utils (ordNub) +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath @@ -22,28 +23,28 @@ detectCyclesPhase = go where -- Only check children of choice nodes. go :: Tree d c -> Tree d c - go (PChoice qpn rdm gr cs) = - PChoice qpn rdm gr $ fmap (checkChild qpn) (fmap go cs) + go (PChoice qpn rdm gr cs) = + PChoice qpn rdm gr $ fmap (checkChild qpn) (fmap go cs) go (FChoice qfn@(FN qpn _) rdm gr w m d cs) = - FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs) - go (SChoice qsn@(SN qpn _) rdm gr w cs) = - SChoice qsn rdm gr w $ fmap (checkChild qpn) (fmap go cs) + FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs) + go (SChoice qsn@(SN qpn _) rdm gr w cs) = + SChoice qsn rdm gr w $ fmap (checkChild qpn) (fmap go cs) go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs) go x@(Fail _ _) = x go x@(Done _ _) = x checkChild :: QPN -> Tree d c -> Tree d c - checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x - checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x - checkChild _ x@(Fail _ _) = x - checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x + checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x + checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x + checkChild _ x@(Fail _ _) = x + checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c failIfCycle qpn rdm x = case findCycles qpn rdm of - Nothing -> x + Nothing -> x Just relSet -> Fail relSet CyclicDependencies -- | Given the reverse dependency map from a node in the tree, check @@ -53,40 +54,41 @@ detectCyclesPhase = go -- TODO: The conflict set should also contain flag and stanza variables. findCycles :: QPN -> RevDepMap -> Maybe ConflictSet findCycles pkg rdm = - -- This function has two parts: a faster cycle check that is called at every - -- step and a slower calculation of the conflict set. - -- - -- 'hasCycle' checks for cycles incrementally by only looking for cycles - -- containing the current package, 'pkg'. It searches for cycles in the - -- 'RevDepMap', which is the data structure used to store reverse - -- dependencies in the search tree. We store the reverse dependencies in a - -- map, because Data.Map is smaller and/or has better sharing than - -- Distribution.Compat.Graph. - -- - -- If there is a cycle, we call G.cycles to find a strongly connected - -- component. Then we choose one cycle from the component to use for the - -- conflict set. Choosing only one cycle can lead to a smaller conflict set, - -- such as when a choice to enable testing introduces many cycles at once. - -- In that case, all cycles contain the current package and are in one large - -- strongly connected component. - -- - if hasCycle - then let scc :: G.Graph RevDepMapNode - scc = case G.cycles $ revDepMapToGraph rdm of - [] -> findCyclesError "cannot find a strongly connected component" - c : _ -> G.fromDistinctList c + -- This function has two parts: a faster cycle check that is called at every + -- step and a slower calculation of the conflict set. + -- + -- 'hasCycle' checks for cycles incrementally by only looking for cycles + -- containing the current package, 'pkg'. It searches for cycles in the + -- 'RevDepMap', which is the data structure used to store reverse + -- dependencies in the search tree. We store the reverse dependencies in a + -- map, because Data.Map is smaller and/or has better sharing than + -- Distribution.Compat.Graph. + -- + -- If there is a cycle, we call G.cycles to find a strongly connected + -- component. Then we choose one cycle from the component to use for the + -- conflict set. Choosing only one cycle can lead to a smaller conflict set, + -- such as when a choice to enable testing introduces many cycles at once. + -- In that case, all cycles contain the current package and are in one large + -- strongly connected component. + -- + if hasCycle + then + let scc :: G.Graph RevDepMapNode + scc = case G.cycles $ revDepMapToGraph rdm of + [] -> findCyclesError "cannot find a strongly connected component" + c : _ -> G.fromDistinctList c - next :: QPN -> QPN - next p = case G.neighbors scc p of - Just (n : _) -> G.nodeKey n - _ -> findCyclesError "cannot find next node in the cycle" + next :: QPN -> QPN + next p = case G.neighbors scc p of + Just (n : _) -> G.nodeKey n + _ -> findCyclesError "cannot find next node in the cycle" - -- This function also assumes that all cycles contain 'pkg'. - oneCycle :: [QPN] - oneCycle = case iterate next pkg of - [] -> findCyclesError "empty cycle" - x : xs -> x : takeWhile (/= x) xs - in Just $ CS.fromList $ map P oneCycle + -- This function also assumes that all cycles contain 'pkg'. + oneCycle :: [QPN] + oneCycle = case iterate next pkg of + [] -> findCyclesError "empty cycle" + x : xs -> x : takeWhile (/= x) xs + in Just $ CS.fromList $ map P oneCycle else Nothing where hasCycle :: Bool @@ -97,14 +99,14 @@ findCycles pkg rdm = where go :: S.Set QPN -> QPN -> S.Set QPN go s x = - if x `S.member` s + if x `S.member` s then s else foldl go (S.insert x s) $ neighbors x neighbors :: QPN -> [QPN] neighbors x = case x `M.lookup` rdm of - Nothing -> findCyclesError "cannot find node" - Just xs -> map snd xs + Nothing -> findCyclesError "cannot find node" + Just xs -> map snd xs findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) @@ -116,5 +118,6 @@ instance G.IsNode RevDepMapNode where nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode -revDepMapToGraph rdm = G.fromDistinctList - [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] +revDepMapToGraph rdm = + G.fromDistinctList + [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 27debc9c6f0..83e1a17777c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -1,34 +1,40 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} -module Distribution.Solver.Modular.Dependency ( - -- * Variables - Var(..) + +module Distribution.Solver.Modular.Dependency + ( -- * Variables + Var (..) , showVar , varPN + -- * Conflict sets , ConflictSet , ConflictMap , CS.showConflictSet + -- * Constrained instances - , CI(..) + , CI (..) + -- * Flagged dependencies , FlaggedDeps - , FlaggedDep(..) - , LDep(..) - , Dep(..) - , PkgComponent(..) - , ExposedComponent(..) - , DependencyReason(..) + , FlaggedDep (..) + , LDep (..) + , Dep (..) + , PkgComponent (..) + , ExposedComponent (..) + , DependencyReason (..) , showDependencyReason , flattenFlaggedDeps - , QualifyOptions(..) + , QualifyOptions (..) , qualifyDeps , unqualifyDeps + -- * Reverse dependency map , RevDepMap + -- * Goals - , Goal(..) - , GoalReason(..) + , Goal (..) + , GoalReason (..) , QGoalReason , goalToVar , varToConflictSet @@ -39,21 +45,21 @@ module Distribution.Solver.Modular.Dependency ( , dependencyReasonToConflictSetWithVersionConflict ) where -import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Solver.Compat.Prelude hiding (pi) +import Prelude () -import Language.Haskell.Extension (Extension(..), Language(..)) +import Language.Haskell.Extension (Extension (..), Language (..)) -import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) +import Distribution.Solver.Modular.ConflictSet (ConflictMap, ConflictSet) +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Var import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.ComponentDeps (Component (..)) import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange @@ -85,14 +91,14 @@ type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep qpn = - -- | Dependencies which are conditional on a flag choice. +data FlaggedDep qpn + = -- | Dependencies which are conditional on a flag choice. Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza + | -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies which are always enabled, for the component 'comp'. - | Simple (LDep qpn) Component + Stanza (SN qpn) (TrueFlaggedDeps qpn) + | -- | Dependencies which are always enabled, for the component 'comp'. + Simple (LDep qpn) Component -- | Conservatively flatten out flagged dependencies -- @@ -102,10 +108,10 @@ flattenFlaggedDeps = concatMap aux where aux :: FlaggedDep qpn -> [(LDep qpn, Component)] aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f - aux (Stanza _ t) = flattenFlaggedDeps t - aux (Simple d c) = [(d, c)] + aux (Stanza _ t) = flattenFlaggedDeps t + aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps qpn +type TrueFlaggedDeps qpn = FlaggedDeps qpn type FalseFlaggedDeps qpn = FlaggedDeps qpn -- | A 'Dep' labeled with the reason it was introduced. @@ -119,11 +125,16 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package - deriving Functor +data Dep qpn + = -- | dependency on a package component + Dep (PkgComponent qpn) CI + | -- | dependency on a language extension + Ext Extension + | -- | dependency on a language version + Lang Language + | -- | dependency on a pkg-config package + Pkg PkgconfigName PkgconfigVersionRange + deriving (Functor) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. @@ -132,8 +143,8 @@ data PkgComponent qpn = PkgComponent qpn ExposedComponent -- | A component that can be depended upon by another package, i.e., a library -- or an executable. -data ExposedComponent = - ExposedLib LibraryName +data ExposedComponent + = ExposedLib LibraryName | ExposedExe UnqualComponentName deriving (Eq, Ord, Show) @@ -147,22 +158,21 @@ data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Sta -- | Print the reason that a dependency was introduced. showDependencyReason :: DependencyReason QPN -> String showDependencyReason (DependencyReason qpn flags stanzas) = - intercalate " " $ - showQPN qpn + intercalate " " $ + showQPN qpn : map (uncurry showFlagValue) (M.toList flags) - ++ map (\s -> showSBool s True) (S.toList stanzas) + ++ map (\s -> showSBool s True) (S.toList stanzas) -- | Options for goal qualification (used in 'qualifyDeps') -- -- See also 'defaultQualifyOptions' -data QualifyOptions = QO { - -- | Do we have a version of base relying on another version of base? - qoBaseShim :: Bool - - -- Should dependencies of the setup script be treated as independent? - , qoSetupIndependent :: Bool +data QualifyOptions = QO + { qoBaseShim :: Bool + -- ^ Do we have a version of base relying on another version of base? + , -- Should dependencies of the setup script be treated as independent? + qoSetupIndependent :: Bool } - deriving Show + deriving (Show) -- | Apply built-in rules for package qualifiers -- @@ -182,8 +192,8 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go go1 :: FlaggedDep PN -> FlaggedDep QPN go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep comp) comp + go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep comp) comp -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like @@ -197,15 +207,15 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci + Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp - | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci + | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci + | otherwise = Dep (Q (PackagePath ns inheritedQ) <$> dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup @@ -216,10 +226,10 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go -- a detailed discussion. inheritedQ :: Qualifier inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q - QualBase _ -> QualToplevel + QualSetup _ -> q + QualExe _ _ -> q + QualToplevel -> q + QualBase _ -> QualToplevel -- Should we qualify this goal with the 'Base' package path? qBase :: PN -> Bool @@ -244,8 +254,8 @@ unqualifyDeps = go go1 :: FlaggedDep QPN -> FlaggedDep PN go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep) comp + go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep) comp goLDep :: LDep QPN -> LDep PN goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) @@ -271,8 +281,8 @@ data Goal qpn = Goal (Var qpn) (GoalReason qpn) deriving (Eq, Show, Functor) -- | Reason why a goal is being added to a goal set. -data GoalReason qpn = - UserGoal -- introduced by a build target +data GoalReason qpn + = UserGoal -- introduced by a build target | DependencyGoal (DependencyReason qpn) -- introduced by a package deriving (Eq, Show, Functor) @@ -288,7 +298,7 @@ varToConflictSet = CS.singleton -- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal -- leads to a conflict. goalReasonToConflictSet :: GoalReason QPN -> ConflictSet -goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet UserGoal = CS.empty goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr -- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the @@ -302,14 +312,14 @@ goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) | M.null flags && S.null stanzas = CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal -goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr -- | This function returns the solver variables responsible for the dependency. -- It drops the values chosen for flag and stanza variables, which are only -- needed for log messages. dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = - CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) + CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) where -- Filter out any flags that introduced the dependency with both values. -- They don't need to be included in the conflict set, because changing the @@ -327,16 +337,19 @@ dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN - -> Ver - -> DependencyReason QPN - -> ConflictSet dependencyReasonToConflictSetWithVersionConstraintConflict - dependency excludedVersion dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConstraintConflict dependency excludedVersion - | otherwise = dependencyReasonToConflictSet dr + :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency + excludedVersion + dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr -- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the -- conflict occurred because the conflict set variables introduced a version of @@ -346,13 +359,16 @@ dependencyReasonToConflictSetWithVersionConstraintConflict -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConflict :: QPN - -> CS.OrderedVersionRange - -> DependencyReason QPN - -> ConflictSet dependencyReasonToConflictSetWithVersionConflict - pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConflict pkgWithVersionConstraint constraint - | otherwise = dependencyReasonToConflictSet dr + :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint + constraint + dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index 90038a28f5c..282b61fd28c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} + module Distribution.Solver.Modular.Explore (backjumpAndExplore) where import Distribution.Solver.Compat.Prelude @@ -15,20 +16,23 @@ import qualified Data.Set as S import Distribution.Simple.Setup (asBool) import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P -import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings - (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) + ( CountConflicts (..) + , EnableBackjumping (..) + , FineGrainedConflicts (..) + ) import Distribution.Types.VersionRange (anyVersion) -- | This function takes the variable we're currently considering, a @@ -58,108 +62,117 @@ import Distribution.Types.VersionRange (anyVersion) -- takes a function to determine whether a child can be skipped. If the child -- can be skipped, the function returns a new conflict set to be merged with the -- previous conflict set. --- -backjump :: forall w k a . Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - - -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) - -- ^ Function that determines whether the given choice could resolve - -- the given conflict. It indicates false by returning 'Just', - -- with the new conflicts to be added to the conflict set. - - -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) - -- ^ Function that logs the given choice that was skipped. - - -> Var QPN -- ^ The current variable. - - -> ConflictSet -- ^ Conflict set representing the reason that the goal - -- was introduced. - - -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) - -- ^ List of children's logs. - - -> ExploreState -> ConflictSetLog a -backjump mbj enableBj fineGrainedConflicts couldResolveConflicts - logSkippedChoice var lastCS xs = +backjump + :: forall w k a + . Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) + -- ^ Function that determines whether the given choice could resolve + -- the given conflict. It indicates false by returning 'Just', + -- with the new conflicts to be added to the conflict set. + -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) + -- ^ Function that logs the given choice that was skipped. + -> Var QPN + -- ^ The current variable. + -> ConflictSet + -- ^ Conflict set representing the reason that the goal + -- was introduced. + -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -- ^ List of children's logs. + -> ExploreState + -> ConflictSetLog a +backjump + mbj + enableBj + fineGrainedConflicts + couldResolveConflicts + logSkippedChoice + var + lastCS + xs = foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing - where - combine :: (k, ExploreState -> ConflictSetLog a) - -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - combine (k, x) f csAcc mPreviousCS es = + where + combine + :: (k, ExploreState -> ConflictSetLog a) + -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet + -> Maybe ConflictSet + -> ExploreState + -> ConflictSetLog a + combine (k, x) f csAcc mPreviousCS es = case (asBool fineGrainedConflicts, mPreviousCS) of (True, Just previousCS) -> - case CS.lookup var previousCS of - Just conflicts -> - case couldResolveConflicts k conflicts of - Nothing -> retryNoSolution (x es) next - Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) - _ -> skipChoice previousCS - _ -> retryNoSolution (x es) next - where - next :: ConflictSet -> ExploreState -> ConflictSetLog a - next !cs es' = if asBool enableBj && not (var `CS.member` cs) - then skipLoggingBackjump cs es' - else f (csAcc `CS.union` cs) (Just cs) es' - - -- This function is for skipping the choice when it cannot resolve any - -- of the previous conflicts. - skipChoice :: ConflictSet -> ConflictSetLog a - skipChoice newCS = + case CS.lookup var previousCS of + Just conflicts -> + case couldResolveConflicts k conflicts of + Nothing -> retryNoSolution (x es) next + Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) + _ -> skipChoice previousCS + _ -> retryNoSolution (x es) next + where + next :: ConflictSet -> ExploreState -> ConflictSetLog a + next !cs es' = + if asBool enableBj && not (var `CS.member` cs) + then skipLoggingBackjump cs es' + else f (csAcc `CS.union` cs) (Just cs) es' + + -- This function is for skipping the choice when it cannot resolve any + -- of the previous conflicts. + skipChoice :: ConflictSet -> ConflictSetLog a + skipChoice newCS = retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> - f (csAcc `CS.union` cs') (Just cs') $ - + f (csAcc `CS.union` cs') (Just cs') $ -- Update the conflict map with the conflict set, to make up for -- skipping the whole subtree. - es' { esConflictMap = updateCM cs' (esConflictMap es') } + es'{esConflictMap = updateCM cs' (esConflictMap es')} - -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - avoidGoal cs _mPreviousCS !es = + -- This function represents the option to not choose a value for this goal. + avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs _mPreviousCS !es = logBackjump mbj (cs `CS.union` lastCS) $ + -- Use 'lastCS' below instead of 'cs' since we do not want to + -- double-count the additionally accumulated conflicts. + es{esConflictMap = updateCM lastCS (esConflictMap es)} - -- Use 'lastCS' below instead of 'cs' since we do not want to - -- double-count the additionally accumulated conflicts. - es { esConflictMap = updateCM lastCS (esConflictMap es) } - - -- The solver does not count or log backjumps at levels where the conflict - -- set does not contain the current variable. Otherwise, there would be many - -- consecutive log messages about backjumping with the same conflict set. - skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a - skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) + -- The solver does not count or log backjumps at levels where the conflict + -- set does not contain the current variable. Otherwise, there would be many + -- consecutive log messages about backjumping with the same conflict set. + skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a + skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) -- | Creates a failing ConflictSetLog representing a backjump. It inserts a -- "backjumping" message, checks whether the backjump limit has been reached, -- and increments the backjump count. logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a logBackjump mbj cs es = - failWith (Failure cs Backjump) $ - if reachedBjLimit (esBackjumps es) - then BackjumpLimit - else NoSolution cs es { esBackjumps = esBackjumps es + 1 } + failWith (Failure cs Backjump) $ + if reachedBjLimit (esBackjumps es) + then BackjumpLimit + else NoSolution cs es{esBackjumps = esBackjumps es + 1} where reachedBjLimit = case mbj of - Nothing -> const False - Just limit -> (>= limit) + Nothing -> const False + Just limit -> (>= limit) -- | Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. -retryNoSolution :: ConflictSetLog a - -> (ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSetLog a +retryNoSolution + :: ConflictSetLog a + -> (ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSetLog a retryNoSolution lg f = retry lg $ \case - BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) - NoSolution cs es -> f cs es + BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) + NoSolution cs es -> f cs es -- | The state that is read and written while exploring the search tree. -data ExploreState = ES { - esConflictMap :: !ConflictMap - , esBackjumps :: !Int +data ExploreState = ES + { esConflictMap :: !ConflictMap + , esBackjumps :: !Int } -data IntermediateFailure = - NoSolution ConflictSet ExploreState +data IntermediateFailure + = NoSolution ConflictSet ExploreState | BackjumpLimit type ConflictSetLog = RetryLog Message IntermediateFailure @@ -168,99 +181,123 @@ getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) getBestGoal cm = P.maximumBy ( flip (M.findWithDefault 0) cm - . (\ (Goal v _) -> v) + . (\(Goal v _) -> v) ) getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) getFirstGoal ts = - P.casePSQ ts + P.casePSQ + ts (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error - (\ k v _xs -> (k, v)) -- commit to the first goal choice + (\k v _xs -> (k, v)) -- commit to the first goal choice updateCM :: ConflictSet -> ConflictMap -> ConflictMap updateCM cs cm = - L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) + L.foldl' (\cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) -- | Record complete assignments on 'Done' nodes. assign :: Tree d c -> Tree Assignment c assign tree = go tree (A M.empty M.empty M.empty) where go :: Tree d c -> Assignment -> Tree Assignment c - go (Fail c fr) _ = Fail c fr - go (Done rdm _) a = Done rdm a - go (PChoice qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f (fmap go ts) - where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) + go (Fail c fr) _ = Fail c fr + go (Done rdm _) a = Done rdm a + go (PChoice qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f (fmap go ts) + where + f (POption k _) r = r (A (M.insert qpn k pa) fa sa) go (FChoice qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f (fmap go ts) - where f k r = r (A pa (M.insert qfn k fa) sa) - go (SChoice qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f (fmap go ts) - where f k r = r (A pa fa (M.insert qsn k sa)) - go (GoalChoice rdm ts) a = GoalChoice rdm $ fmap ($ a) (fmap go ts) + where + f k r = r (A pa (M.insert qfn k fa) sa) + go (SChoice qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f (fmap go ts) + where + f k r = r (A pa fa (M.insert qsn k sa)) + go (GoalChoice rdm ts) a = GoalChoice rdm $ fmap ($ a) (fmap go ts) -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. -exploreLog :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree Assignment QGoalReason - -> ConflictSetLog (Assignment, RevDepMap) +exploreLog + :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree Assignment QGoalReason + -> ConflictSetLog (Assignment, RevDepMap) exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = - para go t initES + para go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' - | asBool countConflicts = \ ts cm -> getBestGoal cm ts - | otherwise = \ ts _ -> getFirstGoal ts - - go :: TreeF Assignment QGoalReason - (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) - -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) = \ !es -> - let es' = es { esConflictMap = updateCM c (esConflictMap es) } - in failWith (Failure c fr) (NoSolution c es') - go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) - go (PChoiceF qpn _ gr ts) = - backjump mbj enableBj fineGrainedConflicts - (couldResolveConflicts qpn) - (logSkippedPackage qpn) - (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryP qpn k) (r es)) - (fmap fst ts) - go (FChoiceF qfn _ gr _ _ _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryF qfn k) (r es)) - (fmap fst ts) - go (SChoiceF qsn _ gr _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryS qsn k) (r es)) - (fmap fst ts) - go (GoalChoiceF _ ts) = \ es -> + | asBool countConflicts = \ts cm -> getBestGoal cm ts + | otherwise = \ts _ -> getFirstGoal ts + + go + :: TreeF + Assignment + QGoalReason + (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) + -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + go (FailF c fr) = \ !es -> + let es' = es{esConflictMap = updateCM c (esConflictMap es)} + in failWith (Failure c fr) (NoSolution c es') + go (DoneF rdm a) = \_ -> succeedWith Success (a, rdm) + go (PChoiceF qpn _ gr ts) = + backjump + mbj + enableBj + fineGrainedConflicts + (couldResolveConflicts qpn) + (logSkippedPackage qpn) + (P qpn) + (avoidSet (P qpn) gr) + $ W.mapWithKey -- try children in order, + -- when descending ... + (\k r es -> tryWith (TryP qpn k) (r es)) + (fmap fst ts) + go (FChoiceF qfn _ gr _ _ _ ts) = + backjump + mbj + enableBj + fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (F qfn) + (avoidSet (F qfn) gr) + $ W.mapWithKey -- try children in order, + -- when descending ... + (\k r es -> tryWith (TryF qfn k) (r es)) + (fmap fst ts) + go (SChoiceF qsn _ gr _ ts) = + backjump + mbj + enableBj + fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (S qsn) + (avoidSet (S qsn) gr) + $ W.mapWithKey -- try children in order, + -- when descending ... + (\k r es -> tryWith (TryS qsn k) (r es)) + (fmap fst ts) + go (GoalChoiceF _ ts) = \es -> let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) - in continueWith (Next k) $ - -- Goal choice nodes are normally not counted as backjumps, since the - -- solver always explores exactly one choice, which means that the - -- backjump from the goal choice would be redundant with the backjump - -- from the PChoice, FChoice, or SChoice below. The one case where the - -- backjump is not redundant is when the chosen goal is a failure node, - -- so we log a backjump in that case. - case tree of - Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj - _ -> v es - - initES = ES { - esConflictMap = M.empty - , esBackjumps = 0 - } + in continueWith (Next k) $ + -- Goal choice nodes are normally not counted as backjumps, since the + -- solver always explores exactly one choice, which means that the + -- backjump from the goal choice would be redundant with the backjump + -- from the PChoice, FChoice, or SChoice below. The one case where the + -- backjump is not redundant is when the chosen goal is a failure node, + -- so we log a backjump in that case. + case tree of + Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj + _ -> v es + + initES = + ES + { esConflictMap = M.empty + , esBackjumps = 0 + } -- Is it possible for this package instance (QPN and POption) to resolve any -- of the conflicts that were caused by the previous instance? The default @@ -275,39 +312,41 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx couldBeResolved :: CS.Conflict -> Maybe ConflictSet couldBeResolved CS.OtherConflict = Nothing couldBeResolved (CS.GoalConflict conflictingDep) = - -- Check whether this package instance also has 'conflictingDep' - -- as a dependency (ignoring flag and stanza choices). - if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] + -- Check whether this package instance also has 'conflictingDep' + -- as a dependency (ignoring flag and stanza choices). + if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] then Nothing else Just CS.empty couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = - -- Check whether this package instance also excludes version - -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). - let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] - vrIntersection = L.foldl' (.&&.) anyVersion vrs - in if checkVR vrIntersection excludedVersion - then Nothing - else -- If we skip this package instance, we need to update the - -- conflict set to say that 'dep' was also excluded by - -- this package instance's constraint. - Just $ CS.singletonWithConflict (P dep) $ - CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) + -- Check whether this package instance also excludes version + -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). + let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep] + vrIntersection = L.foldl' (.&&.) anyVersion vrs + in if checkVR vrIntersection excludedVersion + then Nothing + else -- If we skip this package instance, we need to update the + -- conflict set to say that 'dep' was also excluded by + -- this package instance's constraint. + + Just $ + CS.singletonWithConflict (P dep) $ + CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = - -- Check whether this package instance's version is also excluded - -- by 'excludingVR'. - if checkVR excludingVR v + -- Check whether this package instance's version is also excluded + -- by 'excludingVR'. + if checkVR excludingVR v then Nothing else -- If we skip this version, we need to update the conflict - -- set to say that the reverse dependency also excluded this - -- version. - Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) - in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) + -- set to say that the reverse dependency also excluded this + -- version. + Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) + in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a logSkippedPackage qpn pOption cs es = - tryWith (TryP qpn pOption) $ + tryWith (TryP qpn pOption) $ failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ - NoSolution cs es + NoSolution cs es -- This function is used for flag and stanza choices, but it should not be -- called, because there is currently no way to skip a value for a flag or @@ -338,11 +377,10 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx -- - In a situation where all of the children's conflict sets contain the -- current variable, the goal reason of the current node will be added to the -- conflict set. --- avoidSet :: Var QPN -> QGoalReason -> ConflictSet avoidSet var@(P qpn) gr = CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) -avoidSet var gr = +avoidSet var gr = CS.union (CS.singleton var) (goalReasonToConflictSet gr) -- | Interface. @@ -350,17 +388,18 @@ avoidSet var gr = -- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', -- then infinitely many backjumps are allowed. If the limit is 'Just 0', -- backtracking is completely disabled. -backjumpAndExplore :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree d QGoalReason - -> RetryLog Message SolverFailure (Assignment, RevDepMap) +backjumpAndExplore + :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree d QGoalReason + -> RetryLog Message SolverFailure (Assignment, RevDepMap) backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = - mapFailure convertFailure - . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx - . assign + mapFailure convertFailure + . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx + . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) - convertFailure BackjumpLimit = BackjumpLimitReached + convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs index ea96226b217..cfc21061e36 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs @@ -1,23 +1,24 @@ {-# LANGUAGE DeriveFunctor #-} + module Distribution.Solver.Modular.Flag - ( FInfo(..) - , Flag - , FlagInfo - , FN(..) - , QFN - , QSN - , Stanza - , SN(..) - , WeakOrTrivial(..) - , FlagValue(..) - , mkFlag - , showQFN - , showQFNBool - , showFlagValue - , showQSN - , showQSNBool - , showSBool - ) where + ( FInfo (..) + , Flag + , FlagInfo + , FN (..) + , QFN + , QSN + , Stanza + , SN (..) + , WeakOrTrivial (..) + , FlagValue (..) + , mkFlag + , showQFN + , showQFNBool + , showFlagValue + , showQSN + , showQSNBool + , showSBool + ) where import Data.Map as M import Prelude hiding (pi) @@ -47,7 +48,7 @@ mkFlag = P.mkFlagName -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly. -- Weak flags are typically deferred by the solver. -data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } +data FInfo = FInfo {fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial} deriving (Eq, Show) -- | Flag defaults. @@ -74,7 +75,7 @@ type QSN = SN QPN -- A choice is called trivial if it clearly does not matter. The -- special case of triviality we actually consider is if there are no new -- dependencies introduced by the choice. -newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } +newtype WeakOrTrivial = WeakOrTrivial {unWeakOrTrivial :: Bool} deriving (Eq, Ord, Show) -- | Value shown for a flag in a solver log message. The message can refer to @@ -93,12 +94,12 @@ showFBool (FN _ f) v = P.showFlagValue (f, v) -- | String representation of a flag-value pair. showFlagValue :: P.FlagName -> FlagValue -> String -showFlagValue f FlagTrue = '+' : unFlag f +showFlagValue f FlagTrue = '+' : unFlag f showFlagValue f FlagFalse = '-' : unFlag f -showFlagValue f FlagBoth = "+/-" ++ unFlag f +showFlagValue f FlagBoth = "+/-" ++ unFlag f showSBool :: Stanza -> Bool -> String -showSBool s True = "*" ++ showStanza s +showSBool s True = "*" ++ showStanza s showSBool s False = "!" ++ showStanza s showQFN :: QFN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 2f28d12de85..e317b856692 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -1,17 +1,17 @@ module Distribution.Solver.Modular.Index - ( Index - , PInfo(..) - , ComponentInfo(..) - , IsVisible(..) - , IsBuildable(..) - , defaultQualifyOptions - , mkIndex - ) where + ( Index + , PInfo (..) + , ComponentInfo (..) + , IsVisible (..) + , IsBuildable (..) + , defaultQualifyOptions + , mkIndex + ) where import Prelude hiding (pi) -import Data.Map (Map) import qualified Data.List as L +import Data.Map (Map) import qualified Data.Map as M import Distribution.Solver.Modular.Dependency @@ -32,17 +32,19 @@ type Index = Map PN (Map I PInfo) -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) - (Map ExposedComponent ComponentInfo) - FlagInfo - (Maybe FailReason) +data PInfo + = PInfo + (FlaggedDeps PN) + (Map ExposedComponent ComponentInfo) + FlagInfo + (Maybe FailReason) -- | Info associated with each library and executable in a package instance. -data ComponentInfo = ComponentInfo { - compIsVisible :: IsVisible +data ComponentInfo = ComponentInfo + { compIsVisible :: IsVisible , compIsBuildable :: IsBuildable } - deriving Show + deriving (Show) -- | Whether a component is visible in the current environment. newtype IsVisible = IsVisible Bool @@ -53,21 +55,24 @@ newtype IsBuildable = IsBuildable Bool deriving (Eq, Show) mkIndex :: [(PN, I, PInfo)] -> Index -mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) +mkIndex xs = M.map M.fromList (groupMap (L.map (\(pn, i, pi) -> (pn, (i, pi))) xs)) groupMap :: Ord a => [(a, b)] -> Map a [b] -groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) +groupMap xs = M.fromListWith (flip (++)) (L.map (\(x, y) -> (x, [y])) xs) defaultQualifyOptions :: Index -> QualifyOptions -defaultQualifyOptions idx = QO { - qoBaseShim = or [ dep == base - | -- Find all versions of base .. - Just is <- [M.lookup base idx] - -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is - -- .. and flatten all their dependencies .. - , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps - ] +defaultQualifyOptions idx = + QO + { qoBaseShim = + or + [ dep == base + | -- Find all versions of base .. + Just is <- [M.lookup base idx] + , -- .. which are installed .. + (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is + , -- .. and flatten all their dependencies .. + (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps + ] , qoSetupIndependent = True } where diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index 72d0b8193e3..bf580afdb50 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -1,39 +1,49 @@ module Distribution.Solver.Modular.IndexConversion - ( convPIs - ) where + ( convPIs + ) where import Distribution.Solver.Compat.Prelude import Prelude () import qualified Data.List as L import qualified Data.Map.Strict as M -import qualified Distribution.Compat.NonEmptySet as NonEmptySet import qualified Data.Set as S +import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Compiler -import Distribution.Package -- from Cabal -import Distribution.Simple.BuildToolDepends -- from Cabal -import Distribution.Types.ExeDependency -- from Cabal -import Distribution.Types.PkgconfigDependency -- from Cabal -import Distribution.Types.ComponentName -- from Cabal -import Distribution.Types.CondTree -- from Cabal -import Distribution.Types.MungedPackageId -- from Cabal -import Distribution.Types.MungedPackageName -- from Cabal -import Distribution.PackageDescription -- from Cabal +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package -- from Cabal +-- from Cabal +-- from Cabal +-- from Cabal +-- from Cabal +-- from Cabal +-- from Cabal +-- from Cabal + +import Distribution.PackageDescription -- from Cabal import Distribution.PackageDescription.Configuration +import Distribution.Simple.BuildToolDepends import qualified Distribution.Simple.PackageIndex as SI import Distribution.System - -import Distribution.Solver.Types.ComponentDeps - ( Component(..), componentNameToComponent ) -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint +import Distribution.Types.ComponentName +import Distribution.Types.CondTree +import Distribution.Types.ExeDependency +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.PkgconfigDependency + +import Distribution.Solver.Types.ComponentDeps + ( Component (..) + , componentNameToComponent + ) +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Modular.Dependency as D import Distribution.Solver.Modular.Flag as F @@ -53,59 +63,69 @@ import Distribution.Solver.Modular.Version -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> ShadowPkgs -> StrongFlags -> SolveExecutables - -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) - -> Index +convPIs + :: OS + -> Arch + -> CompilerInfo + -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs + -> StrongFlags + -> SolveExecutables + -> SI.InstalledPackageIndex + -> CI.PackageIndex (SourcePackage loc) + -> Index convPIs os arch comp constraints sip strfl solveExes iidx sidx = mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx + convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] convIPI' (ShadowPkgs sip) idx = - -- apply shadowing whenever there are multiple installed packages with - -- the same version - [ maybeShadow (convIP idx pkg) - -- IMPORTANT to get internal libraries. See - -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx - , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] + -- apply shadowing whenever there are multiple installed packages with + -- the same version + [ maybeShadow (convIP idx pkg) + | -- IMPORTANT to get internal libraries. See + -- Note [Index conversion with internal libraries] + (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs + ] where - -- shadowing is recorded in the package info shadow (pn, i, PInfo fdeps comps fds _) | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) - shadow x = x + shadow x = x -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. convId :: IPI.InstalledPackageInfo -> (PN, I) convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) - where MungedPackageId mpn ver = mungedId ipi - -- HACK. See Note [Index conversion with internal libraries] - pn = encodeCompatPackageName mpn + where + MungedPackageId mpn ver = mungedId ipi + -- HACK. See Note [Index conversion with internal libraries] + pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of - Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) - Right fds -> (pn, i, PInfo fds components M.empty Nothing) - where - -- TODO: Handle sub-libraries and visibility. - components = - M.singleton (ExposedLib LMainLibName) - ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable True - } - - (pn, i) = convId ipi - - -- 'sourceLibName' is unreliable, but for now we only really use this for - -- primary libs anyways - comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi + Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) + Right fds -> (pn, i, PInfo fds components M.empty Nothing) + where + -- TODO: Handle sub-libraries and visibility. + components = + M.singleton + (ExposedLib LMainLibName) + ComponentInfo + { compIsVisible = IsVisible True + , compIsBuildable = IsBuildable True + } + + (pn, i) = convId ipi + + -- 'sourceLibName' is unreliable, but for now we only really use this for + -- primary libs anyways + comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi + -- TODO: Installed packages should also store their encapsulations! -- Note [Index conversion with internal libraries] @@ -144,101 +164,146 @@ convIP idx ipi = convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of - Nothing -> Left ipid - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. - in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) - -- NB: something we pick up from the - -- InstalledPackageIndex is NEVER an executable + Nothing -> Left ipid + Just ipi -> + let (pn, i) = convId ipi + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) + +-- NB: something we pick up from the +-- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables - -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] +convSPI' + :: OS + -> Arch + -> CompilerInfo + -> Map PN [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) + -> [(PN, I, PInfo)] convSPI' os arch cinfo constraints strfl solveExes = - L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages + L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) +convSP + :: OS + -> Arch + -> CompilerInfo + -> Map PN [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> SourcePackage loc + -> (PN, I, PInfo) convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) + in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription - -> PInfo -convGPD os arch cinfo constraints strfl solveExes pn - (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = - let - fds = flagInfo strfl flags - - - conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> - CondTree ConfVar [Dependency] a -> FlaggedDeps PN - conv comp getInfo dr = - convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . - addBuildableCondition getInfo - - initDR = DependencyReason pn M.empty S.empty - - flagged_deps - = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) - ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs - ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs - ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes - ++ prefix (Stanza (SN pn TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) - tests) - ++ prefix (Stanza (SN pn BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) - benchs) - ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) - - addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn - addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) - - -- | A too-new specVersion is turned into a global 'FailReason' - -- which prevents the solver from selecting this release (and if - -- forced to, emit a meaningful solver error message). - fr = case scannedVersion of +convGPD + :: OS + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> PN + -> GenericPackageDescription + -> PInfo +convGPD + os + arch + cinfo + constraints + strfl + solveExes + pn + (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = + let + fds = flagInfo strfl flags + + conv + :: Monoid a + => Component + -> (a -> BuildInfo) + -> DependencyReason PN + -> CondTree ConfVar [Dependency] a + -> FlaggedDeps PN + conv comp getInfo dr = + convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes + . addBuildableCondition getInfo + + initDR = DependencyReason pn M.empty S.empty + + flagged_deps = + concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes + ++ prefix + (Stanza (SN pn TestStanzas)) + ( L.map + (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) + tests + ) + ++ prefix + (Stanza (SN pn BenchStanzas)) + ( L.map + (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) + benchs + ) + ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) + + addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn + addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) + + -- \| A too-new specVersion is turned into a global 'FailReason' + -- which prevents the solver from selecting this release (and if + -- forced to, emit a meaningful solver error message). + fr = case scannedVersion of Just ver -> Just (UnsupportedSpecVer ver) - Nothing -> Nothing - - components :: Map ExposedComponent ComponentInfo - components = M.fromList $ libComps ++ subLibComps ++ exeComps - where - libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) - | lib <- maybeToList mlib ] - subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) - | (name, lib) <- sub_libs ] - exeComps = [ ( ExposedExe name - , ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False - } - ) - | (name, exe) <- exes ] - - libToComponentInfo lib = - ComponentInfo { - compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True + Nothing -> Nothing + + components :: Map ExposedComponent ComponentInfo + components = M.fromList $ libComps ++ subLibComps ++ exeComps + where + libComps = + [ (ExposedLib LMainLibName, libToComponentInfo lib) + | lib <- maybeToList mlib + ] + subLibComps = + [ (ExposedLib (LSubLibName name), libToComponentInfo lib) + | (name, lib) <- sub_libs + ] + exeComps = + [ ( ExposedExe name + , ComponentInfo + { compIsVisible = IsVisible True + , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False + } + ) + | (name, exe) <- exes + ] + + libToComponentInfo lib = + ComponentInfo + { compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False } - testCondition = testConditionForComponent os arch cinfo constraints - - isPrivate LibraryVisibilityPrivate = True - isPrivate LibraryVisibilityPublic = False + testCondition = testConditionForComponent os arch cinfo constraints - in PInfo flagged_deps components fds fr + isPrivate LibraryVisibilityPrivate = True + isPrivate LibraryVisibilityPublic = False + in + PInfo flagged_deps components fds fr -- | Applies the given predicate (for example, testing buildability or -- visibility) to the given component and environment. Values are combined with @@ -246,24 +311,27 @@ convGPD os arch cinfo constraints strfl solveExes pn -- before dependency solving. Additionally, this function only considers flags -- that are set by unqualified flag constraints, and it doesn't check the -- intra-package dependencies of a component. -testConditionForComponent :: OS - -> Arch - -> CompilerInfo - -> [LabeledPackageConstraint] - -> (a -> Bool) - -> CondTree ConfVar [Dependency] a - -> Maybe Bool +testConditionForComponent + :: OS + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> (a -> Bool) + -> CondTree ConfVar [Dependency] a + -> Maybe Bool testConditionForComponent os arch cinfo constraints p tree = - case go $ extractCondition p tree of - Lit True -> Just True - Lit False -> Just False - _ -> Nothing + case go $ extractCondition p tree of + Lit True -> Just True + Lit False -> Just False + _ -> Nothing where flagAssignment :: [(FlagName, Bool)] flagAssignment = - mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] + mconcat + [ unFlagAssignment fa + | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) <- + L.map unlabelPackageConstraint constraints + ] -- Simplify the condition, using the current environment. Most of this -- function was copied from convBranch and @@ -272,52 +340,56 @@ testConditionForComponent os arch cinfo constraints p tree = go (Var (OS os')) = Lit (os == os') go (Var (Arch arch')) = Lit (arch == arch') go (Var (Impl cf cvr)) - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True - | otherwise = Lit False + | matchImpl (compilerInfoId cinfo) + || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = + Lit True + | otherwise = Lit False where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv go (Var (PackageFlag f)) - | Just b <- L.lookup f flagAssignment = Lit b + | Just b <- L.lookup f flagAssignment = Lit b go (Var v) = Var v go (Lit b) = Lit b go (CNot c) = - case go c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' + case go c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' go (COr c d) = - case (go c, go d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c', d') -> COr c' d' + case (go c, go d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' go (CAnd c d) = - case (go c, go d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c', d') -> CAnd c' d' + case (go c, go d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) - -> [FlaggedDeps qpn] -> FlaggedDeps qpn -prefix _ [] = [] +prefix + :: (FlaggedDeps qpn -> FlaggedDep qpn) + -> [FlaggedDeps qpn] + -> FlaggedDeps qpn +prefix _ [] = [] prefix f fds = [f (concat fds)] -- | Convert flag information. Automatic flags are now considered weak -- unless strong flags have been selected explicitly. flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo flagInfo (StrongFlags strfl) = - M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) + M.fromList . L.map (\(MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) where weak m = WeakOrTrivial $ not (strfl || m) flagType m = if m then Manual else Automatic @@ -325,41 +397,50 @@ flagInfo (StrongFlags strfl) = -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation -- of all arguments preceding the input 'CondTree'. -convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> - Component -> - (a -> BuildInfo) -> - SolveExecutables -> - CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree + :: Map FlagName Bool + -> DependencyReason PN + -> PackageDescription + -> OS + -> Arch + -> CompilerInfo + -> PN + -> FlagInfo + -> Component + -> (a -> BuildInfo) + -> SolveExecutables + -> CondTree ConfVar [Dependency] a + -> FlaggedDeps PN convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = - -- Merge all library and build-tool dependencies at every level in - -- the tree of flagged dependencies. Otherwise 'extractCommon' - -- could create duplicate dependencies, and the number of - -- duplicates could grow exponentially from the leaves to the root - -- of the tree. - mergeSimpleDeps $ - [ D.Simple singleDep comp - | dep <- ds - , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies - - ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies - ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches - -- build-tools dependencies - -- NB: Only include these dependencies if SolveExecutables - -- is True. It might be false in the legacy solver - -- codepath, in which case there won't be any record of - -- an executable we need. - ++ [ D.Simple (convExeDep dr exeDep) comp - | solveExes' - , exeDep <- getAllToolDependencies pkg bi - , not $ isInternal pkg exeDep - ] + -- Merge all library and build-tool dependencies at every level in + -- the tree of flagged dependencies. Otherwise 'extractCommon' + -- could create duplicate dependencies, and the number of + -- duplicates could grow exponentially from the leaves to the root + -- of the tree. + mergeSimpleDeps $ + [ D.Simple singleDep comp + | dep <- ds + , singleDep <- convLibDeps dr dep -- unconditional package dependencies + ] + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches + -- build-tools dependencies + -- NB: Only include these dependencies if SolveExecutables + -- is True. It might be false in the legacy solver + -- codepath, in which case there won't be any record of + -- an executable we need. + ++ [ D.Simple (convExeDep dr exeDep) comp + | solveExes' + , exeDep <- getAllToolDependencies pkg bi + , not $ isInternal pkg exeDep + ] where bi = getInfo info -data SimpleFlaggedDepKey qpn = - SimpleFlaggedDepKey (PkgComponent qpn) Component +data SimpleFlaggedDepKey qpn + = SimpleFlaggedDepKey (PkgComponent qpn) Component deriving (Eq, Ord) data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR @@ -386,29 +467,34 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge where (merged, unmerged) = L.foldl' f (M.empty, []) deps where - f :: Ord qpn + f + :: Ord qpn => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) -> FlaggedDep qpn -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = - ( M.insertWith mergeValues - (SimpleFlaggedDepKey dep comp) - (SimpleFlaggedDepValue dr vr) - merged' - , unmerged') + ( M.insertWith + mergeValues + (SimpleFlaggedDepKey dep comp) + (SimpleFlaggedDepValue dr vr) + merged' + , unmerged' + ) f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') - mergeValues :: SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn + mergeValues + :: SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = - SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) + SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) - toFlaggedDep :: SimpleFlaggedDepKey qpn - -> SimpleFlaggedDepValue qpn - -> FlaggedDep qpn + toFlaggedDep + :: SimpleFlaggedDepKey qpn + -> SimpleFlaggedDepValue qpn + -> FlaggedDep qpn toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = - D.Simple (LDep dr (Dep dep (Constrained vr))) comp + D.Simple (LDep dr (Dep dep (Constrained vr))) comp -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- @@ -450,71 +536,84 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge -- -- 8. The set of package names which should be considered internal -- dependencies, and thus not handled as dependencies. -convBranch :: Map FlagName Bool - -> DependencyReason PN - -> PackageDescription - -> OS - -> Arch - -> CompilerInfo - -> PN - -> FlagInfo - -> Component - -> (a -> BuildInfo) - -> SolveExecutables - -> CondBranch ConfVar [Dependency] a - -> FlaggedDeps PN +convBranch + :: Map FlagName Bool + -> DependencyReason PN + -> PackageDescription + -> OS + -> Arch + -> CompilerInfo + -> PN + -> FlagInfo + -> Component + -> (a -> BuildInfo) + -> SolveExecutables + -> CondBranch ConfVar [Dependency] a + -> FlaggedDeps PN convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = - go c' - (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') - (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') - flags dr + go + c' + (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') + (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') + flags + dr where - go :: Condition ConfVar - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN - go (Lit True) t _ = t + go + :: Condition ConfVar + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> Map FlagName Bool + -> DependencyReason PN + -> FlaggedDeps PN + go (Lit True) t _ = t go (Lit False) _ f = f - go (CNot c) t f = go c f t - go (CAnd c d) t f = go c (go d t f) f - go (COr c d) t f = go c t (go d t f) + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) go (Var (PackageFlag fn)) t f = \flags' -> - case M.lookup fn flags' of - Just True -> t flags' - Just False -> f flags' - Nothing -> \dr' -> - -- Add each flag to the DependencyReason for all dependencies below, - -- including any extracted dependencies. Extracted dependencies are - -- introduced by both flag values (FlagBoth). Note that we don't - -- actually need to add the flag to the extracted dependencies for - -- correct backjumping; the information only improves log messages - -- by giving the user the full reason for each dependency. - let addFlagValue v = addFlagToDependencyReason fn v dr' - addFlag v = M.insert fn v flags' - in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) - (f (addFlag False) (addFlagValue FlagBoth)) - ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) - (f (addFlag False) (addFlagValue FlagFalse)) ] + case M.lookup fn flags' of + Just True -> t flags' + Just False -> f flags' + Nothing -> \dr' -> + -- Add each flag to the DependencyReason for all dependencies below, + -- including any extracted dependencies. Extracted dependencies are + -- introduced by both flag values (FlagBoth). Note that we don't + -- actually need to add the flag to the extracted dependencies for + -- correct backjumping; the information only improves log messages + -- by giving the user the full reason for each dependency. + let addFlagValue v = addFlagToDependencyReason fn v dr' + addFlag v = M.insert fn v flags' + in extractCommon + (t (addFlag True) (addFlagValue FlagBoth)) + (f (addFlag False) (addFlagValue FlagBoth)) + ++ [ Flagged + (FN pn fn) + (fds M.! fn) + (t (addFlag True) (addFlagValue FlagTrue)) + (f (addFlag False) (addFlagValue FlagFalse)) + ] go (Var (OS os')) t f - | os == os' = t - | otherwise = f + | os == os' = t + | otherwise = f go (Var (Arch arch')) t f - | arch == arch' = t - | otherwise = f + | arch == arch' = t + | otherwise = f go (Var (Impl cf cvr)) t f - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t - | otherwise = f + | matchImpl (compilerInfoId cinfo) + || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = + t + | otherwise = f where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = - DependencyReason pn' (M.insert fn v fs) ss + DependencyReason pn' (M.insert fn v fs) ss -- If both branches contain the same package as a simple dep, we lift it to -- the next higher-level, but with the union of version ranges. This @@ -529,26 +628,27 @@ convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch -- WARNING: This is quadratic! extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn extractCommon ps ps' = - -- Union the DependencyReasons, because the extracted dependency can be - -- avoided by removing the dependency from either side of the - -- conditional. - [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp - | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps - , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' - , dep1 == dep2 - ] + -- Union the DependencyReasons, because the extracted dependency can be + -- avoided by removing the dependency from either side of the + -- conditional. + [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' + , dep1 == dep2 + ] -- | Merge DependencyReasons by unioning their variables. unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = - DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) + DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) -- | Convert a Cabal dependency on a set of library components (from a single -- package) to solver-specific dependencies. convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] convLibDeps dr (Dependency pn vr libs) = - [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) - | lib <- NonEmptySet.toList libs ] + [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) + | lib <- NonEmptySet.toList libs + ] -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN @@ -557,6 +657,7 @@ convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (Expose -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN convSetupBuildInfo pn nfo = - [ D.Simple singleDep ComponentSetup - | dep <- setupDepends nfo - , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] + [ D.Simple singleDep ComponentSetup + | dep <- setupDepends nfo + , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep + ] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs b/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs index bf5d0f71615..53bce7027a4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs @@ -1,17 +1,21 @@ --- | Wrapper around Data.Graph with support for edge labels {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.LabeledGraph ( - -- * Graphs + +-- | Wrapper around Data.Graph with support for edge labels +module Distribution.Solver.Modular.LabeledGraph + ( -- * Graphs Graph , Vertex + -- ** Building graphs , graphFromEdges , graphFromEdges' , buildG , transposeG + -- ** Graph properties , vertices , edges + -- ** Operations on the underlying unlabeled graph , forgetLabels , topSort @@ -21,7 +25,7 @@ import Distribution.Solver.Compat.Prelude import Prelude () import Data.Array -import Data.Graph (Vertex, Bounds) +import Data.Graph (Bounds, Vertex) import qualified Data.Graph as G {------------------------------------------------------------------------------- @@ -29,7 +33,7 @@ import qualified Data.Graph as G -------------------------------------------------------------------------------} type Graph e = Array Vertex [(e, Vertex)] -type Edge e = (Vertex, e, Vertex) +type Edge e = (Vertex, e, Vertex) {------------------------------------------------------------------------------- Building graphs @@ -38,52 +42,63 @@ type Edge e = (Vertex, e, Vertex) -- | Construct an edge-labeled graph -- -- This is a simple adaptation of the definition in Data.Graph -graphFromEdges :: forall key node edge. Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - , key -> Maybe Vertex - ) +graphFromEdges + :: forall key node edge + . Ord key + => [(node, key, [(edge, key)])] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + , key -> Maybe Vertex + ) graphFromEdges edges0 = - (graph, \v -> vertex_map ! v, key_vertex) + (graph, \v -> vertex_map ! v, key_vertex) where - max_v = length edges0 - 1 - bounds0 = (0, max_v) :: (Vertex, Vertex) + max_v = length edges0 - 1 + bounds0 = (0, max_v) :: (Vertex, Vertex) sorted_edges = sortBy lt edges0 - edges1 = zip [0..] sorted_edges - - graph = array bounds0 [(v, (mapMaybe mk_edge ks)) - | (v, (_, _, ks)) <- edges1] - key_map = array bounds0 [(v, k ) - | (v, (_, k, _ )) <- edges1] - vertex_map = array bounds0 edges1 - - (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + edges1 = zip [0 ..] sorted_edges + + graph = + array + bounds0 + [ (v, (mapMaybe mk_edge ks)) + | (v, (_, _, ks)) <- edges1 + ] + key_map = + array + bounds0 + [ (v, k) + | (v, (_, k, _)) <- edges1 + ] + vertex_map = array bounds0 edges1 + + (_, k1, _) `lt` (_, k2, _) = k1 `compare` k2 mk_edge :: (edge, key) -> Maybe (edge, Vertex) - mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) + mk_edge (edge, key) = do v <- key_vertex key; return (edge, v) -- returns Nothing for non-interesting vertices key_vertex :: key -> Maybe Vertex key_vertex k = findVertex 0 max_v where findVertex a b - | a > b = Nothing + | a > b = Nothing | otherwise = case compare k (key_map ! mid) of - LT -> findVertex a (mid-1) + LT -> findVertex a (mid - 1) EQ -> Just mid - GT -> findVertex (mid+1) b + GT -> findVertex (mid + 1) b where mid = a + (b - a) `div` 2 -graphFromEdges' :: Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - ) -graphFromEdges' x = (a,b) +graphFromEdges' + :: Ord key + => [(node, key, [(edge, key)])] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + ) +graphFromEdges' x = (a, b) where - (a,b,_) = graphFromEdges x + (a, b, _) = graphFromEdges x transposeG :: Graph e -> Graph e transposeG g = buildG (bounds g) (reverseE g) @@ -94,7 +109,7 @@ buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) reassoc (v, e, w) = (v, (e, w)) reverseE :: Graph e -> [Edge e] -reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] +reverseE g = [(w, e, v) | (v, e, w) <- edges g] {------------------------------------------------------------------------------- Graph properties @@ -104,7 +119,7 @@ vertices :: Graph e -> [Vertex] vertices = indices edges :: Graph e -> [Edge e] -edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] +edges g = [(v, e, w) | v <- vertices g, (e, w) <- g ! v] {------------------------------------------------------------------------------- Operations on the underlying unlabelled graph diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs index eb3c98a8aca..a8b76ccbb1f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -3,31 +3,31 @@ -- TODO: remove this {-# OPTIONS -fno-warn-incomplete-uni-patterns #-} -module Distribution.Solver.Modular.Linking ( - validateLinking +module Distribution.Solver.Modular.Linking + ( validateLinking ) where +import Distribution.Solver.Compat.Prelude hiding (get, put) import Prelude () -import Distribution.Solver.Compat.Prelude hiding (get,put) import Control.Exception (assert) import Control.Monad (forM_, zipWithM_) -import Control.Monad.Reader (Reader, runReader, local, ask) -import Control.Monad.State (MonadState, StateT, get, put, modify, execStateT) +import Control.Monad.Reader (Reader, ask, local, runReader) +import Control.Monad.State (MonadState, StateT, execStateT, get, modify, put) import Control.Monad.Trans (lift) import Data.Map ((!)) -import qualified Data.Map as M -import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Traversable as T import Distribution.Client.Utils.Assertion import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.OptionalStanza @@ -56,19 +56,18 @@ import Distribution.Types.Flag (unFlagName) chosen either of them yet. -------------------------------------------------------------------------------} -data ValidateState = VS { - vsIndex :: Index - , vsLinks :: Map QPN LinkGroup - , vsFlags :: FAssignment - , vsStanzas :: SAssignment - , vsQualifyOptions :: QualifyOptions - - -- Saved qualified dependencies. Every time 'validateLinking' makes a +data ValidateState = VS + { vsIndex :: Index + , vsLinks :: Map QPN LinkGroup + , vsFlags :: FAssignment + , vsStanzas :: SAssignment + , vsQualifyOptions :: QualifyOptions + , -- Saved qualified dependencies. Every time 'validateLinking' makes a -- package choice, it qualifies the package's dependencies and saves them in -- this map. Then the qualified dependencies are available for subsequent -- flag and stanza choices for the same package. - , vsSaved :: Map QPN (FlaggedDeps QPN) - } + vsSaved :: Map QPN (FlaggedDeps QPN) + } type Validate = Reader ValidateState @@ -84,16 +83,15 @@ validateLinking index = (`runReader` initVS) . go where go :: Tree d c -> Validate (Tree d c) - go (PChoice qpn rdm gr cs) = - PChoice qpn rdm gr <$> (W.traverseWithKey (goP qpn) $ fmap go cs) + go (PChoice qpn rdm gr cs) = + PChoice qpn rdm gr <$> (W.traverseWithKey (goP qpn) $ fmap go cs) go (FChoice qfn rdm gr t m d cs) = FChoice qfn rdm gr t m d <$> (W.traverseWithKey (goF qfn) $ fmap go cs) - go (SChoice qsn rdm gr t cs) = - SChoice qsn rdm gr t <$> (W.traverseWithKey (goS qsn) $ fmap go cs) - + go (SChoice qsn rdm gr t cs) = + SChoice qsn rdm gr t <$> (W.traverseWithKey (goS qsn) $ fmap go cs) -- For the other nodes we just recurse - go (GoalChoice rdm cs) = GoalChoice rdm <$> T.traverse go cs - go (Done revDepMap s) = return $ Done revDepMap s + go (GoalChoice rdm cs) = GoalChoice rdm <$> T.traverse go cs + go (Done revDepMap s) = return $ Done revDepMap s go (Fail conflictSet failReason) = return $ Fail conflictSet failReason -- Package choices @@ -101,37 +99,38 @@ validateLinking index = (`runReader` initVS) . go goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask let PInfo deps _ _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps - newSaved = M.insert qpn qdeps (vsSaved vs) + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs' { vsSaved = newSaved }) r + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs'{vsSaved = newSaved}) r -- Flag choices goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goF qfn b r = do vs <- ask case execUpdateState (pickFlag qfn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r -- Stanza choices (much the same as flag choices) goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goS qsn b r = do vs <- ask case execUpdateState (pickStanza qsn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r initVS :: ValidateState - initVS = VS { - vsIndex = index - , vsLinks = M.empty - , vsFlags = M.empty - , vsStanzas = M.empty - , vsQualifyOptions = defaultQualifyOptions index - , vsSaved = M.empty - } + initVS = + VS + { vsIndex = index + , vsLinks = M.empty + , vsFlags = M.empty + , vsStanzas = M.empty + , vsQualifyOptions = defaultQualifyOptions index + , vsSaved = M.empty + } {------------------------------------------------------------------------------- Updating the validation state @@ -139,16 +138,16 @@ validateLinking index = (`runReader` initVS) . go type Conflict = (ConflictSet, String) -newtype UpdateState a = UpdateState { - unUpdateState :: StateT ValidateState (Either Conflict) a +newtype UpdateState a = UpdateState + { unUpdateState :: StateT ValidateState (Either Conflict) a } deriving (Functor, Applicative, Monad) instance MonadState ValidateState UpdateState where - get = UpdateState $ get + get = UpdateState $ get put st = UpdateState $ do - expensiveAssert (lgInvariant $ vsLinks st) $ return () - put st + expensiveAssert (lgInvariant $ vsLinks st) $ return () + put st lift' :: Either Conflict a -> UpdateState a lift' = UpdateState . lift @@ -160,69 +159,72 @@ execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateSt execUpdateState = execStateT . unUpdateState pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () -pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i -pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps +pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i +pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps pickConcrete :: QPN -> I -> UpdateState () pickConcrete qpn@(Q pp _) i = do - vs <- get - case M.lookup qpn (vsLinks vs) of - -- Package is not yet in a LinkGroup. Create a new singleton link group. - Nothing -> do - let lg = lgSingleton qpn (Just $ PI pp i) - updateLinkGroup lg - - -- Package is already in a link group. Since we are picking a concrete - -- instance here, it must by definition be the canonical package. - Just lg -> - makeCanonical lg qpn i + vs <- get + case M.lookup qpn (vsLinks vs) of + -- Package is not yet in a LinkGroup. Create a new singleton link group. + Nothing -> do + let lg = lgSingleton qpn (Just $ PI pp i) + updateLinkGroup lg + + -- Package is already in a link group. Since we are picking a concrete + -- instance here, it must by definition be the canonical package. + Just lg -> + makeCanonical lg qpn i pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () pickLink qpn@(Q _pp pn) i pp' deps = do - vs <- get - - -- The package might already be in a link group - -- (because one of its reverse dependencies is) - let lgSource = case M.lookup qpn (vsLinks vs) of - Nothing -> lgSingleton qpn Nothing - Just lg -> lg - - -- Find the link group for the package we are linking to - -- - -- Since the builder never links to a package without having first picked a - -- concrete instance for that package, and since we create singleton link - -- groups for concrete instances, this link group must exist (and must - -- in fact already have a canonical member). - let target = Q pp' pn - lgTarget = vsLinks vs ! target - - -- Verify here that the member we add is in fact for the same package and - -- matches the version of the canonical instance. However, violations of - -- these checks would indicate a bug in the linker, not a true conflict. - let sanityCheck :: Maybe (PI PackagePath) -> Bool - sanityCheck Nothing = False - sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI - assert (sanityCheck (lgCanon lgTarget)) $ return () - - -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget - updateLinkGroup lgTarget' - - -- Make sure all dependencies are linked as well - linkDeps target deps + vs <- get + + -- The package might already be in a link group + -- (because one of its reverse dependencies is) + let lgSource = case M.lookup qpn (vsLinks vs) of + Nothing -> lgSingleton qpn Nothing + Just lg -> lg + + -- Find the link group for the package we are linking to + -- + -- Since the builder never links to a package without having first picked a + -- concrete instance for that package, and since we create singleton link + -- groups for concrete instances, this link group must exist (and must + -- in fact already have a canonical member). + let target = Q pp' pn + lgTarget = vsLinks vs ! target + + -- Verify here that the member we add is in fact for the same package and + -- matches the version of the canonical instance. However, violations of + -- these checks would indicate a bug in the linker, not a true conflict. + let sanityCheck :: Maybe (PI PackagePath) -> Bool + sanityCheck Nothing = False + sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI + assert (sanityCheck (lgCanon lgTarget)) $ return () + + -- Merge the two link groups (updateLinkGroup will propagate the change) + lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget + updateLinkGroup lgTarget' + + -- Make sure all dependencies are linked as well + linkDeps target deps makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () makeCanonical lg qpn@(Q pp _) i = - case lgCanon lg of - -- There is already a canonical member. Fail. - Just _ -> - conflict ( CS.insert (P qpn) (lgConflictSet lg) - , "cannot make " ++ showQPN qpn - ++ " canonical member of " ++ showLinkGroup lg - ) - Nothing -> do - let lg' = lg { lgCanon = Just (PI pp i) } - updateLinkGroup lg' + case lgCanon lg of + -- There is already a canonical member. Fail. + Just _ -> + conflict + ( CS.insert (P qpn) (lgConflictSet lg) + , "cannot make " + ++ showQPN qpn + ++ " canonical member of " + ++ showLinkGroup lg + ) + Nothing -> do + let lg' = lg{lgCanon = Just (PI pp i)} + updateLinkGroup lg' -- | Link the dependencies of linked parents. -- @@ -235,13 +237,13 @@ makeCanonical lg qpn@(Q pp _) i = -- as well, and cover their dependencies at that point. linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () linkDeps target = \deps -> do - -- linkDeps is called in two places: when we first link one package to - -- another, and when we discover more dependencies of an already linked - -- package after doing some flag assignment. It is therefore important that - -- flag assignments cannot influence _how_ dependencies are qualified; - -- fortunately this is a documented property of 'qualifyDeps'. - rdeps <- requalify deps - go deps rdeps + -- linkDeps is called in two places: when we first link one package to + -- another, and when we discover more dependencies of an already linked + -- package after doing some flag assignment. It is therefore important that + -- flag assignments cannot influence _how_ dependencies are qualified; + -- fortunately this is a documented property of 'qualifyDeps'. + rdeps <- requalify deps + go deps rdeps where go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () go = zipWithM_ go1 @@ -250,28 +252,28 @@ linkDeps target = \deps -> do go1 dep rdep = case (dep, rdep) of (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do vs <- get - let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs - lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs + let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs + lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get case M.lookup fn (vsFlags vs) of - Nothing -> return () -- flag assignment not yet known - Just True -> go t t' + Nothing -> return () -- flag assignment not yet known + Just True -> go t t' Just False -> go f f' (Stanza sn t, ~(Stanza _ t')) -> do vs <- get case M.lookup sn (vsStanzas vs) of - Nothing -> return () -- stanza assignment not yet known - Just True -> go t t' + Nothing -> return () -- stanza assignment not yet known + Just True -> go t t' Just False -> return () -- stanza not enabled; no new deps - -- For extensions and language dependencies, there is nothing to do. - -- No choice is involved, just checking, so there is nothing to link. - -- The same goes for pkg-config constraints. - (Simple (LDep _ (Ext _)) _, _) -> return () - (Simple (LDep _ (Lang _)) _, _) -> return () - (Simple (LDep _ (Pkg _ _)) _, _) -> return () + -- For extensions and language dependencies, there is nothing to do. + -- No choice is involved, just checking, so there is nothing to link. + -- The same goes for pkg-config constraints. + (Simple (LDep _ (Ext _)) _, _) -> return () + (Simple (LDep _ (Lang _)) _, _) -> return () + (Simple (LDep _ (Pkg _ _)) _, _) -> return () requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) requalify deps = do @@ -280,15 +282,15 @@ linkDeps target = \deps -> do pickFlag :: QFN -> Bool -> UpdateState () pickFlag qfn b = do - modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } - verifyFlag qfn - linkNewDeps (F qfn) b + modify $ \vs -> vs{vsFlags = M.insert qfn b (vsFlags vs)} + verifyFlag qfn + linkNewDeps (F qfn) b pickStanza :: QSN -> Bool -> UpdateState () pickStanza qsn b = do - modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } - verifyStanza qsn - linkNewDeps (S qsn) b + modify $ \vs -> vs{vsStanzas = M.insert qsn b (vsStanzas vs)} + verifyStanza qsn + linkNewDeps (S qsn) b -- | Link dependencies that we discover after making a flag or stanza choice. -- @@ -299,36 +301,38 @@ pickStanza qsn b = do -- linked. linkNewDeps :: Var QPN -> Bool -> UpdateState () linkNewDeps var b = do - vs <- get - let qpn@(Q pp pn) = varPN var - qdeps = vsSaved vs ! qpn - lg = vsLinks vs ! qpn - newDeps = findNewDeps vs qdeps - linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps + vs <- get + let qpn@(Q pp pn) = varPN var + qdeps = vsSaved vs ! qpn + lg = vsLinks vs ! qpn + newDeps = findNewDeps vs qdeps + linkedTo = S.delete pp (lgMembers lg) + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps where findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN findNewDeps vs = concatMap (findNewDeps' vs) findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN - findNewDeps' _ (Simple _ _) = [] + findNewDeps' _ (Simple _ _) = [] findNewDeps' vs (Flagged qfn _ t f) = case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> if b then t else f + (True, _) -> if b then t else f (_, Nothing) -> [] -- not yet known (_, Just b') -> findNewDeps vs (if b' then t else f) findNewDeps' vs (Stanza qsn t) = case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> if b then t else [] + (True, _) -> if b then t else [] (_, Nothing) -> [] -- not yet known (_, Just b') -> findNewDeps vs (if b' then t else []) updateLinkGroup :: LinkGroup -> UpdateState () updateLinkGroup lg = do - verifyLinkGroup lg - modify $ \vs -> vs { - vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) - `M.union` vsLinks vs + verifyLinkGroup lg + modify $ \vs -> + vs + { vsLinks = + M.fromList (map aux (S.toList (lgMembers lg))) + `M.union` vsLinks vs } where aux pp = (Q pp (lgPackage lg), lg) @@ -339,37 +343,36 @@ updateLinkGroup lg = do verifyLinkGroup :: LinkGroup -> UpdateState () verifyLinkGroup lg = - case lgInstance lg of - -- No instance picked yet. Nothing to verify - Nothing -> - return () - - -- We picked an instance. Verify flags and stanzas - -- TODO: The enumeration of OptionalStanza names is very brittle; - -- if a constructor is added to the datatype we won't notice it here - Just i -> do - vs <- get - let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i - flags = M.keys finfo - stanzas = [TestStanzas, BenchStanzas] - forM_ flags $ \fn -> do - let flag = FN (lgPackage lg) fn - verifyFlag' flag lg - forM_ stanzas $ \sn -> do - let stanza = SN (lgPackage lg) sn - verifyStanza' stanza lg + case lgInstance lg of + -- No instance picked yet. Nothing to verify + Nothing -> + return () + -- We picked an instance. Verify flags and stanzas + -- TODO: The enumeration of OptionalStanza names is very brittle; + -- if a constructor is added to the datatype we won't notice it here + Just i -> do + vs <- get + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i + flags = M.keys finfo + stanzas = [TestStanzas, BenchStanzas] + forM_ flags $ \fn -> do + let flag = FN (lgPackage lg) fn + verifyFlag' flag lg + forM_ stanzas $ \sn -> do + let stanza = SN (lgPackage lg) sn + verifyStanza' stanza lg verifyFlag :: QFN -> UpdateState () verifyFlag (FN qpn@(Q _pp pn) fn) = do - vs <- get - -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN pn fn) (vsLinks vs ! qpn) + vs <- get + -- We can only pick a flag after picking an instance; link group must exist + verifyFlag' (FN pn fn) (vsLinks vs ! qpn) verifyStanza :: QSN -> UpdateState () verifyStanza (SN qpn@(Q _pp pn) sn) = do - vs <- get - -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN pn sn) (vsLinks vs ! qpn) + vs <- get + -- We can only pick a stanza after picking an instance; link group must exist + verifyStanza' (SN pn sn) (vsLinks vs ! qpn) -- | Verify that all packages in the link group agree on flag assignments -- @@ -378,14 +381,16 @@ verifyStanza (SN qpn@(Q _pp pn) sn) = do -- equal. verifyFlag' :: FN PN -> LinkGroup -> UpdateState () verifyFlag' (FN pn fn) lg = do - vs <- get - let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsFlags vs) flags - if allEqual (catMaybes vals) -- We ignore not-yet assigned flags - then return () - else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg - , "flag \"" ++ unFlagName fn ++ "\" incompatible" - ) + vs <- get + let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsFlags vs) flags + if allEqual (catMaybes vals) -- We ignore not-yet assigned flags + then return () + else + conflict + ( CS.fromList (map F flags) `CS.union` lgConflictSet lg + , "flag \"" ++ unFlagName fn ++ "\" incompatible" + ) -- | Verify that all packages in the link group agree on stanza assignments -- @@ -396,14 +401,16 @@ verifyFlag' (FN pn fn) lg = do -- This function closely mirrors 'verifyFlag''. verifyStanza' :: SN PN -> LinkGroup -> UpdateState () verifyStanza' (SN pn sn) lg = do - vs <- get - let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsStanzas vs) stanzas - if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas - then return () - else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg - , "stanza \"" ++ showStanza sn ++ "\" incompatible" - ) + vs <- get + let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsStanzas vs) stanzas + if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas + then return () + else + conflict + ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg + , "stanza \"" ++ showStanza sn ++ "\" incompatible" + ) {------------------------------------------------------------------------------- Link groups @@ -416,27 +423,24 @@ verifyStanza' (SN pn sn) lg = do -- There is an invariant that for all members of a link group, vsLinks must map -- to the same link group. The function updateLinkGroup can be used to -- re-establish this invariant after creating or expanding a LinkGroup. -data LinkGroup = LinkGroup { - -- | The name of the package of this link group - lgPackage :: PN - - -- | The canonical member of this link group (the one where we picked - -- a concrete instance). Once we have picked a canonical member, all - -- other packages must link to this one. - -- - -- We may not know this yet (if we are constructing link groups - -- for dependencies) - , lgCanon :: Maybe (PI PackagePath) - - -- | The members of the link group - , lgMembers :: Set PackagePath - - -- | The set of variables that should be added to the conflict set if - -- something goes wrong with this link set (in addition to the members - -- of the link group itself) - , lgBlame :: ConflictSet - } - deriving (Show, Eq) +data LinkGroup = LinkGroup + { lgPackage :: PN + -- ^ The name of the package of this link group + , lgCanon :: Maybe (PI PackagePath) + -- ^ The canonical member of this link group (the one where we picked + -- a concrete instance). Once we have picked a canonical member, all + -- other packages must link to this one. + -- + -- We may not know this yet (if we are constructing link groups + -- for dependencies) + , lgMembers :: Set PackagePath + -- ^ The members of the link group + , lgBlame :: ConflictSet + -- ^ The set of variables that should be added to the conflict set if + -- something goes wrong with this link set (in addition to the members + -- of the link group itself) + } + deriving (Show, Eq) -- | Invariant for the set of link groups: every element in the link group -- must be pointing to the /same/ link group @@ -457,56 +461,64 @@ lgInstance = fmap (\(PI _ i) -> i) . lgCanon showLinkGroup :: LinkGroup -> String showLinkGroup lg = - "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" + "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" where showMember :: PackagePath -> String - showMember pp = case lgCanon lg of - Just (PI pp' _i) | pp == pp' -> "*" - _otherwise -> "" - ++ case lgInstance lg of - Nothing -> showQPN (qpn pp) - Just i -> showPI (PI (qpn pp) i) + showMember pp = + case lgCanon lg of + Just (PI pp' _i) | pp == pp' -> "*" + _otherwise -> "" + ++ case lgInstance lg of + Nothing -> showQPN (qpn pp) + Just i -> showPI (PI (qpn pp) i) qpn :: PackagePath -> QPN qpn pp = Q pp (lgPackage lg) -- | Creates a link group that contains a single member. lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup -lgSingleton (Q pp pn) canon = LinkGroup { - lgPackage = pn - , lgCanon = canon +lgSingleton (Q pp pn) canon = + LinkGroup + { lgPackage = pn + , lgCanon = canon , lgMembers = S.singleton pp - , lgBlame = CS.empty + , lgBlame = CS.empty } lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup lgMerge blame lg lg' = do - canon <- pick (lgCanon lg) (lgCanon lg') - return LinkGroup { - lgPackage = lgPackage lg - , lgCanon = canon + canon <- pick (lgCanon lg) (lgCanon lg') + return + LinkGroup + { lgPackage = lgPackage lg + , lgCanon = canon , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] + , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] } where pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) - pick Nothing Nothing = Right Nothing - pick (Just x) Nothing = Right $ Just x - pick Nothing (Just y) = Right $ Just y + pick Nothing Nothing = Right Nothing + pick (Just x) Nothing = Right $ Just x + pick Nothing (Just y) = Right $ Just y pick (Just x) (Just y) = - if x == y then Right $ Just x - else Left ( CS.unions [ - blame - , lgConflictSet lg - , lgConflictSet lg' - ] - , "cannot merge " ++ showLinkGroup lg - ++ " and " ++ showLinkGroup lg' - ) + if x == y + then Right $ Just x + else + Left + ( CS.unions + [ blame + , lgConflictSet lg + , lgConflictSet lg' + ] + , "cannot merge " + ++ showLinkGroup lg + ++ " and " + ++ showLinkGroup lg' + ) lgConflictSet :: LinkGroup -> ConflictSet lgConflictSet lg = - CS.fromList (map aux (S.toList (lgMembers lg))) + CS.fromList (map aux (S.toList (lgMembers lg))) `CS.union` lgBlame lg where aux pp = P (Q pp (lgPackage lg)) @@ -516,6 +528,6 @@ lgConflictSet lg = -------------------------------------------------------------------------------} allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual [_] = True -allEqual (x:y:ys) = x == y && allEqual (y:ys) +allEqual [] = True +allEqual [_] = True +allEqual (x : y : ys) = x == y && allEqual (y : ys) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs index 321a051070b..32dce1b7de8 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs @@ -1,10 +1,10 @@ module Distribution.Solver.Modular.Log - ( displayLogMessages - , SolverFailure(..) - ) where + ( displayLogMessages + , SolverFailure (..) + ) where -import Prelude () import Distribution.Solver.Compat.Prelude +import Prelude () import Distribution.Solver.Types.Progress @@ -13,19 +13,21 @@ import Distribution.Solver.Modular.Message import Distribution.Solver.Modular.RetryLog -- | Information about a dependency solver failure. -data SolverFailure = - ExhaustiveSearch ConflictSet ConflictMap +data SolverFailure + = ExhaustiveSearch ConflictSet ConflictMap | BackjumpLimitReached -- | Postprocesses a log file. This function discards all log messages and -- avoids calling 'showMessages' if the log isn't needed (specified by -- 'keepLog'), for efficiency. -displayLogMessages :: Bool - -> RetryLog Message SolverFailure a - -> RetryLog String SolverFailure a -displayLogMessages keepLog lg = fromProgress $ +displayLogMessages + :: Bool + -> RetryLog Message SolverFailure a + -> RetryLog String SolverFailure a +displayLogMessages keepLog lg = + fromProgress $ if keepLog - then showMessages progress - else foldProgress (const id) Fail Done progress + then showMessages progress + else foldProgress (const id) Fail Done progress where progress = toProgress lg diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index eade1c3a1a0..4ac83f637a9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -1,16 +1,16 @@ {-# LANGUAGE BangPatterns #-} -module Distribution.Solver.Modular.Message ( - Message(..), - showMessages +module Distribution.Solver.Modular.Message + ( Message (..) + , showMessages ) where import qualified Data.List as L import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) import Data.Set (Set) import qualified Data.Set as S -import Data.Maybe (catMaybes, mapMaybe) import Prelude hiding (pi) import Distribution.Pretty (prettyShow) -- from Cabal @@ -19,10 +19,15 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.MessageUtils - (showUnsupportedExtension, showUnsupportedLanguage) + ( showUnsupportedExtension + , showUnsupportedLanguage + ) import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree - ( FailReason(..), POption(..), ConflictingDep(..) ) + ( ConflictingDep (..) + , FailReason (..) + , POption (..) + ) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath @@ -30,9 +35,11 @@ import Distribution.Solver.Types.Progress import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName -data Message = - Enter -- ^ increase indentation level - | Leave -- ^ decrease indentation level +data Message + = -- | increase indentation level + Enter + | -- | decrease indentation level + Leave | TryP QPN POption | TryF QFN Bool | TryS QSN Bool @@ -52,34 +59,34 @@ showMessages = go 0 -- 'go' increments the level for a recursive call when it encounters -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. go :: Int -> Progress Message a b -> Progress String a b - go !_ (Done x) = Done x - go !_ (Fail x) = Fail x + go !_ (Done x) = Done x + go !_ (Fail x) = Fail x -- complex patterns go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - goPReject l qpn [i] c fr ms + goPReject l qpn [i] c fr ms go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = - goPSkip l qpn [i] conflicts ms + goPSkip l qpn [i] conflicts ms go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) + (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) - go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) + (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) + go !l (Step (Next (Goal (P _) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = + (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = - (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms + (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms -- standard display - go !l (Step Enter ms) = go (l+1) ms - go !l (Step Leave ms) = go (l-1) ms - go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) - go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) - go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) + go !l (Step Enter ms) = go (l + 1) ms + go !l (Step Leave ms) = go (l - 1) ms + go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) + go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) + go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) - go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log - go !l (Step (Skip conflicts) ms) = - -- 'Skip' should always be handled by 'goPSkip' in the case above. - (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) - go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) - go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) + go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log + go !l (Step (Skip conflicts) ms) = + -- 'Skip' should always be handled by 'goPSkip' in the case above. + (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) + go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) + go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) showPackageGoal :: QPN -> QGoalReason -> String showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr @@ -88,120 +95,138 @@ showMessages = go 0 showFailure c fr = "fail" ++ showFR c fr -- special handler for many subsequent package rejections - goPReject :: Int - -> QPN - -> [POption] - -> ConflictSet - -> FailReason - -> Progress Message a b - -> Progress String a b + goPReject + :: Int + -> QPN + -> [POption] + -> ConflictSet + -> FailReason + -> Progress Message a b + -> Progress String a b goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms goPReject l qpn is c fr ms = - (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) + (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) -- Handle many subsequent skipped package instances. - goPSkip :: Int - -> QPN - -> [POption] - -> Set CS.Conflict - -> Progress Message a b - -> Progress String a b + goPSkip + :: Int + -> QPN + -> [POption] + -> Set CS.Conflict + -> Progress Message a b + -> Progress String a b goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms goPSkip l qpn is conflicts ms = - let msg = "skipping: " - ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) - ++ showConflicts conflicts - in atLevel l msg (go l ms) + let msg = + "skipping: " + ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) + ++ showConflicts conflicts + in atLevel l msg (go l ms) -- write a message with the current level number atLevel :: Int -> String -> Progress String a b -> Progress String a b atLevel l x xs = let s = show l - in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs + in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs -- | Display the set of 'Conflicts' for a skipped package version. showConflicts :: Set CS.Conflict -> String showConflicts conflicts = - " (has the same characteristics that caused the previous version to fail: " - ++ conflictMsg ++ ")" + " (has the same characteristics that caused the previous version to fail: " + ++ conflictMsg + ++ ")" where conflictMsg :: String conflictMsg = if S.member CS.OtherConflict conflicts - then - -- This case shouldn't happen, because an unknown conflict should not + then -- This case shouldn't happen, because an unknown conflict should not -- cause a version to be skipped. - "unknown conflict" - else let mergedConflicts = - [ showConflict qpn conflict - | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] + "unknown conflict" + else + let mergedConflicts = + [ showConflict qpn conflict + | (qpn, conflict) <- M.toList (mergeConflicts conflicts) + ] in if L.null mergedConflicts - then - -- This case shouldn't happen unless backjumping is turned off. + then -- This case shouldn't happen unless backjumping is turned off. "none" - else L.intercalate "; " mergedConflicts + else L.intercalate "; " mergedConflicts -- Merge conflicts to simplify the log message. mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList where - mergeConflict :: MergedPackageConflict - -> MergedPackageConflict - -> MergedPackageConflict - mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { - isGoalConflict = - isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 + mergeConflict + :: MergedPackageConflict + -> MergedPackageConflict + -> MergedPackageConflict + mergeConflict mergedConflict1 mergedConflict2 = + MergedPackageConflict + { isGoalConflict = + isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 , versionConstraintConflict = - L.nub $ versionConstraintConflict mergedConflict1 - ++ versionConstraintConflict mergedConflict2 + L.nub $ + versionConstraintConflict mergedConflict1 + ++ versionConstraintConflict mergedConflict2 , versionConflict = - mergeVersionConflicts (versionConflict mergedConflict1) - (versionConflict mergedConflict2) + mergeVersionConflicts + (versionConflict mergedConflict1) + (versionConflict mergedConflict2) } where mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) - mergeVersionConflicts (Just vr1) Nothing = Just vr1 - mergeVersionConflicts Nothing (Just vr2) = Just vr2 - mergeVersionConflicts Nothing Nothing = Nothing + mergeVersionConflicts (Just vr1) Nothing = Just vr1 + mergeVersionConflicts Nothing (Just vr2) = Just vr2 + mergeVersionConflicts Nothing Nothing = Nothing toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) toMergedConflict (CS.GoalConflict qpn) = - Just (qpn, MergedPackageConflict True [] Nothing) + Just (qpn, MergedPackageConflict True [] Nothing) toMergedConflict (CS.VersionConstraintConflict qpn v) = - Just (qpn, MergedPackageConflict False [v] Nothing) + Just (qpn, MergedPackageConflict False [v] Nothing) toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = - Just (qpn, MergedPackageConflict False [] (Just vr)) + Just (qpn, MergedPackageConflict False [] (Just vr)) toMergedConflict CS.OtherConflict = Nothing showConflict :: QPN -> MergedPackageConflict -> String showConflict qpn mergedConflict = L.intercalate "; " conflictStrings where - conflictStrings = catMaybes [ - case () of - () | isGoalConflict mergedConflict -> Just $ - "depends on '" ++ showQPN qpn ++ "'" ++ - (if null (versionConstraintConflict mergedConflict) - then "" - else " but excludes " - ++ showVersions (versionConstraintConflict mergedConflict)) - | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ - "excludes '" ++ showQPN qpn - ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) - | otherwise -> Nothing - , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") - <$> versionConflict mergedConflict - ] + conflictStrings = + catMaybes + [ case () of + () + | isGoalConflict mergedConflict -> + Just $ + "depends on '" + ++ showQPN qpn + ++ "'" + ++ ( if null (versionConstraintConflict mergedConflict) + then "" + else + " but excludes " + ++ showVersions (versionConstraintConflict mergedConflict) + ) + | not $ L.null (versionConstraintConflict mergedConflict) -> + Just $ + "excludes '" + ++ showQPN qpn + ++ "' " + ++ showVersions (versionConstraintConflict mergedConflict) + | otherwise -> Nothing + , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") + <$> versionConflict mergedConflict + ] - showVersions [] = "no versions" + showVersions [] = "no versions" showVersions [v] = "version " ++ showVer v - showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) + showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) -- | All conflicts related to one package, used for simplifying the display of -- a 'Set CS.Conflict'. -data MergedPackageConflict = MergedPackageConflict { - isGoalConflict :: Bool +data MergedPackageConflict = MergedPackageConflict + { isGoalConflict :: Bool , versionConstraintConflict :: [Ver] , versionConflict :: Maybe VR } @@ -209,52 +234,52 @@ data MergedPackageConflict = MergedPackageConflict { showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) showGR :: QGoalReason -> String -showGR UserGoal = " (user goal)" +showGR UserGoal = " (user goal)" showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" showFR :: ConflictSet -> FailReason -> String -showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")" -showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")" -showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" -showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" +showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" -showFR _ CannotInstall = " (only already installed instances can be used)" -showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" -showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" -showFR _ Shadowed = " (shadowed by another installed package with same version)" -showFR _ (Broken u) = " (package is broken, missing dependency " ++ prettyShow u ++ ")" -showFR _ UnknownPackage = " (unknown package)" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ (Broken u) = " (package is broken, missing dependency " ++ prettyShow u ++ ")" +showFR _ UnknownPackage = " (unknown package)" showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" -showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" -showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" -showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" -showFR _ ManualFlag = " (manual flag can only be changed explicitly)" -showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" -showFR _ MultipleInstances = " (multiple instances)" -showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" -showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" -showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" +showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" +showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" +showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" +showFR _ ManualFlag = " (manual flag can only be changed explicitly)" +showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" +showFR _ MultipleInstances = " (multiple instances)" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" +showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" +showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though. -showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" -showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" showExposedComponent :: ExposedComponent -> String -showExposedComponent (ExposedLib LMainLibName) = "library" +showExposedComponent (ExposedLib LMainLibName) = "library" showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" -showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" +showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src @@ -263,11 +288,19 @@ showConflictingDep :: ConflictingDep -> String showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = let DependencyReason qpn' _ _ = dr componentStr = case comp of - ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" - ExposedLib LMainLibName -> "" - ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" - in case ci of - Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ - showQPN qpn ++ componentStr ++ "==" ++ showI i - Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ - componentStr ++ showVR vr + ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + ExposedLib LMainLibName -> "" + ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" + in case ci of + Fixed i -> + (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") + ++ showQPN qpn + ++ componentStr + ++ "==" + ++ showI i + Constrained vr -> + showDependencyReason dr + ++ " => " + ++ showQPN qpn + ++ componentStr + ++ showVR vr diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs b/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs index 684216579e8..ebc1e1d110e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/MessageUtils.hs @@ -1,20 +1,23 @@ -- | Utility functions providing extra context to cabal error messages - -module Distribution.Solver.Modular.MessageUtils ( - allKnownExtensions, - cutoffRange, - mostSimilarElement, - showUnsupportedExtension, - showUnsupportedLanguage, - withinRange -) where +module Distribution.Solver.Modular.MessageUtils + ( allKnownExtensions + , cutoffRange + , mostSimilarElement + , showUnsupportedExtension + , showUnsupportedLanguage + , withinRange + ) where import Data.Foldable (minimumBy) import Data.Ord (comparing) import Distribution.Pretty (prettyShow) -- from Cabal import Language.Haskell.Extension - ( Extension(..), Language(..), knownLanguages, knownExtensions ) -import Text.EditDistance ( defaultEditCosts, levenshteinDistance ) + ( Extension (..) + , Language (..) + , knownExtensions + , knownLanguages + ) +import Text.EditDistance (defaultEditCosts, levenshteinDistance) showUnsupportedExtension :: Extension -> String showUnsupportedExtension (UnknownExtension extStr) = formatMessage cutoffRange "extension" extStr (mostSimilarElement extStr allKnownExtensions) @@ -28,7 +31,7 @@ allKnownExtensions :: [String] allKnownExtensions = enabledExtensions ++ disabledExtensions where enabledExtensions = map (prettyShow . EnableExtension) knownExtensions - disabledExtensions = map (prettyShow . DisableExtension) knownExtensions + disabledExtensions = map (prettyShow . DisableExtension) knownExtensions -- Measure the Levenshtein distance between two strings distance :: String -> String -> Int @@ -48,7 +51,7 @@ cutoffRange = 10 formatMessage :: Int -> String -> String -> String -> String formatMessage range elementType element suggestion | withinRange range element suggestion = - unwords ["unknown", elementType, element ++ ";", "did you mean", suggestion ++ "?"] + unwords ["unknown", elementType, element ++ ";", "did you mean", suggestion ++ "?"] | otherwise = unwords ["unknown", elementType, element] -- Check whether the strings are within cutoff range diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs index abed96f6b9d..64b54b8a287 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs @@ -1,32 +1,35 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} + module Distribution.Solver.Modular.PSQ - ( PSQ(..) -- Unit test needs constructor access - , casePSQ - , cons - , length - , lookup - , filter - , filterIfAny - , filterIfAnyByKeys - , filterKeys - , firstOnly - , fromList - , isZeroOrOne - , keys - , map - , mapKeys - , mapWithKey - , maximumBy - , minimumBy - , null - , prefer - , preferByKeys - , snoc - , sortBy - , sortByKeys - , toList - , union - ) where + ( PSQ (..) -- Unit test needs constructor access + , casePSQ + , cons + , length + , lookup + , filter + , filterIfAny + , filterIfAnyByKeys + , filterKeys + , firstOnly + , fromList + , isZeroOrOne + , keys + , map + , mapKeys + , mapWithKey + , maximumBy + , minimumBy + , null + , prefer + , preferByKeys + , snoc + , sortBy + , sortByKeys + , toList + , union + ) where -- Priority search queues. -- @@ -42,7 +45,7 @@ import Data.Function import qualified Data.List as S import Data.Ord (comparing) import Data.Traversable -import Prelude hiding (foldr, length, lookup, filter, null, map) +import Prelude hiding (filter, foldr, length, lookup, map, null) newtype PSQ k v = PSQ [(k, v)] deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP @@ -60,7 +63,7 @@ mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b -mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) +mapWithKey f (PSQ xs) = PSQ (fmap (\(k, v) -> (k, f k v)) xs) fromList :: [(k, a)] -> PSQ k a fromList = PSQ @@ -74,7 +77,7 @@ snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r casePSQ (PSQ xs) n c = case xs of - [] -> n + [] -> n (k, v) : ys -> c k v (PSQ ys) sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a @@ -89,7 +92,7 @@ maximumBy sel (PSQ xs) = minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a minimumBy sel (PSQ xs) = - PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] + PSQ [snd (S.minimumBy (comparing fst) (S.map (\x -> (sel (snd x), x)) xs))] -- | Sort the list so that values satisfying the predicate are first. prefer :: (a -> Bool) -> PSQ k a -> PSQ k a @@ -103,22 +106,20 @@ preferByKeys p = sortByKeys $ flip (comparing p) -- there is any element that satisfies the predicate, then only -- the elements satisfying the predicate are returned. -- Otherwise, the rest is returned. --- filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a filterIfAny p (PSQ xs) = let (pro, con) = S.partition (p . snd) xs - in + in if S.null pro then PSQ con else PSQ pro -- | Variant of 'filterIfAny' that takes a predicate on the keys -- rather than on the values. --- filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a filterIfAnyByKeys p (PSQ xs) = let (pro, con) = S.partition (p . fst) xs - in + in if S.null pro then PSQ con else PSQ pro filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a @@ -134,12 +135,12 @@ null :: PSQ k a -> Bool null (PSQ xs) = S.null xs isZeroOrOne :: PSQ k a -> Bool -isZeroOrOne (PSQ []) = True +isZeroOrOne (PSQ []) = True isZeroOrOne (PSQ [_]) = True -isZeroOrOne _ = False +isZeroOrOne _ = False firstOnly :: PSQ k a -> PSQ k a -firstOnly (PSQ []) = PSQ [] +firstOnly (PSQ []) = PSQ [] firstOnly (PSQ (x : _)) = PSQ [x] toList :: PSQ k a -> [(k, a)] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index ccd0e4d4a70..f3aa249153a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -1,12 +1,17 @@ {-# LANGUAGE DeriveFunctor #-} + module Distribution.Solver.Modular.Package - ( I(..) - , Loc(..) + ( I (..) + , Loc (..) , PackageId - , PackageIdentifier(..) - , PackageName, mkPackageName, unPackageName - , PkgconfigName, mkPkgconfigName, unPkgconfigName - , PI(..) + , PackageIdentifier (..) + , PackageName + , mkPackageName + , unPackageName + , PkgconfigName + , mkPkgconfigName + , unPkgconfigName + , PI (..) , PN , QPV , instI @@ -18,8 +23,8 @@ module Distribution.Solver.Modular.Package , unPN ) where -import Prelude () import Distribution.Solver.Compat.Prelude +import Prelude () import Distribution.Package -- from Cabal import Distribution.Pretty (prettyShow) @@ -57,13 +62,13 @@ data I = I Ver Loc -- | String representation of an instance. showI :: I -> String -showI (I v InRepo) = showVer v +showI (I v InRepo) = showVer v showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid where extractPackageAbiHash xs = - case first reverse $ break (=='-') $ reverse (prettyShow xs) of + case first reverse $ break (== '-') $ reverse (prettyShow xs) of (ys, []) -> ys - (ys, _) -> '-' : ys + (ys, _) -> '-' : ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I @@ -75,7 +80,7 @@ showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool instI (I _ (Inst _)) = True -instI _ = False +instI _ = False -- | Is the package in the primary group of packages. This is used to -- determine (1) if we should try to establish stanza preferences @@ -83,22 +88,20 @@ instI _ = False -- should apply to this dependency (grep 'primaryPP' to see the -- use sites). In particular this does not include packages pulled in -- as setup deps. --- primaryPP :: PackagePath -> Bool primaryPP (PackagePath _ns q) = go q where - go QualToplevel = True - go (QualBase _) = True - go (QualSetup _) = False - go (QualExe _ _) = False + go QualToplevel = True + go (QualBase _) = True + go (QualSetup _) = False + go (QualExe _ _) = False -- | Is the package a dependency of a setup script. This is used to -- establish whether or not certain constraints should apply to this -- dependency (grep 'setupPP' to see the use sites). --- setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True -setupPP (PackagePath _ns _) = False +setupPP (PackagePath _ns _) = False -- | Qualify a target package with its own name so that its dependencies are not -- required to be consistent with other targets. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index 3c5b6c5f984..63827163ffa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -1,29 +1,30 @@ {-# LANGUAGE ScopedTypeVariables #-} + -- | Reordering or pruning the tree in order to prefer or make certain choices. module Distribution.Solver.Modular.Preference - ( avoidReinstalls - , deferSetupExeChoices - , deferWeakFlagChoices - , enforceManualFlags - , enforcePackageConstraints - , enforceSingleInstanceRestriction - , firstGoal - , preferBaseGoalChoice - , preferLinked - , preferPackagePreferences - , preferReallyEasyGoalChoices - , requireInstalled - , onlyConstrained - , sortGoals - , pruneAfterFirstSuccess - ) where + ( avoidReinstalls + , deferSetupExeChoices + , deferWeakFlagChoices + , enforceManualFlags + , enforcePackageConstraints + , enforceSingleInstanceRestriction + , firstGoal + , preferBaseGoalChoice + , preferLinked + , preferPackagePreferences + , preferReallyEasyGoalChoices + , requireInstalled + , onlyConstrained + , sortGoals + , pruneAfterFirstSuccess + ) where -import Prelude () import Distribution.Solver.Compat.Prelude +import Prelude () +import Control.Monad.Trans.Reader (Reader, ask, local, runReader) import qualified Data.List as L import qualified Data.Map as M -import Control.Monad.Trans.Reader (Reader, runReader, ask, local) import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal @@ -36,13 +37,13 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.Variable +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a @@ -61,13 +62,17 @@ addWeights fs = go elemsToWhnf :: [a] -> () elemsToWhnf = foldr seq () - in PChoiceF qpn rdm x - -- Evaluate the children's versions before evaluating any of the - -- subtrees, so that 'sortedVersions' doesn't hold onto all of the - -- subtrees (referenced by cs) and cause a space leak. - (elemsToWhnf sortedVersions `seq` - W.mapWeightsWithKey (\k w -> weights k ++ w) cs) - go x = x + in PChoiceF + qpn + rdm + x + -- Evaluate the children's versions before evaluating any of the + -- subtrees, so that 'sortedVersions' doesn't hold onto all of the + -- subtrees (referenced by cs) and cause a space leak. + ( elemsToWhnf sortedVersions `seq` + W.mapWeightsWithKey (\k w -> weights k ++ w) cs + ) + go x = x addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c addWeight f = addWeights [f] @@ -79,13 +84,14 @@ version (POption (I v _) _) = v preferLinked :: EndoTreeTrav d c preferLinked = addWeight (const (const linked)) where - linked (POption _ Nothing) = 1 + linked (POption _ Nothing) = 1 linked (POption _ (Just _)) = 0 -- Works by setting weights on choice nodes. Also applies stanza preferences. preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c preferPackagePreferences pcs = - preferPackageStanzaPreferences pcs . + preferPackageStanzaPreferences pcs + . -- Each package is assigned a list of weights (currently three of them), -- and options are ordered by comparison of these lists. -- @@ -101,17 +107,17 @@ preferPackagePreferences pcs = -- For 'PreferOldest' one weight measures how close is the version to the -- the oldest one possible (between 0.0 and 1.0) and another checks whether -- the version is installed (0 or 1). - addWeights [ - \pn _ opt -> preferred pn opt - , \pn vs opt -> case preference pn of - PreferInstalled -> installed opt - PreferLatest -> latest vs opt - PreferOldest -> oldest vs opt - , \pn vs opt -> case preference pn of - PreferInstalled -> latest vs opt - PreferLatest -> installed opt - PreferOldest -> installed opt - ] + addWeights + [ \pn _ opt -> preferred pn opt + , \pn vs opt -> case preference pn of + PreferInstalled -> installed opt + PreferLatest -> latest vs opt + PreferOldest -> oldest vs opt + , \pn vs opt -> case preference pn of + PreferInstalled -> latest vs opt + PreferLatest -> installed opt + PreferOldest -> installed opt + ] where -- Prefer packages with higher version numbers over packages with -- lower version numbers. @@ -119,7 +125,7 @@ preferPackagePreferences pcs = latest sortedVersions opt = let l = length sortedVersions index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions - in fromIntegral index / fromIntegral l + in fromIntegral index / fromIntegral l -- Prefer packages with lower version numbers over packages with -- higher version numbers. @@ -129,19 +135,19 @@ preferPackagePreferences pcs = preference :: PN -> InstalledPreference preference pn = let PackagePreferences _ ipref _ = pcs pn - in ipref + in ipref - -- | Prefer versions satisfying more preferred version ranges. + -- \| Prefer versions satisfying more preferred version ranges. preferred :: PN -> POption -> Weight preferred pn opt = let PackagePreferences vrs _ _ = pcs pn - in fromIntegral . negate . L.length $ - L.filter (flip checkVR (version opt)) vrs + in fromIntegral . negate . L.length $ + L.filter (flip checkVR (version opt)) vrs -- Prefer installed packages over non-installed packages. installed :: POption -> Weight installed (POption (I _ (Inst _)) _) = 0 - installed _ = 1 + installed _ = 1 -- | Traversal that tries to establish package stanza enable\/disable -- preferences. Works by reordering the branches of stanza choices. @@ -160,116 +166,131 @@ preferPackageStanzaPreferences pcs = go -- move True case first to try enabling the stanza let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts weight k = if k then 0 else 1 - -- defer the choice by setting it to weak - in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' + in -- defer the choice by setting it to weak + SChoiceF qsn rdm gr (WeakOrTrivial True) ts' go x = x enableStanzaPref :: PN -> OptionalStanza -> Bool enableStanzaPref pn s = let PackagePreferences _ _ spref = pcs pn - in s `elem` spref + in s `elem` spref -- | Helper function that tries to enforce a single package constraint on a -- given instance for a P-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintP :: forall d c. QPN - -> ConflictSet - -> I - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c +processPackageConstraintP + :: forall d c + . QPN + -> ConflictSet + -> I + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn + if constraintScopeMatches scope qpn then go i prop else r where go :: I -> PackageProperty -> Tree d c go (I v _) (PackagePropertyVersion vr) - | checkVR vr v = r - | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ PackagePropertyInstalled - | instI i = r - | otherwise = Fail c (GlobalConstraintInstalled src) - go _ PackagePropertySource - | not (instI i) = r - | otherwise = Fail c (GlobalConstraintSource src) - go _ _ = r + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr src) + go _ PackagePropertyInstalled + | instI i = r + | otherwise = Fail c (GlobalConstraintInstalled src) + go _ PackagePropertySource + | not (instI i) = r + | otherwise = Fail c (GlobalConstraintSource src) + go _ _ = r -- | Helper function that tries to enforce a single package constraint on a -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintF :: forall d c. QPN - -> Flag - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c +processPackageConstraintF + :: forall d c + . QPN + -> Flag + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn + if constraintScopeMatches scope qpn then go prop else r where go :: PackageProperty -> Tree d c go (PackagePropertyFlags fa) = - case lookupFlagAssignment f fa of - Nothing -> r - Just b | b == b' -> r - | otherwise -> Fail c (GlobalConstraintFlag src) - go _ = r + case lookupFlagAssignment f fa of + Nothing -> r + Just b + | b == b' -> r + | otherwise -> Fail c (GlobalConstraintFlag src) + go _ = r -- | Helper function that tries to enforce a single package constraint on a -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintS :: forall d c. QPN - -> OptionalStanza - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c +processPackageConstraintS + :: forall d c + . QPN + -> OptionalStanza + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn + if constraintScopeMatches scope qpn then go prop else r where go :: PackageProperty -> Tree d c go (PackagePropertyStanzas ss) = - if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) - else r - go _ = r + if not b' && s `elem` ss + then Fail c (GlobalConstraintFlag src) + else r + go _ = r -- | Traversal that tries to establish various kinds of user constraints. Works -- by selectively disabling choices that have been ruled out by global user -- constraints. -enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] - -> EndoTreeTrav d c +enforcePackageConstraints + :: M.Map PN [LabeledPackageConstraint] + -> EndoTreeTrav d c enforcePackageConstraints pcs = go where - go (PChoiceF qpn@(Q _ pn) rdm gr ts) = + go (PChoiceF qpn@(Q _ pn) rdm gr ts) = let c = varToConflictSet (P qpn) -- compose the transformation functions for each of the relevant constraint - g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) - id - (M.findWithDefault [] pn pcs) - in PChoiceF qpn rdm gr (W.mapWithKey g ts) + g = \(POption i _) -> + foldl + (\h pc -> h . processPackageConstraintP qpn c i pc) + id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn rdm gr (W.mapWithKey g ts) go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = let c = varToConflictSet (F qfn) -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) - go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = + g = \b -> + foldl + (\h pc -> h . processPackageConstraintF qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) + go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = let c = varToConflictSet (S qsn) -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) + g = \b -> + foldl + (\h pc -> h . processPackageConstraintS qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) go x = x -- | Transformation that tries to enforce the rule that manual flags can only be @@ -296,39 +317,41 @@ enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c enforceManualFlags pcs = go where go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = - FChoiceF qfn rdm gr tr Manual d $ - let -- A list of all values specified by constraints on 'fn'. - -- We ignore the constraint scope in order to handle issue #4299. - flagConstraintValues :: [Bool] - flagConstraintValues = - [ flagVal - | let lpcs = M.findWithDefault [] pn pcs - , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs - , (fn', flagVal) <- unFlagAssignment fa - , fn' == fn ] - - -- Prune flag values that are not the default and do not match any - -- of the constraints. - restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c - restrictToggling flagDefault constraintVals flagVal r = - if flagVal `elem` constraintVals || flagVal == flagDefault - then r - else Fail (varToConflictSet (F qfn)) ManualFlag - - in W.mapWithKey (restrictToggling d flagConstraintValues) ts - go x = x + FChoiceF qfn rdm gr tr Manual d $ + let + -- A list of all values specified by constraints on 'fn'. + -- We ignore the constraint scope in order to handle issue #4299. + flagConstraintValues :: [Bool] + flagConstraintValues = + [ flagVal + | let lpcs = M.findWithDefault [] pn pcs + , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs + , (fn', flagVal) <- unFlagAssignment fa + , fn' == fn + ] + + -- Prune flag values that are not the default and do not match any + -- of the constraints. + restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c + restrictToggling flagDefault constraintVals flagVal r = + if flagVal `elem` constraintVals || flagVal == flagDefault + then r + else Fail (varToConflictSet (F qfn)) ManualFlag + in + W.mapWithKey (restrictToggling d flagConstraintValues) ts + go x = x -- | Require installed packages. requireInstalled :: (PN -> Bool) -> EndoTreeTrav d c requireInstalled p = go where go (PChoiceF v@(Q _ pn) rdm gr cs) - | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) - | otherwise = PChoiceF v rdm gr cs + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs where installed (POption (I _ (Inst _)) _) x = x installed _ _ = Fail (varToConflictSet (P v)) CannotInstall - go x = x + go x = x -- | Avoid reinstalls. -- @@ -347,43 +370,45 @@ avoidReinstalls :: (PN -> Bool) -> EndoTreeTrav d c avoidReinstalls p = go where go (PChoiceF qpn@(Q _ pn) rdm gr cs) - | p pn = PChoiceF qpn rdm gr disableReinstalls + | p pn = PChoiceF qpn rdm gr disableReinstalls | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = - let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] - in W.mapWithKey (notReinstall installed) cs + let installed = [v | (_, POption (I v (Inst _)) _, _) <- W.toList cs] + in W.mapWithKey (notReinstall installed) cs - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = - Fail (varToConflictSet (P qpn)) CannotReinstall + notReinstall vs (POption (I v InRepo) _) _ + | v `elem` vs = + Fail (varToConflictSet (P qpn)) CannotReinstall notReinstall _ _ x = x - go x = x + go x = x -- | Require all packages to be mentioned in a constraint or as a goal. onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason onlyConstrained p = go where - go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) - = FailF - (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) - NotExplicit - go x - = x + go (PChoiceF v@(Q _ pn) _ gr _) + | not (p pn) = + FailF + (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) + NotExplicit + go x = + x -- | Sort all goals using the provided function. sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c sortGoals variableOrder = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) - go x = x + go x = x goalOrder :: Goal QPN -> Goal QPN -> Ordering goalOrder = variableOrder `on` (varToVariable . goalToVar) varToVariable :: Var QPN -> Variable QPN - varToVariable (P qpn) = PackageVar qpn - varToVariable (F (FN qpn fn)) = FlagVar qpn fn + varToVariable (P qpn) = PackageVar qpn + varToVariable (F (FN qpn fn)) = FlagVar qpn fn varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza -- | Reduce the branching degree of the search tree by removing all choices @@ -392,10 +417,10 @@ sortGoals variableOrder = go pruneAfterFirstSuccess :: EndoTreeTrav d c pruneAfterFirstSuccess = go where - go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) + go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) - go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) - go x = x + go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) + go x = x -- | Always choose the first goal in the list next, abandoning all -- other choices. @@ -407,8 +432,9 @@ firstGoal :: EndoTreeTrav d c firstGoal = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) - go x = x - -- Note that we keep empty choice nodes, because they mean success. + go x = x + +-- Note that we keep empty choice nodes, because they mean success. -- | Transformation that tries to make a decision on base as early as -- possible by pruning all other goals when base is available. In nearly @@ -418,11 +444,11 @@ preferBaseGoalChoice :: EndoTreeTrav d c preferBaseGoalChoice = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) - go x = x + go x = x isBase :: Goal QPN -> Bool isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" - isBase _ = False + isBase _ = False -- | Deal with setup and build-tool-depends dependencies after regular dependencies, -- so we will link setup/exe dependencies against package dependencies when possible @@ -430,12 +456,12 @@ deferSetupExeChoices :: EndoTreeTrav d c deferSetupExeChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs) - go x = x + go x = x noSetupOrExe :: Goal QPN -> Bool noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False - noSetupOrExe _ = True + noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such @@ -444,15 +470,15 @@ deferWeakFlagChoices :: EndoTreeTrav d c deferWeakFlagChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) - go x = x + go x = x noWeakStanza :: Tree d c -> Bool - noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False - noWeakStanza _ = True + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True noWeakFlag :: Tree d c -> Bool noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False - noWeakFlag _ = True + noWeakFlag _ = True -- | Transformation that prefers goals with lower branching degrees. -- @@ -464,7 +490,7 @@ preferReallyEasyGoalChoices :: EndoTreeTrav d c preferReallyEasyGoalChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) - go x = x + go x = x -- | Monad used internally in enforceSingleInstanceRestriction -- diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs b/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs index 0386eb18dd2..8cc3a1a9cd5 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs @@ -1,15 +1,16 @@ {-# LANGUAGE Rank2Types #-} + module Distribution.Solver.Modular.RetryLog - ( RetryLog - , toProgress - , fromProgress - , mapFailure - , retry - , failWith - , succeedWith - , continueWith - , tryWith - ) where + ( RetryLog + , toProgress + , fromProgress + , mapFailure + , retry + , failWith + , succeedWith + , continueWith + , tryWith + ) where import Distribution.Solver.Compat.Prelude import Prelude () @@ -18,9 +19,11 @@ import Distribution.Solver.Modular.Message import Distribution.Solver.Types.Progress -- | 'Progress' as a difference list that allows efficient appends at failures. -newtype RetryLog step fail done = RetryLog { - unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) - -> Progress step fail2 done +newtype RetryLog step fail done = RetryLog + { unRetryLog + :: forall fail2 + . (fail -> Progress step fail2 done) + -> Progress step fail2 done } -- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. @@ -31,25 +34,28 @@ toProgress (RetryLog f) = f Fail fromProgress :: Progress step fail done -> RetryLog step fail done fromProgress l = RetryLog $ \f -> go f l where - go :: (fail1 -> Progress step fail2 done) - -> Progress step fail1 done - -> Progress step fail2 done + go + :: (fail1 -> Progress step fail2 done) + -> Progress step fail1 done + -> Progress step fail2 done go _ (Done d) = Done d go f (Fail failure) = f failure go f (Step m ms) = Step m (go f ms) -- | /O(1)/. Apply a function to the failure value in a log. -mapFailure :: (fail1 -> fail2) - -> RetryLog step fail1 done - -> RetryLog step fail2 done +mapFailure + :: (fail1 -> fail2) + -> RetryLog step fail1 done + -> RetryLog step fail2 done mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) -- | /O(1)/. If the first log leads to failure, continue with the second. -retry :: RetryLog step fail1 done - -> (fail1 -> RetryLog step fail2 done) - -> RetryLog step fail2 done +retry + :: RetryLog step fail1 done + -> (fail1 -> RetryLog step fail2 done) + -> RetryLog step fail2 done retry (RetryLog f) g = - RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog + RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog -- | /O(1)/. Create a log with one message before a failure. failWith :: step -> fail -> RetryLog step fail done @@ -60,9 +66,10 @@ succeedWith :: step -> done -> RetryLog step fail done succeedWith m d = RetryLog $ const $ Step m (Done d) -- | /O(1)/. Prepend a message to a log. -continueWith :: step - -> RetryLog step fail done - -> RetryLog step fail done +continueWith + :: step + -> RetryLog step fail done + -> RetryLog step fail done continueWith m (RetryLog f) = RetryLog $ Step m . f -- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index 87ce414059f..7b5b8e3008a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -4,25 +4,25 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} #endif module Distribution.Solver.Modular.Solver - ( SolverConfig(..) - , solve - , PruneAfterFirstSuccess(..) - ) where + ( SolverConfig (..) + , solve + , PruneAfterFirstSuccess (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import qualified Data.Map as M import qualified Data.List as L +import qualified Data.Map as M import qualified Data.Set as S import Distribution.Verbosity import Distribution.Compiler (CompilerInfo) +import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.Settings import Distribution.Solver.Types.Variable @@ -32,18 +32,18 @@ import Distribution.Solver.Modular.Cycles import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Explore import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Linking import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.PSQ (PSQ) +import qualified Distribution.Solver.Modular.PSQ as PSQ import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.Preference as P -import Distribution.Solver.Modular.Validate -import Distribution.Solver.Modular.Linking -import Distribution.Solver.Modular.PSQ (PSQ) import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.PSQ as PSQ +import Distribution.Solver.Modular.Validate -import Distribution.Simple.Setup (BooleanFlag(..)) +import Distribution.Simple.Setup (BooleanFlag (..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS @@ -57,25 +57,25 @@ import Debug.Trace.Tree.Assoc (Assoc(..)) #endif -- | Various options for the modular solver. -data SolverConfig = SolverConfig { - reorderGoals :: ReorderGoals, - countConflicts :: CountConflicts, - fineGrainedConflicts :: FineGrainedConflicts, - minimizeConflictSet :: MinimizeConflictSet, - independentGoals :: IndependentGoals, - avoidReinstalls :: AvoidReinstalls, - shadowPkgs :: ShadowPkgs, - strongFlags :: StrongFlags, - allowBootLibInstalls :: AllowBootLibInstalls, - nonInstallablePackages :: [PackageName], - onlyConstrained :: OnlyConstrained, - maxBackjumps :: Maybe Int, - enableBackjumping :: EnableBackjumping, - solveExecutables :: SolveExecutables, - goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - solverVerbosity :: Verbosity, - pruneAfterFirstSuccess :: PruneAfterFirstSuccess -} +data SolverConfig = SolverConfig + { reorderGoals :: ReorderGoals + , countConflicts :: CountConflicts + , fineGrainedConflicts :: FineGrainedConflicts + , minimizeConflictSet :: MinimizeConflictSet + , independentGoals :: IndependentGoals + , avoidReinstalls :: AvoidReinstalls + , shadowPkgs :: ShadowPkgs + , strongFlags :: StrongFlags + , allowBootLibInstalls :: AllowBootLibInstalls + , nonInstallablePackages :: [PackageName] + , onlyConstrained :: OnlyConstrained + , maxBackjumps :: Maybe Int + , enableBackjumping :: EnableBackjumping + , solveExecutables :: SolveExecutables + , goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + , solverVerbosity :: Verbosity + , pruneAfterFirstSuccess :: PruneAfterFirstSuccess + } -- | Whether to remove all choices after the first successful choice at each -- level in the search tree. @@ -89,67 +89,84 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool -- There is one exception, though, and that is cycle detection, which -- has been added relatively recently. Cycles are only removed directly -- before exploration. --- -solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo - -> Index -- ^ all available packages as an index - -> PkgConfigDb -- ^ available pkg-config pkgs - -> (PN -> PackagePreferences) -- ^ preferences - -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints - -> S.Set PN -- ^ global goals - -> RetryLog Message SolverFailure (Assignment, RevDepMap) +solve + :: SolverConfig + -- ^ solver parameters + -> CompilerInfo + -> Index + -- ^ all available packages as an index + -> PkgConfigDb + -- ^ available pkg-config pkgs + -> (PN -> PackagePreferences) + -- ^ preferences + -> M.Map PN [LabeledPackageConstraint] + -- ^ global constraints + -> S.Set PN + -- ^ global goals + -> RetryLog Message SolverFailure (Assignment, RevDepMap) solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = - explorePhase . - traceTree "cycles.json" id . - detectCycles . - traceTree "heuristics.json" id . - trav ( - heuristicsPhase . - preferencesPhase . - validationPhase - ) . - traceTree "semivalidated.json" id . - validationCata . - traceTree "pruned.json" id . - trav prunePhase . - traceTree "build.json" id $ - buildPhase + explorePhase + . traceTree "cycles.json" id + . detectCycles + . traceTree "heuristics.json" id + . trav + ( heuristicsPhase + . preferencesPhase + . validationPhase + ) + . traceTree "semivalidated.json" id + . validationCata + . traceTree "pruned.json" id + . trav prunePhase + . traceTree "build.json" id + $ buildPhase where - explorePhase = backjumpAndExplore (maxBackjumps sc) - (enableBackjumping sc) - (fineGrainedConflicts sc) - (countConflicts sc) - idx - detectCycles = detectCyclesPhase - heuristicsPhase = + explorePhase = + backjumpAndExplore + (maxBackjumps sc) + (enableBackjumping sc) + (fineGrainedConflicts sc) + (countConflicts sc) + idx + detectCycles = detectCyclesPhase + heuristicsPhase = let - sortGoals = case goalOrder sc of - Nothing -> goalChoiceHeuristics . - P.deferSetupExeChoices . - P.deferWeakFlagChoices . - P.preferBaseGoalChoice - Just order -> P.firstGoal . - P.sortGoals order - PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc - in sortGoals . - (if prune then P.pruneAfterFirstSuccess else id) - preferencesPhase = P.preferLinked . - P.preferPackagePreferences userPrefs - validationPhase = P.enforcePackageConstraints userConstraints . - P.enforceManualFlags userConstraints - validationCata = P.enforceSingleInstanceRestriction . - validateLinking idx . - validateTree cinfo idx pkgConfigDB - prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . - (if asBool (allowBootLibInstalls sc) - then id - else P.requireInstalled (`elem` nonInstallablePackages sc)) . - (case onlyConstrained sc of - OnlyConstrainedAll -> - P.onlyConstrained pkgIsExplicit - OnlyConstrainedNone -> - id) - buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) + sortGoals = case goalOrder sc of + Nothing -> + goalChoiceHeuristics + . P.deferSetupExeChoices + . P.deferWeakFlagChoices + . P.preferBaseGoalChoice + Just order -> + P.firstGoal + . P.sortGoals order + PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc + in + sortGoals + . (if prune then P.pruneAfterFirstSuccess else id) + preferencesPhase = + P.preferLinked + . P.preferPackagePreferences userPrefs + validationPhase = + P.enforcePackageConstraints userConstraints + . P.enforceManualFlags userConstraints + validationCata = + P.enforceSingleInstanceRestriction + . validateLinking idx + . validateTree cinfo idx pkgConfigDB + prunePhase = + (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) + . ( if asBool (allowBootLibInstalls sc) + then id + else P.requireInstalled (`elem` nonInstallablePackages sc) + ) + . ( case onlyConstrained sc of + OnlyConstrainedAll -> + P.onlyConstrained pkgIsExplicit + OnlyConstrainedNone -> + id + ) + buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) allExplicit = M.keysSet userConstraints `S.union` userGoals @@ -170,12 +187,13 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = -- goalChoiceHeuristics | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices - | otherwise = id {- P.firstGoal -} + | otherwise = id {- P.firstGoal -} -- | Dump solver tree to a file (in debugging mode) -- -- This only does something if the @debug-tracetree@ configure argument was -- given; otherwise this is just the identity function. +{- FOURMOLU_DISABLE -} traceTree :: #ifdef DEBUG_TRACETREE GSimpleTree a => @@ -229,6 +247,7 @@ instance GSimpleTree (Tree d c) where goCS :: ConflictSet -> String goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" #endif +{- FOURMOLU_ENABLE -} -- | Replace all goal reasons with a dummy goal reason in the tree -- @@ -236,22 +255,24 @@ instance GSimpleTree (Tree d c) where _removeGR :: Tree d c -> Tree d QGoalReason _removeGR = trav go where - go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) - go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq - go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq - go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq - go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) - go (DoneF rdm s) = DoneF rdm s - go (FailF cs reason) = FailF cs reason + go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason - goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) - goG = PSQ.fromList - . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) - . PSQ.toList + goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) + goG = + PSQ.fromList + . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) + . PSQ.toList - dummy :: QGoalReason - dummy = - DependencyGoal $ - DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) - M.empty S.empty + dummy :: QGoalReason + dummy = + DependencyGoal $ + DependencyReason + (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + M.empty + S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index 039da4b41b0..408bc27031f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -1,22 +1,25 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} + module Distribution.Solver.Modular.Tree - ( POption(..) - , Tree(..) - , TreeF(..) - , Weight - , FailReason(..) - , ConflictingDep(..) - , ana - , cata - , inn - , innM - , para - , trav - , zeroOrOneChoices - , active - , TreeTrav - , EndoTreeTrav - ) where + ( POption (..) + , Tree (..) + , TreeF (..) + , Weight + , FailReason (..) + , ConflictingDep (..) + , ana + , cata + , inn + , innM + , para + , trav + , zeroOrOneChoices + , active + , TreeTrav + , EndoTreeTrav + ) where import Control.Monad hiding (mapM, sequence) import Data.Foldable @@ -25,8 +28,8 @@ import Prelude hiding (foldr, mapM, sequence) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Version import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) import qualified Distribution.Solver.Modular.WeightedPSQ as W @@ -49,19 +52,16 @@ type Weight = Double -- -- TODO: The weight type should be changed from [Double] to Double to avoid -- giving too much weight to preferences that are applied later. -data Tree d c = - -- | Choose a version for a package (or choose to link) +data Tree d c + = -- | Choose a version for a package (or choose to link) PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) - - -- | Choose a value for a flag + | -- | Choose a value for a flag -- -- The Bool is the default value. - | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) - - -- | Choose whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) - - -- | Choose which choice to make next + FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose whether or not to enable a stanza + SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose which choice to make next -- -- Invariants: -- @@ -72,13 +72,11 @@ data Tree d c = -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) - - -- | We're done -- we found a solution! - | Done RevDepMap d - - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason + GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + | -- | We're done -- we found a solution! + Done RevDepMap d + | -- | We failed to find a solution in this path through the tree + Fail ConflictSet FailReason -- | A package option is a package instance with an optional linking annotation -- @@ -99,36 +97,37 @@ data Tree d c = data POption = POption I (Maybe PackagePath) deriving (Eq, Show) -data FailReason = UnsupportedExtension Extension - | UnsupportedLanguage Language - | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange - | NewPackageDoesNotMatchExistingConstraint ConflictingDep - | ConflictingConstraints ConflictingDep ConflictingDep - | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) - | PackageRequiresMissingComponent QPN ExposedComponent - | PackageRequiresPrivateComponent QPN ExposedComponent - | PackageRequiresUnbuildableComponent QPN ExposedComponent - | CannotInstall - | CannotReinstall - | NotExplicit - | Shadowed - | Broken UnitId - | UnknownPackage - | GlobalConstraintVersion VR ConstraintSource - | GlobalConstraintInstalled ConstraintSource - | GlobalConstraintSource ConstraintSource - | GlobalConstraintFlag ConstraintSource - | ManualFlag - | MalformedFlagChoice QFN - | MalformedStanzaChoice QSN - | EmptyGoalChoice - | Backjump - | MultipleInstances - | DependenciesNotLinked String - | CyclicDependencies - | UnsupportedSpecVer Ver +data FailReason + = UnsupportedExtension Extension + | UnsupportedLanguage Language + | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange + | NewPackageDoesNotMatchExistingConstraint ConflictingDep + | ConflictingConstraints ConflictingDep ConflictingDep + | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) + | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresPrivateComponent QPN ExposedComponent + | PackageRequiresUnbuildableComponent QPN ExposedComponent + | CannotInstall + | CannotReinstall + | NotExplicit + | Shadowed + | Broken UnitId + | UnknownPackage + | GlobalConstraintVersion VR ConstraintSource + | GlobalConstraintInstalled ConstraintSource + | GlobalConstraintSource ConstraintSource + | GlobalConstraintFlag ConstraintSource + | ManualFlag + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + | MultipleInstances + | DependenciesNotLinked String + | CyclicDependencies + | UnsupportedSpecVer Ver deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. @@ -137,53 +136,53 @@ data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) C -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- have the same meaning as in 'Tree'. -data TreeF d c a = - PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) - | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) - | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) - | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) - | DoneF RevDepMap d - | FailF ConflictSet FailReason +data TreeF d c a + = PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d + | FailF ConflictSet FailReason deriving (Functor, Foldable, Traversable) out :: Tree d c -> TreeF d c (Tree d c) -out (PChoice p s i ts) = PChoiceF p s i ts -out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts -out (SChoice p s i b ts) = SChoiceF p s i b ts -out (GoalChoice s ts) = GoalChoiceF s ts -out (Done x s ) = DoneF x s -out (Fail c x ) = FailF c x +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s) = DoneF x s +out (Fail c x) = FailF c x inn :: TreeF d c (Tree d c) -> Tree d c -inn (PChoiceF p s i ts) = PChoice p s i ts -inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts -inn (SChoiceF p s i b ts) = SChoice p s i b ts -inn (GoalChoiceF s ts) = GoalChoice s ts -inn (DoneF x s ) = Done x s -inn (FailF c x ) = Fail c x +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +inn (DoneF x s) = Done x s +inn (FailF c x) = Fail c x innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) -innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) -innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) -innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) -innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) -innM (DoneF x s ) = return $ Done x s -innM (FailF c x ) = return $ Fail c x +innM (PChoiceF p s i ts) = liftM (PChoice p s i) (sequence ts) +innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) +innM (SChoiceF p s i b ts) = liftM (SChoice p s i b) (sequence ts) +innM (GoalChoiceF s ts) = liftM (GoalChoice s) (sequence ts) +innM (DoneF x s) = return $ Done x s +innM (FailF c x) = return $ Fail c x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree d c -> Bool active (Fail _ _) = False -active _ = True +active _ = True -- | Approximates the number of active choices that are available in a node. -- Note that we count goal choices as having one choice, always. zeroOrOneChoices :: Tree d c -> Bool -zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (GoalChoice _ _ ) = True -zeroOrOneChoices (Done _ _ ) = True -zeroOrOneChoices (Fail _ _ ) = True +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _) = True +zeroOrOneChoices (Done _ _) = True +zeroOrOneChoices (Fail _ _) = True -- | Catamorphism on trees. cata :: (TreeF d c a -> a) -> Tree d c -> a @@ -197,7 +196,7 @@ trav psi x = cata (inn . psi) x -- | Paramorphism on trees. para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a -para phi = phi . fmap (\ x -> (para phi x, x)) . out +para phi = phi . fmap (\x -> (para phi x, x)) . out -- | Anamorphism on trees. ana :: (a -> TreeF d c a) -> a -> Tree d c diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index 54911f2c367..c362415cbb1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} #ifdef DEBUG_CONFLICT_SETS {-# LANGUAGE ImplicitParams #-} #endif @@ -12,8 +12,8 @@ module Distribution.Solver.Modular.Validate (validateTree) where -- assignment returned by exploration of the tree should be a complete valid -- assignment, i.e., actually constitute a solution. -import Control.Monad (foldM, mzero, liftM2) -import Control.Monad.Reader (MonadReader, Reader, runReader, local, asks) +import Control.Monad (foldM, liftM2, mzero) +import Control.Monad.Reader (MonadReader, Reader, asks, local, runReader) import Data.Either (lefts) import Data.Function (on) @@ -23,7 +23,7 @@ import qualified Data.Set as S import Language.Haskell.Extension (Extension, Language) import Data.Map.Strict as M -import Distribution.Compiler (CompilerInfo(..)) +import Distribution.Compiler (CompilerInfo (..)) import Distribution.Solver.Modular.Assignment import qualified Distribution.Solver.Modular.ConflictSet as CS @@ -95,31 +95,26 @@ import GHC.Stack (CallStack) -- check if we've chosen them already and either proceed or stop. -- | The state needed during validation. -data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, - index :: Index, - - -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, - -- it qualifies the package's dependencies and saves them in this map. Then - -- the qualified dependencies are available for subsequent flag and stanza - -- choices for the same package. - saved :: Map QPN (FlaggedDeps QPN), - - pa :: PreAssignment, - - -- Map from package name to the components that are provided by the chosen - -- instance of that package, and whether those components are visible and - -- buildable. - availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), - - -- Map from package name to the components that are required from that - -- package. - requiredComponents :: Map QPN ComponentDependencyReasons, - - qualifyOptions :: QualifyOptions -} +data ValidateState = VS + { supportedExt :: Extension -> Bool + , supportedLang :: Language -> Bool + , presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool + , index :: Index + , -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, + -- it qualifies the package's dependencies and saves them in this map. Then + -- the qualified dependencies are available for subsequent flag and stanza + -- choices for the same package. + saved :: Map QPN (FlaggedDeps QPN) + , pa :: PreAssignment + , -- Map from package name to the components that are provided by the chosen + -- instance of that package, and whether those components are visible and + -- buildable. + availableComponents :: Map QPN (Map ExposedComponent ComponentInfo) + , -- Map from package name to the components that are required from that + -- package. + requiredComponents :: Map QPN ComponentDependencyReasons + , qualifyOptions :: QualifyOptions + } newtype Validate a = Validate (Reader ValidateState a) deriving (Functor, Applicative, Monad, MonadReader ValidateState) @@ -151,8 +146,8 @@ type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) -- It is important to store the component name with the version constraint, for -- error messages, because whether something is a build-tool dependency affects -- its qualifier, which affects which constraint is applied. -data MergedPkgDep = - MergedDepFixed ExposedComponent (DependencyReason QPN) I +data MergedPkgDep + = MergedDepFixed ExposedComponent (DependencyReason QPN) I | MergedDepConstrained [VROrigin] -- | Version ranges paired with origins. @@ -166,7 +161,7 @@ validate = go where go :: Tree d c -> Validate (Tree d c) - go (PChoice qpn rdm gr ts) = PChoice qpn rdm gr <$> W.traverseWithKey (\k -> goP qpn k . go) ts + go (PChoice qpn rdm gr ts) = PChoice qpn rdm gr <$> W.traverseWithKey (\k -> goP qpn k . go) ts go (FChoice qfn rdm gr b m d ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints @@ -174,41 +169,45 @@ validate = go -- collapse repeated flag choice nodes. PA _ pfa _ <- asks pa -- obtain current flag-preassignment case M.lookup qfn pfa of - Just rb -> -- flag has already been assigned; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goF qfn rb (go t) - Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) - Nothing -> -- flag choice is new, follow both branches - FChoice qfn rdm gr b m d <$> W.traverseWithKey (\k -> goF qfn k . go) ts - go (SChoice qsn rdm gr b ts) = + Just rb -> + -- flag has already been assigned; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goF qfn rb (go t) + Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) + Nothing -> + -- flag choice is new, follow both branches + FChoice qfn rdm gr b m d <$> W.traverseWithKey (\k -> goF qfn k . go) ts + go (SChoice qsn rdm gr b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment case M.lookup qsn psa of - Just rb -> -- stanza choice has already been made; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goS qsn rb (go t) - Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) - Nothing -> -- stanza choice is new, follow both branches - SChoice qsn rdm gr b <$> W.traverseWithKey (\k -> goS qsn k . go) ts + Just rb -> + -- stanza choice has already been made; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goS qsn rb (go t) + Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) + Nothing -> + -- stanza choice is new, follow both branches + SChoice qsn rdm gr b <$> W.traverseWithKey (\k -> goS qsn k . go) ts -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoice rdm ts) = GoalChoice rdm <$> traverse go ts - go (Done rdm s ) = pure (Done rdm s) - go (Fail c fr ) = pure (Fail c fr) + go (GoalChoice rdm ts) = GoalChoice rdm <$> traverse go ts + go (Done rdm s) = pure (Done rdm s) + go (Fail c fr) = pure (Fail c fr) -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) (POption i _) r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - idx <- asks index -- obtain the index - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - qo <- asks qualifyOptions + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope @@ -217,13 +216,15 @@ validate = go -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent newactives - =<< extendWithPackageChoice (PI qpn i) ppa + let mnppa = + extend extSupported langSupported pkgPresent newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of - Just fr -> -- The index marks this as an invalid choice. We can stop. - return (Fail (varToConflictSet (P qpn)) fr) + Just fr -> + -- The index marks this as an invalid choice. We can stop. + return (Fail (varToConflictSet (P qpn)) fr) Nothing -> let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) newDeps = do @@ -231,26 +232,33 @@ validate = go rComps' <- extendRequiredComponents qpn aComps rComps newactives checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps return (nppa, rComps') - in case newDeps of - Left (c, fr) -> -- We have an inconsistency. We can stop. - return (Fail c fr) - Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa - , saved = nsvd - , availableComponents = M.insert qpn comps aComps - , requiredComponents = rComps' - }) r + in case newDeps of + Left (c, fr) -> + -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rComps') -> + -- We have an updated partial assignment for the recursive validation. + local + ( \s -> + s + { pa = PA nppa pfa psa + , saved = nsvd + , availableComponents = M.insert qpn comps aComps + , requiredComponents = rComps' + } + ) + r -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goF qfn@(FN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -267,20 +275,20 @@ validate = go -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found + Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r + local (\s -> s{pa = PA nppa npfa psa, requiredComponents = rComps'}) r -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goS qsn@(SN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -297,41 +305,46 @@ validate = go -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found + Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r + local (\s -> s{pa = PA nppa pfa npsa, requiredComponents = rComps'}) r -- | Check that a newly chosen package instance contains all components that -- are required from that package so far. The components must also be visible -- and buildable. -checkComponentsInNewPackage :: ComponentDependencyReasons - -> QPN - -> Map ExposedComponent ComponentInfo - -> Either Conflict () +checkComponentsInNewPackage + :: ComponentDependencyReasons + -> QPN + -> Map ExposedComponent ComponentInfo + -> Either Conflict () checkComponentsInNewPackage required qpn providedComps = - case M.toList $ deleteKeys (M.keys providedComps) required of - (missingComp, dr) : _ -> - Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent - [] -> - let failures = lefts - [ case () of - _ | compIsVisible compInfo == IsVisible False -> - Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent - | otherwise -> Right () - | let merged = M.intersectionWith (,) required providedComps - , (comp, (dr, compInfo)) <- M.toList merged ] - in case failures of - failure : _ -> Left failure - [] -> Right () + case M.toList $ deleteKeys (M.keys providedComps) required of + (missingComp, dr) : _ -> + Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent + [] -> + let failures = + lefts + [ case () of + _ + | compIsVisible compInfo == IsVisible False -> + Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent + | otherwise -> Right () + | let merged = M.intersectionWith (,) required providedComps + , (comp, (dr, compInfo)) <- M.toList merged + ] + in case failures of + failure : _ -> Left failure + [] -> Right () where - mkConflict :: ExposedComponent - -> DependencyReason QPN - -> (ExposedComponent -> DependencyReason QPN -> FailReason) - -> Conflict + mkConflict + :: ExposedComponent + -> DependencyReason QPN + -> (ExposedComponent -> DependencyReason QPN -> FailReason) + -> Conflict mkConflict comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) deleteKeys :: Ord k => [k] -> Map k v -> Map k v deleteKeys ks m = L.foldr M.delete m ks @@ -343,15 +356,15 @@ extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractAllDeps fa sa deps = do d <- deps case d of - Simple sd _ -> return sd + Simple sd _ -> return sd Flagged qfn _ td fd -> case M.lookup qfn fa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> extractAllDeps fa sa fd - Stanza qsn td -> case M.lookup qsn sa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> [] + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> extractAllDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> [] -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call @@ -363,19 +376,19 @@ extractNewDeps v b fa sa = go go deps = do d <- deps case d of - Simple _ _ -> mzero + Simple _ _ -> mzero Flagged qfn' _ td fd - | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd - | otherwise -> case M.lookup qfn' fa of - Nothing -> mzero - Just True -> go td - Just False -> go fd + | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd Stanza qsn' td - | v == S qsn' -> if b then extractAllDeps fa sa td else [] - | otherwise -> case M.lookup qsn' sa of - Nothing -> mzero - Just True -> go td - Just False -> [] + | v == S qsn' -> if b then extractAllDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] -- | Extend a package preassignment. -- @@ -389,30 +402,36 @@ extractNewDeps v b fa sa = go -- -- Either returns a witness of the conflict that would arise during the merge, -- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> [LDep QPN] - -> PPreAssignment - -> Either Conflict PPreAssignment +extend + :: (Extension -> Bool) + -- ^ is a given extension supported + -> (Language -> Bool) + -- ^ is a given language supported + -> (PkgconfigName -> PkgconfigVersionRange -> Bool) + -- ^ is a given pkg-config requirement satisfiable + -> [LDep QPN] + -> PPreAssignment + -> Either Conflict PPreAssignment extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives where - extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment - extendSingle a (LDep dr (Ext ext )) = - if extSupported ext then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) - extendSingle a (LDep dr (Lang lang)) = - if langSupported lang then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) - extendSingle a (LDep dr (Pkg pn vr)) = - if pkgPresent pn vr then Right a - else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) + extendSingle a (LDep dr (Ext ext)) = + if extSupported ext + then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) + extendSingle a (LDep dr (Lang lang)) = + if langSupported lang + then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) + extendSingle a (LDep dr (Pkg pn vr)) = + if pkgPresent pn vr + then Right a + else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of + in case (\x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') - Right x -> Right x + Right x -> Right x -- | Extend a package preassignment with a package choice. For example, when -- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. @@ -424,14 +443,17 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment extendWithPackageChoice (PI qpn i) ppa = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa - newChoice = PkgDep (DependencyReason qpn M.empty S.empty) - (PkgComponent qpn (ExposedLib LMainLibName)) - (Fixed i) - in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of - Left (c, (d, _d')) -> -- Don't include the package choice in the - -- FailReason, because it is redundant. - Left (c, NewPackageDoesNotMatchExistingConstraint d) - Right x -> Right x + newChoice = + PkgDep + (DependencyReason qpn M.empty S.empty) + (PkgComponent qpn (ExposedLib LMainLibName)) + (Fixed i) + in case (\x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of + Left (c, (d, _d')) -> + -- Don't include the package choice in the + -- FailReason, because it is redundant. + Left (c, NewPackageDoesNotMatchExistingConstraint d) + Right x -> Right x -- | Merge constrained instances. We currently adopt a lazy strategy for -- merging, i.e., we only perform actual checking if one of the two choices @@ -450,6 +472,7 @@ extendWithPackageChoice (PI qpn i) ppa = -- set in the sense the it contains variables that allow us to backjump -- further. We might apply some heuristics here, such as to change the -- order in which we check the constraints. +{- FOURMOLU_DISABLE -} merge :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => @@ -488,104 +511,120 @@ merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Const -- before a refactoring. Consider prepending the version range, if there is -- no negative performance impact. vrOrigins ++ [(vr, comp2, vs2)]) +{- FOURMOLU_ENABLE -} -- | Creates a conflict set representing a conflict between a version constraint -- and the fixed version chosen for a package. -createConflictSetForVersionConflict :: QPN - -> Ver - -> DependencyReason QPN - -> VR - -> DependencyReason QPN - -> ConflictSet -createConflictSetForVersionConflict pkg - conflictingVersion - versionDR@(DependencyReason p1 _ _) - conflictingVersionRange - versionRangeDR@(DependencyReason p2 _ _) = - let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) - in - -- The solver currently only optimizes the case where there is a conflict - -- between the version chosen for a package and a version constraint that - -- is not under any flags or stanzas. Here is how we check for this case: - -- - -- (1) Choosing a specific version for a package foo is implemented as - -- adding a dependency from foo to that version of foo (See - -- extendWithPackageChoice), so we check that the DependencyReason - -- contains the current package and no flag or stanza choices. - -- - -- (2) We check that the DependencyReason for the version constraint also - -- contains no flag or stanza choices. - -- - -- When these criteria are not met, we fall back to calling - -- dependencyReasonToConflictSet. - if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) - then let cs1 = dependencyReasonToConflictSetWithVersionConflict - p2 - (CS.OrderedVersionRange conflictingVersionRange) - versionDR - cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict - pkg conflictingVersion versionRangeDR - in cs1 `CS.union` cs2 - else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR +createConflictSetForVersionConflict + :: QPN + -> Ver + -> DependencyReason QPN + -> VR + -> DependencyReason QPN + -> ConflictSet +createConflictSetForVersionConflict + pkg + conflictingVersion + versionDR@(DependencyReason p1 _ _) + conflictingVersionRange + versionRangeDR@(DependencyReason p2 _ _) = + let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) + in -- The solver currently only optimizes the case where there is a conflict + -- between the version chosen for a package and a version constraint that + -- is not under any flags or stanzas. Here is how we check for this case: + -- + -- (1) Choosing a specific version for a package foo is implemented as + -- adding a dependency from foo to that version of foo (See + -- extendWithPackageChoice), so we check that the DependencyReason + -- contains the current package and no flag or stanza choices. + -- + -- (2) We check that the DependencyReason for the version constraint also + -- contains no flag or stanza choices. + -- + -- When these criteria are not met, we fall back to calling + -- dependencyReasonToConflictSet. + if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) + then + let cs1 = + dependencyReasonToConflictSetWithVersionConflict + p2 + (CS.OrderedVersionRange conflictingVersionRange) + versionDR + cs2 = + dependencyReasonToConflictSetWithVersionConstraintConflict + pkg + conflictingVersion + versionRangeDR + in cs1 `CS.union` cs2 + else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency -- requires a component that is missing, private, or unbuildable in a previously -- chosen package. -extendRequiredComponents :: QPN -- ^ package we extend - -> Map QPN (Map ExposedComponent ComponentInfo) - -> Map QPN ComponentDependencyReasons - -> [LDep QPN] - -> Either Conflict (Map QPN ComponentDependencyReasons) +extendRequiredComponents + :: QPN + -- ^ package we extend + -> Map QPN (Map ExposedComponent ComponentInfo) + -> Map QPN ComponentDependencyReasons + -> [LDep QPN] + -> Either Conflict (Map QPN ComponentDependencyReasons) extendRequiredComponents eqpn available = foldM extendSingle where - extendSingle :: Map QPN ComponentDependencyReasons - -> LDep QPN - -> Either Conflict (Map QPN ComponentDependencyReasons) + extendSingle + :: Map QPN ComponentDependencyReasons + -> LDep QPN + -> Either Conflict (Map QPN ComponentDependencyReasons) extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = let compDeps = M.findWithDefault M.empty qpn required success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required - in -- Only check for the existence of the component if its package has - -- already been chosen. - case M.lookup qpn available of - Just comps -> - case M.lookup comp comps of - Nothing -> - Left $ mkConflict qpn comp dr PackageRequiresMissingComponent - Just compInfo - | compIsVisible compInfo == IsVisible False - , eqpn /= qpn -- package components can depend on other components - -> - Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent - | otherwise -> success - Nothing -> success - extendSingle required _ = Right required - - mkConflict :: QPN - -> ExposedComponent - -> DependencyReason QPN - -> (QPN -> ExposedComponent -> FailReason) - -> Conflict + in -- Only check for the existence of the component if its package has + -- already been chosen. + case M.lookup qpn available of + Just comps -> + case M.lookup comp comps of + Nothing -> + Left $ mkConflict qpn comp dr PackageRequiresMissingComponent + Just compInfo + | compIsVisible compInfo == IsVisible False + , eqpn /= qpn -> -- package components can depend on other components + Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent + | otherwise -> success + Nothing -> success + extendSingle required _ = Right required + + mkConflict + :: QPN + -> ExposedComponent + -> DependencyReason QPN + -> (QPN -> ExposedComponent -> FailReason) + -> Conflict mkConflict qpn comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) - -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c -validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in \ x -> S.member x s) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb - , index = idx - , saved = M.empty - , pa = PA M.empty M.empty M.empty - , availableComponents = M.empty - , requiredComponents = M.empty - , qualifyOptions = defaultQualifyOptions idx - } +validateTree cinfo idx pkgConfigDb t = + runValidate + (validate t) + VS + { supportedExt = + maybe + (const True) -- if compiler has no list of extensions, we assume everything is supported + (\es -> let s = S.fromList es in \x -> S.member x s) + (compilerInfoExtensions cinfo) + , supportedLang = + maybe + (const True) + (flip L.elem) -- use list lookup because language list is small and no Ord instance + (compilerInfoLanguages cinfo) + , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb + , index = idx + , saved = M.empty + , pa = PA M.empty M.empty M.empty + , availableComponents = M.empty + , requiredComponents = M.empty + , qualifyOptions = defaultQualifyOptions idx + } diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs index c3284f1c18e..d6514ddf512 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Var ( - Var(..) + +module Distribution.Solver.Modular.Var + ( Var (..) , showVar , varPN ) where @@ -29,6 +30,6 @@ showVar (S qsn) = showQSN qsn -- | Extract the package name from a Var varPN :: Var qpn -> qpn -varPN (P qpn) = qpn +varPN (P qpn) = qpn varPN (F (FN qpn _)) = qpn varPN (S (SN qpn _)) = qpn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs index 695a90aea99..ddd02b0c803 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs @@ -1,21 +1,22 @@ module Distribution.Solver.Modular.Version - ( Ver - , VR - , anyVR - , checkVR - , eqVR - , showVer - , showVR - , simplifyVR - , (.&&.) - , (.||.) - ) where + ( Ver + , VR + , anyVR + , checkVR + , eqVR + , showVer + , showVR + , simplifyVR + , (.&&.) + , (.||.) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import qualified Distribution.Version as CV -- from Cabal +-- from Cabal import Distribution.Pretty (prettyShow) +import qualified Distribution.Version as CV -- | Preliminary type for versions. type Ver = CV.Version diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs index ec9b242bda9..3d1e83fec6c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Distribution.Solver.Modular.WeightedPSQ ( - WeightedPSQ + +module Distribution.Solver.Modular.WeightedPSQ + ( WeightedPSQ , fromList , toList , keys @@ -36,9 +39,9 @@ filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) -- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. isZeroOrOne :: WeightedPSQ w k v -> Bool -isZeroOrOne (WeightedPSQ []) = True +isZeroOrOne (WeightedPSQ []) = True isZeroOrOne (WeightedPSQ [_]) = True -isZeroOrOne _ = False +isZeroOrOne _ = False -- | /O(1)/. Return the elements in order. toList :: WeightedPSQ w k v -> [(w, k, v)] @@ -62,17 +65,20 @@ lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs -- | /O(N log N)/. Update the weights. -mapWeightsWithKey :: Ord w2 - => (k -> w1 -> w2) - -> WeightedPSQ w1 k v - -> WeightedPSQ w2 k v -mapWeightsWithKey f (WeightedPSQ xs) = fromList $ - L.map (\ (w, k, v) -> (f k w, k, v)) xs +mapWeightsWithKey + :: Ord w2 + => (k -> w1 -> w2) + -> WeightedPSQ w1 k v + -> WeightedPSQ w2 k v +mapWeightsWithKey f (WeightedPSQ xs) = + fromList $ + L.map (\(w, k, v) -> (f k w, k, v)) xs -- | /O(N)/. Update the values. mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 -mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ - L.map (\ (w, k, v) -> (w, k, f k v)) xs +mapWithKey f (WeightedPSQ xs) = + WeightedPSQ $ + L.map (\(w, k, v) -> (w, k, f k v)) xs -- | /O(N)/. Traverse and update values in some applicative functor. traverseWithKey @@ -80,8 +86,9 @@ traverseWithKey => (k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v') -traverseWithKey f (WeightedPSQ q) = WeightedPSQ <$> - traverse (\(w,k,v) -> (w,k,) <$> f k v) q +traverseWithKey f (WeightedPSQ q) = + WeightedPSQ + <$> traverse (\(w, k, v) -> (w,k,) <$> f k v) q -- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all -- elements. Elements from the first @WeightedPSQ@ come before elements in the @@ -95,7 +102,7 @@ takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) where go :: [(w, k, v)] -> [(w, k, v)] - go [] = [] + go [] = [] go (y : ys) = y : if p (triple_3 y) then [] else go ys triple_1 :: (x, y, z) -> x diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs index 8926521673b..077a21ea469 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -11,12 +11,13 @@ -- > , ComponentDeps -- > ) -- > import qualified Distribution.Solver.Types.ComponentDeps as CD -module Distribution.Solver.Types.ComponentDeps ( - -- * Fine-grained package dependencies - Component(..) +module Distribution.Solver.Types.ComponentDeps + ( -- * Fine-grained package dependencies + Component (..) , componentNameToComponent , ComponentDep , ComponentDeps -- opaque + -- ** Constructing ComponentDeps , empty , fromList @@ -28,6 +29,7 @@ module Distribution.Solver.Types.ComponentDeps ( , fromLibraryDeps , fromSetupDeps , fromInstalled + -- ** Deconstructing ComponentDeps , toList , flatDeps @@ -38,31 +40,30 @@ module Distribution.Solver.Types.ComponentDeps ( , components ) where -import Prelude () +import Distribution.Solver.Compat.Prelude hiding (empty, toList, zip) import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) +import Prelude () -import qualified Data.Map as Map import Data.Foldable (fold) +import qualified Data.Map as Map import Distribution.Pretty (Pretty (..)) import qualified Distribution.Types.ComponentName as CN import qualified Distribution.Types.LibraryName as LN import qualified Text.PrettyPrint as PP - {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} -- | Component of a package. -data Component = - ComponentLib +data Component + = ComponentLib | ComponentSubLib UnqualComponentName - | ComponentFLib UnqualComponentName - | ComponentExe UnqualComponentName - | ComponentTest UnqualComponentName - | ComponentBench UnqualComponentName + | ComponentFLib UnqualComponentName + | ComponentExe UnqualComponentName + | ComponentTest UnqualComponentName + | ComponentBench UnqualComponentName | ComponentSetup deriving (Show, Eq, Ord, Generic) @@ -70,13 +71,13 @@ instance Binary Component instance Structured Component instance Pretty Component where - pretty ComponentLib = PP.text "lib" - pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n - pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n - pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n - pretty (ComponentTest n) = PP.text "test:" <<>> pretty n - pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n - pretty ComponentSetup = PP.text "setup" + pretty ComponentLib = PP.text "lib" + pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n + pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n + pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n + pretty (ComponentTest n) = PP.text "test:" <<>> pretty n + pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n + pretty ComponentSetup = PP.text "setup" -- | Dependency for a single component. type ComponentDep a = (Component, a) @@ -85,8 +86,7 @@ type ComponentDep a = (Component, a) -- -- Typically used as @ComponentDeps [Dependency]@, to represent the list of -- dependencies for each named component within a package. --- -newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } +newtype ComponentDeps a = ComponentDeps {unComponentDeps :: Map Component a} deriving (Show, Functor, Eq, Ord, Generic) instance Semigroup a => Monoid (ComponentDeps a) where @@ -95,7 +95,7 @@ instance Semigroup a => Monoid (ComponentDeps a) where instance Semigroup a => Semigroup (ComponentDeps a) where ComponentDeps d <> ComponentDeps d' = - ComponentDeps (Map.unionWith (<>) d d') + ComponentDeps (Map.unionWith (<>) d d') instance Foldable ComponentDeps where foldMap f = foldMap f . unComponentDeps @@ -107,12 +107,12 @@ instance Binary a => Binary (ComponentDeps a) instance Structured a => Structured (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component -componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib +componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s -componentNameToComponent (CN.CFLibName s) = ComponentFLib s -componentNameToComponent (CN.CExeName s) = ComponentExe s -componentNameToComponent (CN.CTestName s) = ComponentTest s -componentNameToComponent (CN.CBenchName s) = ComponentBench s +componentNameToComponent (CN.CFLibName s) = ComponentFLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s {------------------------------------------------------------------------------- Construction @@ -130,21 +130,24 @@ singleton comp = ComponentDeps . Map.singleton comp insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps where - aux Nothing = Just a + aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip :: (Monoid a, Monoid b) - => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) + => ComponentDeps a + -> ComponentDeps b + -> ComponentDeps (a, b) zip (ComponentDeps d1) (ComponentDeps d2) = - ComponentDeps $ - Map.mergeWithKey - (\_ a b -> Just (a,b)) - (fmap (\a -> (a, mempty))) - (fmap (\b -> (mempty, b))) - d1 d2 + ComponentDeps $ + Map.mergeWithKey + (\_ a b -> Just (a, b)) + (fmap (\a -> (a, mempty))) + (fmap (\b -> (mempty, b))) + d1 + d2 -- | Keep only selected components (and their associated deps info). filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a @@ -193,9 +196,13 @@ nonSetupDeps = select (/= ComponentSetup) -- | Library dependencies proper only. (Includes dependencies -- of internal libraries.) libraryDeps :: Monoid a => ComponentDeps a -> a -libraryDeps = select (\c -> case c of ComponentSubLib _ -> True - ComponentLib -> True - _ -> False) +libraryDeps = + select + ( \c -> case c of + ComponentSubLib _ -> True + ComponentLib -> True + _ -> False + ) -- | List components components :: ComponentDeps a -> Set Component diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index 7d821257234..ead12f75931 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -1,55 +1,44 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) - , showConstraintSource - ) where + ( ConstraintSource (..) + , showConstraintSource + ) where import Distribution.Solver.Compat.Prelude import Prelude () -- | Source of a 'PackageConstraint'. -data ConstraintSource = - - -- | Main config file, which is ~/.cabal/config by default. - ConstraintSourceMainConfig FilePath - - -- | Local cabal.project file - | ConstraintSourceProjectConfig FilePath - - -- | User config file, which is ./cabal.config by default. - | ConstraintSourceUserConfig FilePath - - -- | Flag specified on the command line. - | ConstraintSourceCommandlineFlag - - -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ - -- implies @package==0.1.0.0@. - | ConstraintSourceUserTarget - - -- | Internal requirement to use installed versions of packages like ghc-prim. - | ConstraintSourceNonUpgradeablePackage - - -- | Internal constraint used by @cabal freeze@. - | ConstraintSourceFreeze - - -- | Constraint specified by a config file, a command line flag, or a user - -- target, when a more specific source is not known. - | ConstraintSourceConfigFlagOrTarget - - -- | Constraint introduced by --enable-multi-repl, which requires features - -- from Cabal >= 3.11 - | ConstraintSourceMultiRepl - - -- | The source of the constraint is not specified. - | ConstraintSourceUnknown - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a minimum lower bound on Cabal - | ConstraintSetupCabalMinVersion - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a maximum upper bound on Cabal - | ConstraintSetupCabalMaxVersion +data ConstraintSource + = -- | Main config file, which is ~/.cabal/config by default. + ConstraintSourceMainConfig FilePath + | -- | Local cabal.project file + ConstraintSourceProjectConfig FilePath + | -- | User config file, which is ./cabal.config by default. + ConstraintSourceUserConfig FilePath + | -- | Flag specified on the command line. + ConstraintSourceCommandlineFlag + | -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ + -- implies @package==0.1.0.0@. + ConstraintSourceUserTarget + | -- | Internal requirement to use installed versions of packages like ghc-prim. + ConstraintSourceNonUpgradeablePackage + | -- | Internal constraint used by @cabal freeze@. + ConstraintSourceFreeze + | -- | Constraint specified by a config file, a command line flag, or a user + -- target, when a more specific source is not known. + ConstraintSourceConfigFlagOrTarget + | -- | Constraint introduced by --enable-multi-repl, which requires features + -- from Cabal >= 3.11 + ConstraintSourceMultiRepl + | -- | The source of the constraint is not specified. + ConstraintSourceUnknown + | -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a minimum lower bound on Cabal + ConstraintSetupCabalMinVersion + | -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a maximum upper bound on Cabal + ConstraintSetupCabalMaxVersion deriving (Eq, Show, Generic) instance Binary ConstraintSource @@ -58,21 +47,21 @@ instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path + "main config " ++ path showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ path -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path + "project config " ++ path +showConstraintSource (ConstraintSourceUserConfig path) = "user config " ++ path showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" showConstraintSource ConstraintSourceUserTarget = "user target" showConstraintSource ConstraintSourceNonUpgradeablePackage = - "non-upgradeable package" + "non-upgradeable package" showConstraintSource ConstraintSourceFreeze = "cabal freeze" showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" + "config file, command line flag, or user target" showConstraintSource ConstraintSourceMultiRepl = - "--enable-multi-repl" + "--enable-multi-repl" showConstraintSource ConstraintSourceUnknown = "unknown source" showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" + "minimum version of Cabal used by Setup.hs" showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" + "maximum version of Cabal used by Setup.hs" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index e773492ae74..17345bbcd44 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -1,22 +1,22 @@ module Distribution.Solver.Types.DependencyResolver - ( DependencyResolver - ) where + ( DependencyResolver + ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) +import Distribution.Solver.Types.PackageIndex (PackageIndex) import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SourcePackage -import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) -import Distribution.Package ( PackageName ) -import Distribution.Compiler ( CompilerInfo ) -import Distribution.System ( Platform ) +import Distribution.Compiler (CompilerInfo) +import Distribution.Package (PackageName) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.System (Platform) -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to @@ -25,13 +25,13 @@ import Distribution.System ( Platform ) -- The reason for this interface is because there are dozens of approaches to -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. --- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex - -> PackageIndex (SourcePackage loc) - -> PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> Set PackageName - -> Progress String String [ResolverPackage loc] +type DependencyResolver loc = + Platform + -> CompilerInfo + -> InstalledPackageIndex + -> PackageIndex (SourcePackage loc) + -> PkgConfigDb + -> (PackageName -> PackagePreferences) + -> [LabeledPackageConstraint] + -> Set PackageName + -> Progress String String [ResolverPackage loc] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs index 18ce1df3243..89d7ce2937d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs @@ -1,6 +1,6 @@ module Distribution.Solver.Types.Flag - ( FlagType(..) - ) where + ( FlagType (..) + ) where import Prelude (Eq, Show) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs index 871a0dd15a9..398ed6c42b8 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -1,39 +1,40 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Types.InstSolverPackage - ( InstSolverPackage(..) - ) where + ( InstSolverPackage (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Package (HasMungedPackageId (..), HasUnitId (..), Package (..)) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.SolverId import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId import Distribution.Types.MungedPackageName -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Types.PackageId -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. -data InstSolverPackage = InstSolverPackage { - instSolverPkgIPI :: InstalledPackageInfo, - instSolverPkgLibDeps :: ComponentDeps [SolverId], - instSolverPkgExeDeps :: ComponentDeps [SolverId] - } +data InstSolverPackage = InstSolverPackage + { instSolverPkgIPI :: InstalledPackageInfo + , instSolverPkgLibDeps :: ComponentDeps [SolverId] + , instSolverPkgExeDeps :: ComponentDeps [SolverId] + } deriving (Eq, Show, Generic) instance Binary InstSolverPackage instance Structured InstSolverPackage instance Package InstSolverPackage where - packageId i = - -- HACK! See Note [Index conversion with internal libraries] - let MungedPackageId mpn v = mungedId i - in PackageIdentifier (encodeCompatPackageName mpn) v + packageId i = + -- HACK! See Note [Index conversion with internal libraries] + let MungedPackageId mpn v = mungedId i + in PackageIdentifier (encodeCompatPackageName mpn) v instance HasMungedPackageId InstSolverPackage where - mungedId = mungedId . instSolverPkgIPI + mungedId = mungedId . instSolverPkgIPI instance HasUnitId InstSolverPackage where - installedUnitId = installedUnitId . instSolverPkgIPI + installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs index 7aa7215a8fb..6acd39ad6fc 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs @@ -1,11 +1,10 @@ module Distribution.Solver.Types.InstalledPreference - ( InstalledPreference(..), - ) where + ( InstalledPreference (..) + ) where import Prelude (Show) -- | Whether we prefer an installed version of a package or simply the latest -- version. --- data InstalledPreference = PreferInstalled | PreferLatest | PreferOldest - deriving Show + deriving (Show) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs index 8715e46fd22..b76566c4f29 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -1,14 +1,14 @@ module Distribution.Solver.Types.LabeledPackageConstraint - ( LabeledPackageConstraint(..) - , unlabelPackageConstraint - ) where + ( LabeledPackageConstraint (..) + , unlabelPackageConstraint + ) where import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint -- | 'PackageConstraint' labeled with its source. data LabeledPackageConstraint - = LabeledPackageConstraint PackageConstraint ConstraintSource + = LabeledPackageConstraint PackageConstraint ConstraintSource unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs b/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs index cde029d195b..788173b6a1b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs @@ -1,33 +1,36 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.OptionalStanza ( - -- * OptionalStanza - OptionalStanza(..), - showStanza, - showStanzas, - enableStanzas, +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Solver.Types.OptionalStanza + ( -- * OptionalStanza + OptionalStanza (..) + , showStanza + , showStanzas + , enableStanzas + -- * Set of stanzas - OptionalStanzaSet, - optStanzaSetFromList, - optStanzaSetToList, - optStanzaSetMember, - optStanzaSetInsert, - optStanzaSetSingleton, - optStanzaSetIntersection, - optStanzaSetNull, - optStanzaSetIsSubset, + , OptionalStanzaSet + , optStanzaSetFromList + , optStanzaSetToList + , optStanzaSetMember + , optStanzaSetInsert + , optStanzaSetSingleton + , optStanzaSetIntersection + , optStanzaSetNull + , optStanzaSetIsSubset + -- * Map indexed by stanzas - OptionalStanzaMap, - optStanzaTabulate, - optStanzaIndex, - optStanzaLookup, - optStanzaKeysFilteredByValue, -) where + , OptionalStanzaMap + , optStanzaTabulate + , optStanzaIndex + , optStanzaLookup + , optStanzaKeysFilteredByValue + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Data.Bits (testBit, (.|.), (.&.)) +import Data.Bits (testBit, (.&.), (.|.)) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..)) import Distribution.Utils.Structured (Structured (..), nominalStructure) @@ -36,13 +39,13 @@ import Distribution.Utils.Structured (Structured (..), nominalStructure) ------------------------------------------------------------------------------- data OptionalStanza - = TestStanzas - | BenchStanzas + = TestStanzas + | BenchStanzas deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) -- | String representation of an OptionalStanza. showStanza :: OptionalStanza -> String -showStanza TestStanzas = "test" +showStanza TestStanzas = "test" showStanza BenchStanzas = "bench" showStanzas :: OptionalStanzaSet -> String @@ -50,10 +53,10 @@ showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList -- | Convert a list of 'OptionalStanza' into the corresponding -- Cabal's 'ComponentRequestedSpec' which records what components are enabled. --- enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec -enableStanzas optionalStanzas = ComponentRequestedSpec - { testsRequested = optStanzaSetMember TestStanzas optionalStanzas +enableStanzas optionalStanzas = + ComponentRequestedSpec + { testsRequested = optStanzaSetMember TestStanzas optionalStanzas , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas } @@ -68,11 +71,11 @@ newtype OptionalStanzaSet = OptionalStanzaSet Word deriving (Eq, Ord, Show) instance Binary OptionalStanzaSet where - put (OptionalStanzaSet w) = put w - get = fmap (OptionalStanzaSet . (.&. 0x03)) get + put (OptionalStanzaSet w) = put w + get = fmap (OptionalStanzaSet . (.&. 0x03)) get instance Structured OptionalStanzaSet where - structure = nominalStructure + structure = nominalStructure optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty @@ -88,11 +91,11 @@ optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet optStanzaSetInsert x s = optStanzaSetSingleton x <> s optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool -optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0 +optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0 optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1 optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet -optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1 +optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1 optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2 optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet @@ -105,11 +108,11 @@ optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b instance Semigroup OptionalStanzaSet where - OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b) + OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b) instance Monoid OptionalStanzaSet where - mempty = OptionalStanzaSet 0 - mappend = (<>) + mempty = OptionalStanzaSet 0 + mappend = (<>) ------------------------------------------------------------------------------- -- OptionalStanzaMap @@ -126,7 +129,7 @@ optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas) optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a -optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x +optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a @@ -134,5 +137,5 @@ optStanzaLookup = flip optStanzaIndex optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet optStanzaKeysFilteredByValue p (OptionalStanzaMap x y) - | p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1 - | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0 + | p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1 + | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0 diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index fbe56380e81..20054acac40 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -4,56 +4,54 @@ -- solver. Multiple constraints for each package can be given, though obviously -- it is possible to construct conflicting constraints (eg impossible version -- range or inconsistent flag assignment). --- -module Distribution.Solver.Types.PackageConstraint ( - ConstraintScope(..), - scopeToplevel, - scopeToPackageName, - constraintScopeMatches, - PackageProperty(..), - dispPackageProperty, - PackageConstraint(..), - dispPackageConstraint, - showPackageConstraint, - packageConstraintToDependency +module Distribution.Solver.Types.PackageConstraint + ( ConstraintScope (..) + , scopeToplevel + , scopeToPackageName + , constraintScopeMatches + , PackageProperty (..) + , dispPackageProperty + , PackageConstraint (..) + , dispPackageConstraint + , showPackageConstraint + , packageConstraintToDependency ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package (PackageName) -import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Pretty (flatStyle, pretty) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) -import Distribution.Version (VersionRange, simplifyVersionRange) +import Distribution.Version (VersionRange, simplifyVersionRange) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import qualified Text.PrettyPrint as Disp - -- | Determines to what packages and in what contexts a -- constraint applies. data ConstraintScope - -- | A scope that applies when the given package is used as a build target. - -- In other words, the scope applies iff a goal has a top-level qualifier - -- and its namespace matches the given package name. A namespace is - -- considered to match a package name when it is either the default - -- namespace (for --no-independent-goals) or it is an independent namespace - -- with the given package name (for --independent-goals). - - -- TODO: Try to generalize the ConstraintScopes once component-based - -- solving is implemented, and remove this special case for targets. - = ScopeTarget PackageName - -- | The package with the specified name and qualifier. - | ScopeQualified Qualifier PackageName - -- | The package with the specified name when it has a - -- setup qualifier. - | ScopeAnySetupQualifier PackageName - -- | The package with the specified name regardless of - -- qualifier. - | ScopeAnyQualifier PackageName + = -- TODO: Try to generalize the ConstraintScopes once component-based + -- solving is implemented, and remove this special case for targets. + + -- | A scope that applies when the given package is used as a build target. + -- In other words, the scope applies iff a goal has a top-level qualifier + -- and its namespace matches the given package name. A namespace is + -- considered to match a package name when it is either the default + -- namespace (for --no-independent-goals) or it is an independent namespace + -- with the given package name (for --independent-goals). + ScopeTarget PackageName + | -- | The package with the specified name and qualifier. + ScopeQualified Qualifier PackageName + | -- | The package with the specified name when it has a + -- setup qualifier. + ScopeAnySetupQualifier PackageName + | -- | The package with the specified name regardless of + -- qualifier. + ScopeAnyQualifier PackageName deriving (Eq, Show) -- | Constructor for a common use case: the constraint applies to @@ -73,13 +71,13 @@ constraintScopeMatches :: ConstraintScope -> QPN -> Bool constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = let namespaceMatches DefaultNamespace = True namespaceMatches (Independent namespacePn) = pn == namespacePn - in namespaceMatches ns && q == QualToplevel && pn == pn' + in namespaceMatches ns && q == QualToplevel && pn == pn' constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = - q == q' && pn == pn' + q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = let setup (PackagePath _ (QualSetup _)) = True - setup _ = False - in setup pp && pn == pn' + setup _ = False + in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' -- | Pretty-prints a constraint scope. @@ -91,11 +89,11 @@ dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. data PackageProperty - = PackagePropertyVersion VersionRange - | PackagePropertyInstalled - | PackagePropertySource - | PackagePropertyFlags FlagAssignment - | PackagePropertyStanzas [OptionalStanza] + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] deriving (Eq, Show, Generic) instance Binary PackageProperty @@ -104,10 +102,10 @@ instance Structured PackageProperty -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property @@ -123,7 +121,6 @@ dispPackageConstraint (PackageConstraint scope prop) = -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that -- produced by 'dispPackageConstraint'). --- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 @@ -142,7 +139,7 @@ packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstr packageConstraintToDependency (PackageConstraint scope prop) = toDep prop where toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr - toDep (PackagePropertyInstalled) = Nothing - toDep (PackagePropertySource) = Nothing - toDep (PackagePropertyFlags _) = Nothing - toDep (PackagePropertyStanzas _) = Nothing + toDep (PackagePropertyInstalled) = Nothing + toDep (PackagePropertySource) = Nothing + toDep (PackagePropertyFlags _) = Nothing + toDep (PackagePropertyStanzas _) = Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs index 1031c42127d..7f4035b17b2 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs @@ -1,11 +1,14 @@ module Distribution.Solver.Types.PackageFixedDeps - ( PackageFixedDeps(..) - ) where + ( PackageFixedDeps (..) + ) where -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Package - ( Package(..), UnitId, installedDepends) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Package + ( Package (..) + , UnitId + , installedDepends + ) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD -- | Subclass of packages that have specific versioned dependencies. @@ -14,10 +17,8 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD -- ranges, not specific versions. A configured or an already installed package -- depends on exact versions. Some operations or data structures (like -- dependency graphs) only make sense on this subclass of package types. --- class Package pkg => PackageFixedDeps pkg where depends :: pkg -> ComponentDeps [UnitId] instance PackageFixedDeps InstalledPackageInfo where depends pkg = CD.fromInstalled (installedDepends pkg) - diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs index 6106f61c3b3..83a0a75388a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Solver.Types.PackageIndex -- Copyright : (c) David Himmelstrup 2005, @@ -11,83 +13,91 @@ -- Portability : portable -- -- An index of packages. --- -module Distribution.Solver.Types.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - override, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - elemByPackageId, - elemByPackageName, - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, - - -- ** Bulk queries - allPackages, - allPackagesByName, +module Distribution.Solver.Types.PackageIndex + ( -- * Package index data type + PackageIndex + + -- * Creating an index + , fromList + + -- * Updates + , merge + , override + , insert + , deletePackageName + , deletePackageId + , deleteDependency + + -- * Queries + + -- ** Precise lookups + , elemByPackageId + , elemByPackageName + , lookupPackageName + , lookupPackageId + , lookupDependency + + -- ** Case-insensitive searches + , searchByName + , SearchResult (..) + , searchByNameSubstring + , searchWithPredicate + + -- ** Bulk queries + , allPackages + , allPackagesByName ) where -import Prelude () import Distribution.Solver.Compat.Prelude hiding (lookup) +import Prelude () -import qualified Data.Map as Map import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map -import Distribution.Client.Utils.Assertion ( expensiveAssert ) +import Distribution.Client.Utils.Assertion (expensiveAssert) import Distribution.Package - ( PackageName, unPackageName, PackageIdentifier(..) - , Package(..), packageName, packageVersion ) -import Distribution.Version - ( VersionRange, withinRange ) + ( Package (..) + , PackageIdentifier (..) + , PackageName + , packageName + , packageVersion + , unPackageName + ) import Distribution.Simple.Utils - ( lowercase ) + ( lowercase + ) +import Distribution.Version + ( VersionRange + , withinRange + ) import qualified Prelude (foldr1) -- | The collection of information about packages from one or more 'PackageDB's. -- -- It can be searched efficiently by package name and version. --- -newtype PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - +newtype PackageIndex pkg + = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) deriving (Eq, Show, Read, Functor, Generic) ---FIXME: the Functor instance here relies on no package id changes + +-- FIXME: the Functor instance here relies on no package id changes instance Package pkg => Semigroup (PackageIndex pkg) where (<>) = merge instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex Map.empty + mempty = PackageIndex Map.empty mappend = (<>) - --save one mappend with empty in the common case: + + -- save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = Prelude.foldr1 mappend xs @@ -96,86 +106,94 @@ instance Binary pkg => Binary (PackageIndex pkg) invariant :: Package pkg => PackageIndex pkg -> Bool invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + goodBucket _ [] = False + goodBucket name (pkg0 : pkgs0) = check (packageId pkg0) pkgs0 where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' + check pkgid [] = packageName pkgid == name + check pkgid (pkg' : pkgs) = + packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where + pkgid' = packageId pkg' -- + -- * Internal helpers + -- mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = expensiveAssert (invariant (PackageIndex index)) - (PackageIndex index) +mkPackageIndex index = + expensiveAssert + (invariant (PackageIndex index)) + (PackageIndex index) internalError :: String -> a internalError name = error ("PackageIndex." ++ name ++ ": internal error") -- | Lookup a name in the index to get all packages that match that name -- case-sensitively. --- lookup :: PackageIndex pkg -> PackageName -> [pkg] lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m -- + -- * Construction + -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates, later ones mask earlier ones. --- fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] +fromList pkgs = + mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs + ] where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map NE.head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . NE.groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) + fixBucket = + -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map NE.head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . NE.groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) -- + -- * Updates + -- -- | Merge two indexes. -- -- Packages from the second mask packages of the same exact name -- (case-sensitively) from the first. --- merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg merge i1@(PackageIndex m1) i2@(PackageIndex m2) = expensiveAssert (invariant i1 && invariant i2) $ mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - -- | Elements in the second list mask those in the first. mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x : xs') ys@(y : ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys -- | Override-merge of two indexes. -- -- Packages from the second mask packages of the same exact name -- (case-sensitively) from the first. --- override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg override i1@(PackageIndex m1) i2@(PackageIndex m2) = expensiveAssert (invariant i1 && invariant i2) $ @@ -185,69 +203,83 @@ override i1@(PackageIndex m1) i2@(PackageIndex m2) = -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. --- insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index +insert pkg (PackageIndex index) = + mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index where pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg' : pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' GT -> pkg' : insertNoDup pkgs' -- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg - -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index +delete + :: Package pkg + => PackageName + -> (pkg -> Bool) + -> PackageIndex pkg + -> PackageIndex pkg +delete name p (PackageIndex index) = + mkPackageIndex $ + Map.update filterBucket name index where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing + filterBucket = + deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing deleteEmptyBucket remaining = Just remaining -- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg - -> PackageIndex pkg +deletePackageId + :: Package pkg + => PackageIdentifier + -> PackageIndex pkg + -> PackageIndex pkg deletePackageId pkgid = delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) -- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg - -> PackageIndex pkg +deletePackageName + :: Package pkg + => PackageName + -> PackageIndex pkg + -> PackageIndex pkg deletePackageName name = delete name (\pkg -> packageName pkg == name) -- | Removes all packages satisfying this dependency from the index. -deleteDependency :: Package pkg - => PackageName -> VersionRange -> PackageIndex pkg - -> PackageIndex pkg +deleteDependency + :: Package pkg + => PackageName + -> VersionRange + -> PackageIndex pkg + -> PackageIndex pkg deleteDependency name verstionRange = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) -- + -- * Bulk queries + -- -- | Get all the packages from the index. --- allPackages :: PackageIndex pkg -> [pkg] allPackages (PackageIndex m) = concat (Map.elems m) -- | Get all the packages from the index. -- -- They are grouped by package name, case-sensitively. --- allPackagesByName :: PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m -- + -- * Lookups + -- elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool @@ -256,44 +288,46 @@ elemByPackageId index = isJust . lookupPackageId index elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool elemByPackageName index = not . null . lookupPackageName index - -- | Does a lookup by package id (name & version). -- -- Since multiple package DBs mask each other case-sensitively by package name, -- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier - -> Maybe pkg +lookupPackageId + :: Package pkg + => PackageIndex pkg + -> PackageIdentifier + -> Maybe pkg lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing + case [ pkg | pkg <- lookup index (packageName pkgid), packageId pkg == pkgid + ] of + [] -> Nothing [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" + _ -> internalError "lookupPackageIdentifier" -- | Does a case-sensitive search by package name. --- lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] + [ pkg | pkg <- lookup index name, packageName pkg == name + ] -- | Does a case-sensitive search by package name and a range of versions. -- -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. --- -lookupDependency :: Package pkg - => PackageIndex pkg - -> PackageName -> VersionRange - -> [pkg] +lookupDependency + :: Package pkg + => PackageIndex pkg + -> PackageName + -> VersionRange + -> [pkg] lookupDependency index name versionRange = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] + [ pkg | pkg <- lookup index name, packageName pkg == name, packageVersion pkg `withinRange` versionRange + ] -- + -- * Case insensitive name lookups + -- -- | Does a case-insensitive search by package name. @@ -307,13 +341,15 @@ lookupDependency index name versionRange = -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] +searchByName + :: PackageIndex pkg + -> String + -> [(PackageName, [pkg])] searchByName (PackageIndex m) name = - [ pkgs - | pkgs@(pname,_) <- Map.toList m - , lowercase (unPackageName pname) == lname ] + [ pkgs + | pkgs@(pname, _) <- Map.toList m + , lowercase (unPackageName pname) == lname + ] where lname = lowercase name @@ -322,17 +358,21 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] +searchByNameSubstring + :: PackageIndex pkg + -> String + -> [(PackageName, [pkg])] searchByNameSubstring index searchterm = - searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm + searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) + where + lsearchterm = lowercase searchterm -searchWithPredicate :: PackageIndex pkg - -> (String -> Bool) -> [(PackageName, [pkg])] +searchWithPredicate + :: PackageIndex pkg + -> (String -> Bool) + -> [(PackageName, [pkg])] searchWithPredicate (PackageIndex m) predicate = - [ pkgs - | pkgs@(pname, _) <- Map.toList m - , predicate (unPackageName pname) - ] + [ pkgs + | pkgs@(pname, _) <- Map.toList m + , predicate (unPackageName pname) + ] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..56b43f3fd5c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,19 +1,19 @@ module Distribution.Solver.Types.PackagePath - ( PackagePath(..) - , Namespace(..) - , Qualifier(..) - , dispQualifier - , Qualified(..) - , QPN - , dispQPN - , showQPN - ) where + ( PackagePath (..) + , Namespace (..) + , Qualifier (..) + , dispQualifier + , Qualified (..) + , QPN + , dispQPN + , showQPN + ) where -import Distribution.Solver.Compat.Prelude -import Prelude () import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) +import Distribution.Pretty (flatStyle, pretty) +import Distribution.Solver.Compat.Prelude import qualified Text.PrettyPrint as Disp +import Prelude () -- | A package path consists of a namespace and a package path inside that -- namespace. @@ -24,12 +24,11 @@ data PackagePath = PackagePath Namespace Qualifier -- -- Package choices in different namespaces are considered completely independent -- by the solver. -data Namespace = - -- | The default namespace +data Namespace + = -- | The default namespace DefaultNamespace - - -- | A namespace for a specific build target - | Independent PackageName + | -- | A namespace for a specific build target + Independent PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a namespace. The result is either empty or @@ -39,25 +38,22 @@ dispNamespace DefaultNamespace = Disp.empty dispNamespace (Independent i) = pretty i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') -data Qualifier = - -- | Top-level dependency in this namespace +data Qualifier + = -- | Top-level dependency in this namespace QualToplevel - - -- | Any dependency on base is considered independent + | -- | Any dependency on base is considered independent -- -- This makes it possible to have base shims. - | QualBase PackageName - - -- | Setup dependency + QualBase PackageName + | -- | Setup dependency -- -- By rights setup dependencies ought to be nestable; after all, the setup -- dependencies of a package might themselves have setup dependencies, which -- are independent from everything else. However, this very quickly leads to -- infinite search trees in the solver. Therefore we limit ourselves to -- a single qualifier (within a given namespace). - | QualSetup PackageName - - -- | If we depend on an executable from a package (via + QualSetup PackageName + | -- | If we depend on an executable from a package (via -- @build-tools@), we should solve for the dependencies of that -- package separately (since we're not going to actually try to -- link it.) We qualify for EACH package separately; e.g., @@ -67,7 +63,7 @@ data Qualifier = -- of the depended upon executables from a package; if we -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) - | QualExe PackageName PackageName + QualExe PackageName PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a qualifier. The result is either empty or @@ -80,10 +76,13 @@ data Qualifier = -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> - pretty pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." +dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = + pretty pn + <<>> Disp.text ":" + <<>> pretty pn2 + <<>> Disp.text ":exe." +dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs index 88ee877a0ec..6088e1a92e3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs @@ -1,6 +1,6 @@ module Distribution.Solver.Types.PackagePreferences - ( PackagePreferences(..) - ) where + ( PackagePreferences (..) + ) where import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.OptionalStanza @@ -16,7 +16,8 @@ import Distribution.Version (VersionRange) -- -- It is not specified if preferences on some packages are more important than -- others. --- -data PackagePreferences = PackagePreferences [VersionRange] - InstalledPreference - [OptionalStanza] +data PackagePreferences + = PackagePreferences + [VersionRange] + InstalledPreference + [OptionalStanza] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs index 11e6da847f0..ebefbb2fd16 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Solver.Types.PkgConfigDb -- Copyright : (c) Iñaki García Etxebarria 2016 @@ -10,46 +14,51 @@ -- Portability : portable -- -- Read the list of packages available to pkg-config. ------------------------------------------------------------------------------ module Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb (..) - , readPkgConfigDb - , pkgConfigDbFromList - , pkgConfigPkgIsPresent - , pkgConfigDbPkgVersion - , getPkgConfigDbDirs - ) where + ( PkgConfigDb (..) + , readPkgConfigDb + , pkgConfigDbFromList + , pkgConfigPkgIsPresent + , pkgConfigDbPkgVersion + , getPkgConfigDbDirs + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Control.Exception (handle) -import Control.Monad (mapM) -import qualified Data.Map as M -import System.FilePath (splitSearchPath) +import Control.Exception (handle) +import Control.Monad (mapM) +import qualified Data.Map as M +import System.FilePath (splitSearchPath) -import Distribution.Compat.Environment (lookupEnv) -import Distribution.Package (PkgconfigName, mkPkgconfigName) +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program - (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram, ConfiguredProgram) -import Distribution.Simple.Program.Run (getProgramInvocationOutputAndErrors, programInvocation) -import Distribution.Simple.Utils (info) + ( ConfiguredProgram + , ProgramDb + , getProgramOutput + , needProgram + , pkgConfigProgram + ) +import Distribution.Simple.Program.Run (getProgramInvocationOutputAndErrors, programInvocation) +import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (Verbosity) -- | The list of packages installed in the system visible to -- @pkg-config@. This is an opaque datatype, to be constructed with -- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. -data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) - -- ^ If an entry is `Nothing`, this means that the - -- package seems to be present, but we don't know the - -- exact version (because parsing of the version - -- number failed). - | NoPkgConfigDb - -- ^ For when we could not run pkg-config successfully. - deriving (Show, Generic, Typeable) +data PkgConfigDb + = -- | If an entry is `Nothing`, this means that the + -- package seems to be present, but we don't know the + -- exact version (because parsing of the version + -- number failed). + PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) + | -- | For when we could not run pkg-config successfully. + NoPkgConfigDb + deriving (Show, Generic, Typeable) instance Binary PkgConfigDb instance Structured PkgConfigDb @@ -59,67 +68,70 @@ instance Structured PkgConfigDb -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do - mpkgConfig <- needProgram verbosity pkgConfigProgram progdb - case mpkgConfig of - Nothing -> noPkgConfig "Cannot find pkg-config program" - Just (pkgConfig, _) -> do - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - (pkgVersions, _errs, exitCode) <- - getProgramInvocationOutputAndErrors verbosity - (programInvocation pkgConfig ("--modversion" : pkgNames)) - case exitCode of - ExitSuccess -> (return . pkgConfigDbFromList . zip pkgNames) (lines pkgVersions) - -- if there's a single broken pc file the above fails, so we fall back into calling it individually - _ -> do - info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") - pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "Cannot find pkg-config program" + Just (pkgConfig, _) -> do + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + (pkgVersions, _errs, exitCode) <- + getProgramInvocationOutputAndErrors + verbosity + (programInvocation pkgConfig ("--modversion" : pkgNames)) + case exitCode of + ExitSuccess -> (return . pkgConfigDbFromList . zip pkgNames) (lines pkgVersions) + -- if there's a single broken pc file the above fails, so we fall back into calling it individually + _ -> do + info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") + pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames where -- For when pkg-config invocation fails (possibly because of a -- too long command line). noPkgConfig extra = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ extra) - return NoPkgConfigDb + info + verbosity + ( "Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ extra + ) + return NoPkgConfigDb ioErrorHandler :: IOException -> IO PkgConfigDb ioErrorHandler e = noPkgConfig (show e) getIndividualVersion :: ConfiguredProgram -> String -> IO (Maybe (String, String)) getIndividualVersion pkgConfig pkg = do - (pkgVersion, _errs, exitCode) <- - getProgramInvocationOutputAndErrors verbosity - (programInvocation pkgConfig ["--modversion",pkg]) - return $ case exitCode of - ExitSuccess -> Just (pkg, pkgVersion) - _ -> Nothing + (pkgVersion, _errs, exitCode) <- + getProgramInvocationOutputAndErrors + verbosity + (programInvocation pkgConfig ["--modversion", pkg]) + return $ case exitCode of + ExitSuccess -> Just (pkg, pkgVersion) + _ -> Nothing -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs - where - convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) - convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) + where + convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) + convert (n, vs) = (mkPkgconfigName n, simpleParsec vs) -- | Check whether a given package range is satisfiable in the given -- @pkg-config@ database. pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = - case M.lookup pn db of - Nothing -> False -- Package not present in the DB. - Just Nothing -> True -- Package present, but version unknown. - Just (Just v) -> withinPkgconfigVersionRange v vr + case M.lookup pn db of + Nothing -> False -- Package not present in the DB. + Just Nothing -> True -- Package present, but version unknown. + Just (Just v) -> withinPkgconfigVersionRange v vr -- If we could not read the pkg-config database successfully we fail. -- The plan found by the solver can't be executed later, because pkg-config itself -- is going to be called in the build phase to get the library location for linking -- so even if there is a library, it would need to be passed manual flags anyway. pkgConfigPkgIsPresent NoPkgConfigDb _ _ = False - - -- | Query the version of a package in the @pkg-config@ database. -- @Nothing@ indicates the package is not in the database, while -- @Just Nothing@ indicates that the package is in the database, @@ -132,14 +144,12 @@ pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db -- don't know about it. pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing - -- | Query pkg-config for the locations of pkg-config's package files. Use this -- to monitor for changes in the pkg-config DB. --- getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] getPkgConfigDbDirs verbosity progdb = - (++) <$> getEnvPath <*> getDefPath - where + (++) <$> getEnvPath <*> getDefPath + where -- According to @man pkg-config@: -- -- PKG_CONFIG_PATH @@ -147,8 +157,9 @@ getPkgConfigDbDirs verbosity progdb = -- to search for .pc files. The default directory will always be searched -- after searching the path -- - getEnvPath = maybe [] parseSearchPath - <$> lookupEnv "PKG_CONFIG_PATH" + getEnvPath = + maybe [] parseSearchPath + <$> lookupEnv "PKG_CONFIG_PATH" -- Again according to @man pkg-config@: -- @@ -161,13 +172,14 @@ getPkgConfigDbDirs verbosity progdb = mpkgConfig <- needProgram verbosity pkgConfigProgram progdb case mpkgConfig of Nothing -> return [] - Just (pkgConfig, _) -> parseSearchPath <$> - getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] + Just (pkgConfig, _) -> + parseSearchPath + <$> getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of [p] | not (null p) -> splitSearchPath p - _ -> [] + _ -> [] ioErrorHandler :: IOException -> IO [FilePath] ioErrorHandler _e = return [] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs index a47e651d1c4..39f65ca9fed 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -1,26 +1,26 @@ module Distribution.Solver.Types.Progress - ( Progress(..) - , foldProgress - ) where + ( Progress (..) + , foldProgress + ) where -import Prelude () import Distribution.Solver.Compat.Prelude hiding (fail) +import Prelude () -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- result which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done +data Progress step fail done + = Step step (Progress step fail done) + | Fail fail + | Done done -- This Functor instance works around a bug in GHC 7.6.3. -- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. -- The derived functor instance caused a space leak in the solver. instance Functor (Progress step fail) where fmap f (Step s p) = Step s (fmap f p) - fmap _ (Fail x) = Fail x - fmap f (Done r) = Done (f r) + fmap _ (Fail x) = Fail x + fmap f (Done r) = Done (f r) -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. @@ -28,22 +28,26 @@ instance Functor (Progress step fail) where -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a +foldProgress + :: (step -> a -> a) + -> (fail -> a) + -> (done -> a) + -> Progress step fail done + -> a foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r + where + fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p + return = pure + p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where - pure a = Done a + pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where - empty = Fail mempty + empty = Fail mempty p <|> q = foldProgress Step (const q) Done p diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs index 840e58aff94..b23137ab54e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -1,38 +1,39 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + module Distribution.Solver.Types.ResolverPackage - ( ResolverPackage(..) - , resolverPackageLibDeps - , resolverPackageExeDeps - ) where + ( ResolverPackage (..) + , resolverPackageLibDeps + , resolverPackageExeDeps + ) where import Distribution.Solver.Compat.Prelude import Prelude () +import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Package (Package(..), HasUnitId(..)) +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasUnitId (..), Package (..)) import Distribution.Simple.Utils (ordNub) -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration. -- -- This is like the 'InstallPlan.PlanPackage' but with fewer cases. --- -data ResolverPackage loc = PreExisting InstSolverPackage - | Configured (SolverPackage loc) +data ResolverPackage loc + = PreExisting InstSolverPackage + | Configured (SolverPackage loc) deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc) instance Structured loc => Structured (ResolverPackage loc) instance Package (ResolverPackage loc) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg @@ -46,7 +47,9 @@ instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) nodeKey (Configured spkg) = PlannedId (packageId spkg) + -- Use dependencies for ALL components nodeNeighbors pkg = - ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ - CD.flatDeps (resolverPackageExeDeps pkg) + ordNub $ + CD.flatDeps (resolverPackageLibDeps pkg) + ++ CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs index 4b7fe65b769..9f34d288640 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs @@ -1,27 +1,28 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Distribution.Solver.Types.Settings - ( ReorderGoals(..) - , IndependentGoals(..) - , PreferOldest(..) - , MinimizeConflictSet(..) - , AvoidReinstalls(..) - , ShadowPkgs(..) - , StrongFlags(..) - , AllowBootLibInstalls(..) - , OnlyConstrained(..) - , EnableBackjumping(..) - , CountConflicts(..) - , FineGrainedConflicts(..) - , SolveExecutables(..) - ) where + ( ReorderGoals (..) + , IndependentGoals (..) + , PreferOldest (..) + , MinimizeConflictSet (..) + , AvoidReinstalls (..) + , ShadowPkgs (..) + , StrongFlags (..) + , AllowBootLibInstalls (..) + , OnlyConstrained (..) + , EnableBackjumping (..) + , CountConflicts (..) + , FineGrainedConflicts (..) + , SolveExecutables (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Simple.Setup ( BooleanFlag(..) ) -import Distribution.Pretty ( Pretty(pretty) ) -import Distribution.Parsec ( Parsec(parsec) ) +import Distribution.Parsec (Parsec (parsec)) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Simple.Setup (BooleanFlag (..)) import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP @@ -96,12 +97,12 @@ instance Structured OnlyConstrained instance Structured SolveExecutables instance Pretty OnlyConstrained where - pretty OnlyConstrainedAll = PP.text "all" + pretty OnlyConstrainedAll = PP.text "all" pretty OnlyConstrainedNone = PP.text "none" instance Parsec OnlyConstrained where - parsec = P.choice - [ P.string "all" >> return OnlyConstrainedAll - , P.string "none" >> return OnlyConstrainedNone - ] - + parsec = + P.choice + [ P.string "all" >> return OnlyConstrainedAll + , P.string "none" >> return OnlyConstrainedNone + ] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..42cc09eb547 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -1,29 +1,29 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.SolverId - ( SolverId(..) - ) +module Distribution.Solver.Types.SolverId + ( SolverId (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package (PackageId, Package(..), UnitId) +import Distribution.Package (Package (..), PackageId, UnitId) -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. --- -data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } - | PlannedId { solverSrcId :: PackageId } +data SolverId + = PreExistingId {solverSrcId :: PackageId, solverInstId :: UnitId} + | PlannedId {solverSrcId :: PackageId} deriving (Eq, Ord, Generic) instance Binary SolverId instance Structured SolverId instance Show SolverId where - show = show . solverSrcId + show = show . solverSrcId instance Package SolverId where packageId = solverSrcId diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs index 186f140aefe..8a521c06ff2 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -1,14 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Types.SolverPackage - ( SolverPackage(..) - ) where + ( SolverPackage (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package ( Package(..) ) -import Distribution.PackageDescription ( FlagAssignment ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Package (Package (..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage @@ -19,14 +20,13 @@ import Distribution.Solver.Types.SourcePackage -- -- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', -- but for symmetry we have the parameter. (Maybe it can be removed.) --- -data SolverPackage loc = SolverPackage { - solverPkgSource :: SourcePackage loc, - solverPkgFlags :: FlagAssignment, - solverPkgStanzas :: OptionalStanzaSet, - solverPkgLibDeps :: ComponentDeps [SolverId], - solverPkgExeDeps :: ComponentDeps [SolverId] - } +data SolverPackage loc = SolverPackage + { solverPkgSource :: SourcePackage loc + , solverPkgFlags :: FlagAssignment + , solverPkgStanzas :: OptionalStanzaSet + , solverPkgLibDeps :: ComponentDeps [SolverId] + , solverPkgExeDeps :: ComponentDeps [SolverId] + } deriving (Eq, Show, Generic) instance Binary loc => Binary (SolverPackage loc) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs index 35cba9b6e4a..26ca95b36bd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs @@ -1,28 +1,31 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Types.SourcePackage - ( PackageDescriptionOverride - , SourcePackage(..) - ) where + ( PackageDescriptionOverride + , SourcePackage (..) + ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package - ( PackageId, Package(..) ) + ( Package (..) + , PackageId + ) import Distribution.PackageDescription - ( GenericPackageDescription(..) ) + ( GenericPackageDescription (..) + ) import Data.ByteString.Lazy (ByteString) -- | A package description along with the location of the package sources. --- data SourcePackage loc = SourcePackage - { srcpkgPackageId :: PackageId - , srcpkgDescription :: GenericPackageDescription - -- ^ Note, this field is lazy, e.g. when reading in hackage index - -- we parse only what we need, not whole index. - , srcpkgSource :: loc + { srcpkgPackageId :: PackageId + , srcpkgDescription :: GenericPackageDescription + -- ^ Note, this field is lazy, e.g. when reading in hackage index + -- we parse only what we need, not whole index. + , srcpkgSource :: loc , srcpkgDescrOverride :: PackageDescriptionOverride } deriving (Eq, Show, Generic, Typeable) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs b/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs index 80f9de52deb..560d8357119 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs @@ -8,8 +8,8 @@ import Distribution.PackageDescription (FlagName) -- | Variables used by the dependency solver. This type is similar to the -- internal 'Var' type. -data Variable qpn = - PackageVar qpn +data Variable qpn + = PackageVar qpn | FlagVar qpn FlagName | StanzaVar qpn OptionalStanza deriving (Eq, Show) diff --git a/cabal-install-solver/tests/UnitTests.hs b/cabal-install-solver/tests/UnitTests.hs index 35ba174ea9e..b74d9970d0d 100644 --- a/cabal-install-solver/tests/UnitTests.hs +++ b/cabal-install-solver/tests/UnitTests.hs @@ -1,12 +1,15 @@ module Main (main) where - import Test.Tasty import qualified UnitTests.Distribution.Solver.Modular.MessageUtils main :: IO () -main = defaultMain $ testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Solver.Modular.MessageUtils" +main = + defaultMain $ + testGroup + "Unit Tests" + [ testGroup + "UnitTests.Distribution.Solver.Modular.MessageUtils" UnitTests.Distribution.Solver.Modular.MessageUtils.tests - ] + ] diff --git a/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs b/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs index a24d5672ddd..8c9be253938 100644 --- a/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs +++ b/cabal-install-solver/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs @@ -1,7 +1,11 @@ -module UnitTests.Distribution.Solver.Modular.MessageUtils ( tests ) where +module UnitTests.Distribution.Solver.Modular.MessageUtils (tests) where import Distribution.Solver.Modular.MessageUtils - (allKnownExtensions, cutoffRange, withinRange, mostSimilarElement) + ( allKnownExtensions + , cutoffRange + , mostSimilarElement + , withinRange + ) import Language.Haskell.Extension (knownLanguages) import Test.Tasty import Test.Tasty.HUnit @@ -57,7 +61,7 @@ rangeAssertions = map (testRange cutoffRange extensionStrings) outOfBounds isOutOfBounds :: Int -> String -> String -> Bool isOutOfBounds range a b = not $ withinRange range a b -testRange :: Int -> [String] -> String -> Assertion +testRange :: Int -> [String] -> String -> Assertion testRange range elems erronousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erronousElement suggestion) where suggestion = mostSimilarElement erronousElement elems diff --git a/cabal-install/src/Distribution/Client/Check.hs b/cabal-install/src/Distribution/Client/Check.hs index b4c85f0abc3..82f466e196a 100644 --- a/cabal-install/src/Distribution/Client/Check.hs +++ b/cabal-install/src/Distribution/Client/Check.hs @@ -99,34 +99,35 @@ check verbosity = do -- Poor man’s “group checks by constructor”. groupChecks :: [PackageCheck] -> [NE.NonEmpty PackageCheck] -groupChecks ds = NE.groupBy (F.on (==) constInt) - (L.sortBy (F.on compare constInt) ds) - where - constInt :: PackageCheck -> Int - constInt (PackageBuildImpossible {}) = 0 - constInt (PackageBuildWarning {}) = 1 - constInt (PackageDistSuspicious {}) = 2 - constInt (PackageDistSuspiciousWarn {}) = 3 - constInt (PackageDistInexcusable {}) = 4 +groupChecks ds = + NE.groupBy + (F.on (==) constInt) + (L.sortBy (F.on compare constInt) ds) + where + constInt :: PackageCheck -> Int + constInt (PackageBuildImpossible{}) = 0 + constInt (PackageBuildWarning{}) = 1 + constInt (PackageDistSuspicious{}) = 2 + constInt (PackageDistSuspiciousWarn{}) = 3 + constInt (PackageDistInexcusable{}) = 4 groupExplanation :: PackageCheck -> String -groupExplanation (PackageBuildImpossible {}) = "The package will not build sanely due to these errors:" -groupExplanation (PackageBuildWarning {}) = "The following errors are likely to affect your build negatively:" -groupExplanation (PackageDistSuspicious {}) = "These warnings will likely cause trouble when distributing the package:" -groupExplanation (PackageDistSuspiciousWarn {}) = "These warnings may cause trouble when distributing the package:" -groupExplanation (PackageDistInexcusable {}) = "The following errors will cause portability problems on other environments:" +groupExplanation (PackageBuildImpossible{}) = "The package will not build sanely due to these errors:" +groupExplanation (PackageBuildWarning{}) = "The following errors are likely to affect your build negatively:" +groupExplanation (PackageDistSuspicious{}) = "These warnings will likely cause trouble when distributing the package:" +groupExplanation (PackageDistSuspiciousWarn{}) = "These warnings may cause trouble when distributing the package:" +groupExplanation (PackageDistInexcusable{}) = "The following errors will cause portability problems on other environments:" groupOutputFunction :: PackageCheck -> Verbosity -> String -> IO () -groupOutputFunction (PackageBuildImpossible {}) ver = warnError ver -groupOutputFunction (PackageBuildWarning {}) ver = warnError ver -groupOutputFunction (PackageDistSuspicious {}) ver = warn ver -groupOutputFunction (PackageDistSuspiciousWarn {}) ver = warn ver -groupOutputFunction (PackageDistInexcusable {}) ver = warnError ver +groupOutputFunction (PackageBuildImpossible{}) ver = warnError ver +groupOutputFunction (PackageBuildWarning{}) ver = warnError ver +groupOutputFunction (PackageDistSuspicious{}) ver = warn ver +groupOutputFunction (PackageDistSuspiciousWarn{}) ver = warn ver +groupOutputFunction (PackageDistInexcusable{}) ver = warnError ver outputGroupCheck :: Verbosity -> NE.NonEmpty PackageCheck -> IO () outputGroupCheck ver pcs = do - let hp = NE.head pcs - outf = groupOutputFunction hp ver - notice ver (groupExplanation hp) - CM.mapM_ (outf . ppPackageCheck) pcs - + let hp = NE.head pcs + outf = groupOutputFunction hp ver + notice ver (groupExplanation hp) + CM.mapM_ (outf . ppPackageCheck) pcs diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 7d7aaa9efa1..bc065556222 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -347,7 +347,9 @@ sanityCheckElaboratedPackage -- readProjectConfig also loads the global configuration, which is read with -- loadConfig and convertd to a ProjectConfig with convertLegacyGlobalConfig. -- --- *Important* + +-- * Important* + -- -- You can notice how some project config options are needed to read the -- project config! This is evident by the fact that rebuildProjectConfig @@ -539,9 +541,10 @@ configureCompiler ) $ defaultProgramDb - ------------------------------------------------------------------------------ + -- * Deciding what to do: making an 'ElaboratedInstallPlan' + ------------------------------------------------------------------------------ -- | Return an up-to-date elaborated install plan. diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 0ff8e280823..bcd6e4134d1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -45,9 +45,24 @@ import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Data.Coerce (Coercible, coerce) import Network.URI (URI (..), URIAuth (..), isUnreserved) -import Test.QuickCheck (Arbitrary(..), Gen, NonEmptyList(..), - arbitraryBoundedEnum, choose, elements, frequency, genericShrink, - liftArbitrary, listOf, oneof, resize, sized, shrinkBoundedEnum, suchThat, vectorOf) +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , NonEmptyList (..) + , arbitraryBoundedEnum + , choose + , elements + , frequency + , genericShrink + , liftArbitrary + , listOf + , oneof + , resize + , shrinkBoundedEnum + , sized + , suchThat + , vectorOf + ) import Test.QuickCheck.GenericArbitrary (genericArbitrary) import Test.QuickCheck.Instances.Cabal () diff --git a/cabal-testsuite/PackageTests/AllowNewer/Setup.hs b/cabal-testsuite/PackageTests/AllowNewer/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/cabal-testsuite/PackageTests/AllowNewer/Setup.hs +++ b/cabal-testsuite/PackageTests/AllowNewer/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs b/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs index 5cb00a21505..6af7de0d5ee 100644 --- a/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs +++ b/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs @@ -1,28 +1,49 @@ import Test.Cabal.Prelude hiding (cabal) import qualified Test.Cabal.Prelude as P + -- See #4332, dep solving output is not deterministic main = cabalTest . recordMode DoNotRecord $ do - fails $ cabal "v2-build" [] - cabal "v2-build" ["--allow-newer"] - fails $ cabal "v2-build" ["--allow-newer=baz,quux"] - cabal "v2-build" ["--allow-newer=base", "--allow-newer=baz,quux"] - cabal "v2-build" ["--allow-newer=bar", "--allow-newer=base,baz" - ,"--allow-newer=quux"] - fails $ cabal "v2-build" ["--enable-tests"] - cabal "v2-build" ["--enable-tests", "--allow-newer"] - fails $ cabal "v2-build" ["--enable-benchmarks"] - cabal "v2-build" ["--enable-benchmarks", "--allow-newer"] - fails $ cabal "v2-build" ["--enable-benchmarks", "--enable-tests"] - cabal "v2-build" ["--enable-benchmarks", "--enable-tests" - ,"--allow-newer"] - fails $ cabal "v2-build" ["--allow-newer=Foo:base"] - fails $ cabal "v2-build" ["--allow-newer=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - cabal "v2-build" ["--allow-newer=AllowNewer:base"] - cabal "v2-build" ["--allow-newer=AllowNewer:base" - ,"--allow-newer=Foo:base"] - cabal "v2-build" ["--allow-newer=AllowNewer:base" - ,"--allow-newer=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] + fails $ cabal "v2-build" [] + cabal "v2-build" ["--allow-newer"] + fails $ cabal "v2-build" ["--allow-newer=baz,quux"] + cabal "v2-build" ["--allow-newer=base", "--allow-newer=baz,quux"] + cabal + "v2-build" + [ "--allow-newer=bar" + , "--allow-newer=base,baz" + , "--allow-newer=quux" + ] + fails $ cabal "v2-build" ["--enable-tests"] + cabal "v2-build" ["--enable-tests", "--allow-newer"] + fails $ cabal "v2-build" ["--enable-benchmarks"] + cabal "v2-build" ["--enable-benchmarks", "--allow-newer"] + fails $ cabal "v2-build" ["--enable-benchmarks", "--enable-tests"] + cabal + "v2-build" + [ "--enable-benchmarks" + , "--enable-tests" + , "--allow-newer" + ] + fails $ cabal "v2-build" ["--allow-newer=Foo:base"] + fails $ + cabal + "v2-build" + [ "--allow-newer=Foo:base" + , "--enable-tests" + , "--enable-benchmarks" + ] + cabal "v2-build" ["--allow-newer=AllowNewer:base"] + cabal + "v2-build" + [ "--allow-newer=AllowNewer:base" + , "--allow-newer=Foo:base" + ] + cabal + "v2-build" + [ "--allow-newer=AllowNewer:base" + , "--allow-newer=Foo:base" + , "--enable-tests" + , "--enable-benchmarks" + ] where cabal cmd args = P.cabal cmd ("--dry-run" : args) diff --git a/cabal-testsuite/PackageTests/AllowOlder/Setup.hs b/cabal-testsuite/PackageTests/AllowOlder/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/cabal-testsuite/PackageTests/AllowOlder/Setup.hs +++ b/cabal-testsuite/PackageTests/AllowOlder/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs b/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs index 2160ed091d7..96d8abe723f 100644 --- a/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs +++ b/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs @@ -1,28 +1,49 @@ import Test.Cabal.Prelude hiding (cabal) import qualified Test.Cabal.Prelude as P + -- See #4332, dep solving output is not deterministic main = cabalTest . recordMode DoNotRecord $ do - fails $ cabal "v2-build" [] - cabal "v2-build" ["--allow-older"] - fails $ cabal "v2-build" ["--allow-older=baz,quux"] - cabal "v2-build" ["--allow-older=base", "--allow-older=baz,quux"] - cabal "v2-build" ["--allow-older=bar", "--allow-older=base,baz" - ,"--allow-older=quux"] - fails $ cabal "v2-build" ["--enable-tests"] - cabal "v2-build" ["--enable-tests", "--allow-older"] - fails $ cabal "v2-build" ["--enable-benchmarks"] - cabal "v2-build" ["--enable-benchmarks", "--allow-older"] - fails $ cabal "v2-build" ["--enable-benchmarks", "--enable-tests"] - cabal "v2-build" ["--enable-benchmarks", "--enable-tests" - ,"--allow-older"] - fails $ cabal "v2-build" ["--allow-older=Foo:base"] - fails $ cabal "v2-build" ["--allow-older=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - cabal "v2-build" ["--allow-older=AllowOlder:base"] - cabal "v2-build" ["--allow-older=AllowOlder:base" - ,"--allow-older=Foo:base"] - cabal "v2-build" ["--allow-older=AllowOlder:base" - ,"--allow-older=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] + fails $ cabal "v2-build" [] + cabal "v2-build" ["--allow-older"] + fails $ cabal "v2-build" ["--allow-older=baz,quux"] + cabal "v2-build" ["--allow-older=base", "--allow-older=baz,quux"] + cabal + "v2-build" + [ "--allow-older=bar" + , "--allow-older=base,baz" + , "--allow-older=quux" + ] + fails $ cabal "v2-build" ["--enable-tests"] + cabal "v2-build" ["--enable-tests", "--allow-older"] + fails $ cabal "v2-build" ["--enable-benchmarks"] + cabal "v2-build" ["--enable-benchmarks", "--allow-older"] + fails $ cabal "v2-build" ["--enable-benchmarks", "--enable-tests"] + cabal + "v2-build" + [ "--enable-benchmarks" + , "--enable-tests" + , "--allow-older" + ] + fails $ cabal "v2-build" ["--allow-older=Foo:base"] + fails $ + cabal + "v2-build" + [ "--allow-older=Foo:base" + , "--enable-tests" + , "--enable-benchmarks" + ] + cabal "v2-build" ["--allow-older=AllowOlder:base"] + cabal + "v2-build" + [ "--allow-older=AllowOlder:base" + , "--allow-older=Foo:base" + ] + cabal + "v2-build" + [ "--allow-older=AllowOlder:base" + , "--allow-older=Foo:base" + , "--enable-tests" + , "--enable-benchmarks" + ] where cabal cmd args = P.cabal cmd ("--dry-run" : args) diff --git a/cabal-testsuite/PackageTests/Ambiguity/p/Dupe.hs b/cabal-testsuite/PackageTests/Ambiguity/p/Dupe.hs index 908b17a017d..ee7b232e00f 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/p/Dupe.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/p/Dupe.hs @@ -1,2 +1,3 @@ module Dupe where + pkg = "p" diff --git a/cabal-testsuite/PackageTests/Ambiguity/package-import/A.hs b/cabal-testsuite/PackageTests/Ambiguity/package-import/A.hs index 8f8d99e565c..7adceb7cb11 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/package-import/A.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/package-import/A.hs @@ -4,4 +4,3 @@ import qualified "p" Dupe as PDupe import qualified "q" Dupe as QDupe main = putStrLn (PDupe.pkg ++ " " ++ QDupe.pkg) - diff --git a/cabal-testsuite/PackageTests/Ambiguity/q/Dupe.hs b/cabal-testsuite/PackageTests/Ambiguity/q/Dupe.hs index baa7e7ff267..2d1e353fc2c 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/q/Dupe.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/q/Dupe.hs @@ -1,2 +1,3 @@ module Dupe where + pkg = "q" diff --git a/cabal-testsuite/PackageTests/Ambiguity/reexport-test/Main.hs b/cabal-testsuite/PackageTests/Ambiguity/reexport-test/Main.hs index 90df771060f..9060a06e530 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/reexport-test/Main.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/reexport-test/Main.hs @@ -1,4 +1,5 @@ module Main where + import qualified PDupe import qualified QDupe diff --git a/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs b/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs index 50c09d00f4a..9d6be97bd51 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + -- Test that module name ambiguity can be resolved using package -- qualified imports. (Paper Backpack doesn't natively support -- this but we must!) main = setupAndCabalTest $ do - withPackageDb $ do - withDirectory "p" $ setup_install [] - withDirectory "q" $ setup_install [] - withDirectory "package-import" $ do - setup_build [] - runExe' "package-import" [] >>= assertOutputContains "p q" + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ setup_install [] + withDirectory "package-import" $ do + setup_build [] + runExe' "package-import" [] >>= assertOutputContains "p q" diff --git a/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs b/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs index a5407ce2b18..69aae7a1281 100644 --- a/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs +++ b/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + -- Test that we can resolve a module name ambiguity when reexporting -- by explicitly specifying what package we want. main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 7.9" - withPackageDb $ do - withDirectory "p" $ setup_install [] - withDirectory "q" $ setup_install [] - withDirectory "reexport" $ setup_install [] - withDirectory "reexport-test" $ do - setup_build [] - runExe' "reexport-test" [] >>= assertOutputContains "p q" + skipUnlessGhcVersion ">= 7.9" + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ setup_install [] + withDirectory "reexport" $ setup_install [] + withDirectory "reexport-test" $ do + setup_build [] + runExe' "reexport-test" [] >>= assertOutputContains "p q" diff --git a/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs b/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs index 74c9d8806b8..4ee0228e1ce 100644 --- a/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs +++ b/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs @@ -1,5 +1,6 @@ -import Test.Cabal.Prelude import Data.Foldable (traverse_) +import Test.Cabal.Prelude + main = cabalTest $ do -- Test the forbidden characters except NUL. Reference: -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions @@ -8,7 +9,8 @@ main = cabalTest $ do -- Note: we bundle the configure script so no need to autoreconf -- while building skipIfWindows - traverse_ check + traverse_ + check [ "foo bar" , "foo\tbar" , "foo\nbar" @@ -45,9 +47,13 @@ main = cabalTest $ do , testDistDir env ] configured_prog <- requireProgramM cabalProgram - r <- liftIO $ run (testVerbosity env) - (Just (testCurrentDir env)) - (testEnvironment env) - (programPath configured_prog) - args Nothing + r <- + liftIO $ + run + (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + (programPath configured_prog) + args + Nothing recordLog r diff --git a/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs b/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs index 2b52b469e22..f061a35a477 100644 --- a/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs +++ b/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs @@ -2,48 +2,47 @@ import Test.Cabal.Prelude -- Test that setup shows all the 'autogen-modules' warnings. main = setupAndCabalTest $ do + configureResult <- fails $ setup' "configure" [] + sdistResult <- fails $ setup' "sdist" [] - configureResult <- fails $ setup' "configure" [] - sdistResult <- fails $ setup' "sdist" [] + -- Package check messages. + let libAutogenMsg = + "An 'autogen-module' is neither on 'exposed-modules' or " + ++ "'other-modules'" + let exeAutogenMsg = + "On executable 'Exe' an 'autogen-module' is not on " + ++ "'other-modules'" + let testAutogenMsg = + "On test suite 'Test' an 'autogen-module' is not on " + ++ "'other-modules'" + let benchAutogenMsg = + "On benchmark 'Bench' an 'autogen-module' is not on " + ++ "'other-modules'" + let pathsAutogenMsg = + "Packages using 'cabal-version: 2.0' and the autogenerated" - -- Package check messages. - let libAutogenMsg = - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'" - let exeAutogenMsg = - "On executable 'Exe' an 'autogen-module' is not on " - ++ "'other-modules'" - let testAutogenMsg = - "On test suite 'Test' an 'autogen-module' is not on " - ++ "'other-modules'" - let benchAutogenMsg = - "On benchmark 'Bench' an 'autogen-module' is not on " - ++ "'other-modules'" - let pathsAutogenMsg = - "Packages using 'cabal-version: 2.0' and the autogenerated" + -- Asserts for the desired check messages after configure. + assertOutputContains libAutogenMsg configureResult + assertOutputContains exeAutogenMsg configureResult + assertOutputContains testAutogenMsg configureResult + assertOutputContains benchAutogenMsg configureResult - -- Asserts for the desired check messages after configure. - assertOutputContains libAutogenMsg configureResult - assertOutputContains exeAutogenMsg configureResult - assertOutputContains testAutogenMsg configureResult - assertOutputContains benchAutogenMsg configureResult + -- Asserts for the desired check messages after sdist. + assertOutputContains "Distribution quality errors:" sdistResult + assertOutputContains libAutogenMsg sdistResult + assertOutputContains exeAutogenMsg sdistResult + assertOutputContains testAutogenMsg sdistResult + assertOutputContains benchAutogenMsg sdistResult + assertOutputContains pathsAutogenMsg sdistResult + -- Asserts for the undesired check messages after sdist. + assertOutputDoesNotContain "Distribution quality warnings:" sdistResult - -- Asserts for the desired check messages after sdist. - assertOutputContains "Distribution quality errors:" sdistResult - assertOutputContains libAutogenMsg sdistResult - assertOutputContains exeAutogenMsg sdistResult - assertOutputContains testAutogenMsg sdistResult - assertOutputContains benchAutogenMsg sdistResult - assertOutputContains pathsAutogenMsg sdistResult - -- Asserts for the undesired check messages after sdist. - assertOutputDoesNotContain "Distribution quality warnings:" sdistResult + -- Asserts for the error messages of the modules not found. + assertOutputContains + "Could not find module: MyLibHelperModule with any suffix" + sdistResult + assertOutputContains + "module is autogenerated it should be added to 'autogen-modules'" + sdistResult - -- Asserts for the error messages of the modules not found. - assertOutputContains - "Could not find module: MyLibHelperModule with any suffix" - sdistResult - assertOutputContains - "module is autogenerated it should be added to 'autogen-modules'" - sdistResult - - return () + return () diff --git a/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs b/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs index 84d702c57d2..959fecaab25 100644 --- a/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs +++ b/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs @@ -1,105 +1,111 @@ {-# LANGUAGE CPP #-} + import Test.Cabal.Prelude import Control.Monad.IO.Class import Distribution.ModuleName hiding (main) -import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo -- Test that setup parses and uses 'autogen-modules' fields correctly main = setupAndCabalTest $ do + dist_dir <- fmap testDistDir getTestEnv - dist_dir <- fmap testDistDir getTestEnv - - -- Calling sdist without running configure first makes test fail with: - -- "Exception: Run the 'configure' command first." - -- This is because we are calling getPersistBuildConfig + -- Calling sdist without running configure first makes test fail with: + -- "Exception: Run the 'configure' command first." + -- This is because we are calling getPersistBuildConfig - configureResult <- setup' "configure" [] - sdistResult <- setup' "sdist" [] + configureResult <- setup' "configure" [] + sdistResult <- setup' "sdist" [] - -- Now check that all the correct modules were parsed. - lbi <- getLocalBuildInfoM - let Just gotLibrary = library (localPkgDescr lbi) - let gotExecutable = head $ executables (localPkgDescr lbi) - let gotTestSuite = head $ testSuites (localPkgDescr lbi) - let gotBenchmark = head $ benchmarks (localPkgDescr lbi) - assertEqual "library 'autogen-modules' field does not match expected" - [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyLibHelperModule"] - (libModulesAutogen gotLibrary) - assertEqual "executable 'autogen-modules' field does not match expected" - [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyExeHelperModule"] - (exeModulesAutogen gotExecutable) - assertEqual "test-suite 'autogen-modules' field does not match expected" - [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyTestHelperModule"] - (testModulesAutogen gotTestSuite) - assertEqual "benchmark 'autogen-modules' field does not match expected" - [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyBenchHelperModule"] - (benchmarkModulesAutogen gotBenchmark) + -- Now check that all the correct modules were parsed. + lbi <- getLocalBuildInfoM + let Just gotLibrary = library (localPkgDescr lbi) + let gotExecutable = head $ executables (localPkgDescr lbi) + let gotTestSuite = head $ testSuites (localPkgDescr lbi) + let gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual + "library 'autogen-modules' field does not match expected" + [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyLibHelperModule"] + (libModulesAutogen gotLibrary) + assertEqual + "executable 'autogen-modules' field does not match expected" + [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyExeHelperModule"] + (exeModulesAutogen gotExecutable) + assertEqual + "test-suite 'autogen-modules' field does not match expected" + [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyTestHelperModule"] + (testModulesAutogen gotTestSuite) + assertEqual + "benchmark 'autogen-modules' field does not match expected" + [fromString "PackageInfo_AutogenModules", fromString "Paths_AutogenModules", fromString "MyBenchHelperModule"] + (benchmarkModulesAutogen gotBenchmark) - -- Package check messages. - let libAutogenMsg = - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'" - let exeAutogenMsg = - "On executable 'Exe' an 'autogen-module' is not on " - ++ "'other-modules'" - let testAutogenMsg = - "On test suite 'Test' an 'autogen-module' is not on " - ++ "'other-modules'" - let benchAutogenMsg = - "On benchmark 'Bench' an 'autogen-module' is not on " - ++ "'other-modules'" - let pathsAutogenMsg = - "Packages using 'cabal-version: 2.0' and the autogenerated" + -- Package check messages. + let libAutogenMsg = + "An 'autogen-module' is neither on 'exposed-modules' or " + ++ "'other-modules'" + let exeAutogenMsg = + "On executable 'Exe' an 'autogen-module' is not on " + ++ "'other-modules'" + let testAutogenMsg = + "On test suite 'Test' an 'autogen-module' is not on " + ++ "'other-modules'" + let benchAutogenMsg = + "On benchmark 'Bench' an 'autogen-module' is not on " + ++ "'other-modules'" + let pathsAutogenMsg = + "Packages using 'cabal-version: 2.0' and the autogenerated" - -- Asserts for the undesired check messages after configure. - assertOutputDoesNotContain libAutogenMsg configureResult - assertOutputDoesNotContain exeAutogenMsg configureResult - assertOutputDoesNotContain testAutogenMsg configureResult - assertOutputDoesNotContain benchAutogenMsg configureResult - assertOutputDoesNotContain pathsAutogenMsg configureResult + -- Asserts for the undesired check messages after configure. + assertOutputDoesNotContain libAutogenMsg configureResult + assertOutputDoesNotContain exeAutogenMsg configureResult + assertOutputDoesNotContain testAutogenMsg configureResult + assertOutputDoesNotContain benchAutogenMsg configureResult + assertOutputDoesNotContain pathsAutogenMsg configureResult - -- Asserts for the undesired check messages after sdist. - assertOutputDoesNotContain "Distribution quality errors:" sdistResult - assertOutputDoesNotContain libAutogenMsg sdistResult - assertOutputDoesNotContain exeAutogenMsg sdistResult - assertOutputDoesNotContain testAutogenMsg sdistResult - assertOutputDoesNotContain benchAutogenMsg sdistResult - assertOutputDoesNotContain "Distribution quality warnings:" sdistResult - assertOutputDoesNotContain pathsAutogenMsg sdistResult + -- Asserts for the undesired check messages after sdist. + assertOutputDoesNotContain "Distribution quality errors:" sdistResult + assertOutputDoesNotContain libAutogenMsg sdistResult + assertOutputDoesNotContain exeAutogenMsg sdistResult + assertOutputDoesNotContain testAutogenMsg sdistResult + assertOutputDoesNotContain benchAutogenMsg sdistResult + assertOutputDoesNotContain "Distribution quality warnings:" sdistResult + assertOutputDoesNotContain pathsAutogenMsg sdistResult - -- Assert sdist --list-sources output. - -- If called before configure fails, dist directory is not created. - let listSourcesFileGot = dist_dir ++ "/" ++ "list-sources.txt" - setup "sdist" ["--list-sources=" ++ listSourcesFileGot] - let listSourcesStrExpected = +-- Assert sdist --list-sources output. +-- If called before configure fails, dist directory is not created. +{- FOURMOLU_DISABLE -} + let listSourcesFileGot = dist_dir ++ "/" ++ "list-sources.txt" + setup "sdist" ["--list-sources=" ++ listSourcesFileGot] + let listSourcesStrExpected = #if defined(mingw32_HOST_OS) - ".\\MyLibrary.hs\n" - ++ ".\\MyLibModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyExeModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyTestModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyBenchModule.hs\n" - ++ "LICENSE\n" - ++ ".\\AutogenModules.cabal\n" + ".\\MyLibrary.hs\n" + ++ ".\\MyLibModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyExeModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyTestModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyBenchModule.hs\n" + ++ "LICENSE\n" + ++ ".\\AutogenModules.cabal\n" #else - "./MyLibrary.hs\n" - ++ "./MyLibModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyExeModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyTestModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyBenchModule.hs\n" - ++ "LICENSE\n" - ++ "./AutogenModules.cabal\n" + "./MyLibrary.hs\n" + ++ "./MyLibModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyExeModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyTestModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyBenchModule.hs\n" + ++ "LICENSE\n" + ++ "./AutogenModules.cabal\n" #endif - listSourcesStrGot <- liftIO $ readFile listSourcesFileGot - assertEqual "sdist --list-sources does not match the expected files" - listSourcesStrExpected - listSourcesStrGot + listSourcesStrGot <- liftIO $ readFile listSourcesFileGot + assertEqual + "sdist --list-sources does not match the expected files" + listSourcesStrExpected + listSourcesStrGot - return () + return () diff --git a/cabal-testsuite/PackageTests/AutogenModulesToggling/Main.hs b/cabal-testsuite/PackageTests/AutogenModulesToggling/Main.hs index b14c74931ac..f0a458aff32 100644 --- a/cabal-testsuite/PackageTests/AutogenModulesToggling/Main.hs +++ b/cabal-testsuite/PackageTests/AutogenModulesToggling/Main.hs @@ -9,4 +9,3 @@ main = do putStrLn "-----BEGIN CABAL OUTPUT-----" putStrLn bar putStrLn "-----END CABAL OUTPUT-----" - diff --git a/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs b/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs index 2eab853cdfb..3f0a457500b 100644 --- a/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs +++ b/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs @@ -1,4 +1,3 @@ - module Main (main) where import Distribution.Simple @@ -11,14 +10,17 @@ import Distribution.Verbosity import System.Directory ppHGen :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHGen _bi lbi _clbi = PreProcessor - { platformIndependent = True - , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - copyFile inFile outFile - } +ppHGen _bi lbi _clbi = + PreProcessor + { platformIndependent = True + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + copyFile inFile outFile + } main :: IO () -main = defaultMainWithHooks simpleUserHooks - { hookedPreProcessors = ("hgen", ppHGen) : hookedPreProcessors simpleUserHooks - } +main = + defaultMainWithHooks + simpleUserHooks + { hookedPreProcessors = ("hgen", ppHGen) : hookedPreProcessors simpleUserHooks + } diff --git a/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs index ac89a40e48a..9ba657c8561 100644 --- a/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - r <- fails $ setup' "configure" [] - assertOutputContains "MissingReq" r - return () + skipUnlessGhcVersion ">= 8.1" + r <- fails $ setup' "configure" [] + assertOutputContains "MissingReq" r + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs index 40b813d523f..3d2dfbbfa75 100644 --- a/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - r <- fails $ setup' "configure" [] - assertOutputContains "non-existent" r - return () + skipUnlessGhcVersion ">= 8.1" + r <- fails $ setup' "configure" [] + assertOutputContains "non-existent" r + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs index 64f462ef12f..c78dad4d9e4 100644 --- a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - r <- fails $ setup' "configure" [] - assertOutputContains "UnfilledSig" r - return () + skipUnlessGhcVersion ">= 8.1" + r <- fails $ setup' "configure" [] + assertOutputContains "UnfilledSig" r + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Includes1/A.hs b/cabal-testsuite/PackageTests/Backpack/Includes1/A.hs index e2aa2976731..d9ffe02173f 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes1/A.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes1/A.hs @@ -1,2 +1,3 @@ module A where + import Data.Map diff --git a/cabal-testsuite/PackageTests/Backpack/Includes1/B.hs b/cabal-testsuite/PackageTests/Backpack/Includes1/B.hs index 391138dd357..ba1d3f80a3f 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes1/B.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes1/B.hs @@ -1,3 +1,4 @@ module B where + import A import Data.Set diff --git a/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs index 0ec74cfec97..eea343ddc68 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs @@ -1,8 +1,11 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - setup "configure" [] - r <- fails $ setup' "build" [] - assertRegex "error should be in B.hs" "^B.hs:" r - assertRegex "error should be \"Could not find module Data.Set\"" - "(Could not (load|find) module|Failed to load interface).*Data.Set" r + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in B.hs" "^B.hs:" r + assertRegex + "error should be \"Could not find module Data.Set\"" + "(Could not (load|find) module|Failed to load interface).*Data.Set" + r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs index d26064d700e..255421b6bd9 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withProjectFile "cabal.external.project" $ do - cabal "v2-build" ["mylib"] + skipUnlessGhcVersion ">= 8.1" + withProjectFile "cabal.external.project" $ do + cabal "v2-build" ["mylib"] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs index 7197786ff2a..956eaeb7342 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 - withProjectFile "cabal.external.project" $ do - cabal "v2-build" ["exe"] - withPlan $ do - r <- runPlanExe' "exe" "exe" [] - assertOutputContains "minemysql minepostgresql" r + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withProjectFile "cabal.external.project" $ do + cabal "v2-build" ["exe"] + withPlan $ do + r <- runPlanExe' "exe" "exe" [] + assertOutputContains "minemysql minepostgresql" r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs index 94627d8f95e..8f304678a27 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withProjectFile "cabal.internal.project" $ do - cabal "v2-build" ["mylib"] + skipUnlessGhcVersion ">= 8.1" + withProjectFile "cabal.internal.project" $ do + cabal "v2-build" ["mylib"] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs index a04fdd4987a..24b384ef8bb 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 - withProjectFile "cabal.internal.project" $ do - cabal "v2-build" ["exe"] - withPlan $ do - r <- runPlanExe' "Includes2" "exe" [] - assertOutputContains "minemysql minepostgresql" r + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withProjectFile "cabal.internal.project" $ do + cabal "v2-build" ["exe"] + withPlan $ do + r <- runPlanExe' "Includes2" "exe" [] + assertOutputContains "minemysql minepostgresql" r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Mine.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Mine.hs index 20b4c0d404c..7d1ad838ce9 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Mine.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/mylib/Mine.hs @@ -1,4 +1,6 @@ module Mine where + import Database + data Mine = Mine Database mine = "mine" ++ databaseName diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs index b49cdb42849..92b45856272 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs @@ -1,3 +1,4 @@ module Database.MySQL where + data Database = Database Int databaseName = "mysql" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs index 9cc64f12d61..a8a2db2e743 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs @@ -1,3 +1,4 @@ module Database.PostgreSQL where + data Database = Database Bool databaseName = "postgresql" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs index 3e4577aecfa..5262910ef36 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do skipUnlessGhcVersion ">= 8.1" ghc <- isGhcVersion "== 9.0.2 || == 9.2.* || == 9.4.* || == 9.6.*" @@ -8,11 +9,19 @@ main = setupAndCabalTest $ do withDirectory "mysql" $ setup_install_with_docs ["--ipid", "mysql-0.1.0.0"] withDirectory "postgresql" $ setup_install_with_docs ["--ipid", "postgresql-0.1.0.0"] withDirectory "mylib" $ - setup_install_with_docs ["--ipid", "mylib-0.1.0.0", - "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] + setup_install_with_docs + [ "--ipid" + , "mylib-0.1.0.0" + , "--instantiate-with" + , "Database=mysql-0.1.0.0:Database.MySQL" + ] withDirectory "mylib" $ - setup_install_with_docs ["--ipid", "mylib-0.1.0.0", - "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + setup_install_with_docs + [ "--ipid" + , "mylib-0.1.0.0" + , "--instantiate-with" + , "Database=postgresql-0.1.0.0:Database.PostgreSQL" + ] withDirectory "src" $ setup_install_with_docs [] withDirectory "exe" $ do setup_install_with_docs [] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs index d624dfcac06..28ba3dcef3e 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - r <- fails $ setup' "configure" ["--cabal-file", "Includes2.cabal.fail"] - assertOutputContains "mysql" r + skipUnlessGhcVersion ">= 8.1" + r <- fails $ setup' "configure" ["--cabal-file", "Includes2.cabal.fail"] + assertOutputContains "mysql" r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs index ab1853753e2..7f47cdb828a 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - setup_install ["--cabal-file", "Includes2.cabal"] - -- TODO: haddock for internal method doesn't work - runExe "exe" [] + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + setup_install ["--cabal-file", "Includes2.cabal"] + -- TODO: haddock for internal method doesn't work + runExe "exe" [] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs index 5196d404f65..57dc47b63dd 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupTest $ do -- No cabal test because per-component is broken with it skipUnlessGhcVersion ">= 8.1" @@ -9,10 +10,20 @@ main = setupTest $ do setup_install' ["mylib", "--cid", "mylib-0.1.0.0"] setup_install' ["mysql", "--cid", "mysql-0.1.0.0"] setup_install' ["postgresql", "--cid", "postgresql-0.1.0.0"] - setup_install' ["mylib", "--cid", "mylib-0.1.0.0", - "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] - setup_install' ["mylib", "--cid", "mylib-0.1.0.0", - "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + setup_install' + [ "mylib" + , "--cid" + , "mylib-0.1.0.0" + , "--instantiate-with" + , "Database=mysql-0.1.0.0:Database.MySQL" + ] + setup_install' + [ "mylib" + , "--cid" + , "mylib-0.1.0.0" + , "--instantiate-with" + , "Database=postgresql-0.1.0.0:Database.PostgreSQL" + ] setup_install' ["Includes2"] setup_install' ["exe"] runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/src/App.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/src/App.hs index f5213de2c16..0f356d83707 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/src/App.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes2/src/App.hs @@ -1,4 +1,5 @@ module App where + import Database.MySQL import Database.PostgreSQL import qualified Mine.MySQL diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs index 80a4c47d068..1e05a03a9dd 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 - withProjectFile "cabal.external.project" $ do - cabal "v2-build" ["exe"] - withPlan $ do - r <- runPlanExe' "exe" "exe" [] - assertOutputContains "fromList [(0,2),(2,4)]" r + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withProjectFile "cabal.external.project" $ do + cabal "v2-build" ["exe"] + withPlan $ do + r <- runPlanExe' "exe" "exe" [] + assertOutputContains "fromList [(0,2),(2,4)]" r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs index b247e56259a..48a1cd151fa 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipUnlessGhcVersion ">= 8.1" - skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 - withProjectFile "cabal.internal.project" $ do - cabal "v2-build" ["exe"] - withPlan $ do - r <- runPlanExe' "Includes3" "exe" [] - assertOutputContains "fromList [(0,2),(2,4)]" r + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withProjectFile "cabal.internal.project" $ do + cabal "v2-build" ["exe"] + withPlan $ do + r <- runPlanExe' "Includes3" "exe" [] + assertOutputContains "fromList [(0,2),(2,4)]" r diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs index d0557c828b8..2bb5e0520d8 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do skipUnlessGhcVersion ">= 8.1" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs index e0cb6d02c6e..61c4ba8c73a 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs @@ -1,4 +1,5 @@ -import qualified Data.Map as Map import Data.Map (Map) +import qualified Data.Map as Map import Foo -main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) + +main = print $ f (+ 1) (Map.fromList [(0, 1), (2, 3)] :: Map Int Int) diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs index ca9fae50d2e..8bd0b24550c 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- NB: cabal-install doesn't understand --dependency main = setupTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] - withDirectory "repo/indef-0.1.0.0" $ setup_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] + withDirectory "repo/indef-0.1.0.0" $ setup_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs index 979558be1a4..e3628255621 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs @@ -1,13 +1,14 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - withDirectory "repo/sigs-0.1.0.0" $ setup_install [] - withDirectory "repo/indef-0.1.0.0" $ setup_install [] - -- Forgot to build the instantiated versions! - withDirectory "repo/exe-0.1.0.0" $ do - -- Missing package message includes a unit identifier, - -- which wobbles when version numbers change - r <- recordMode DoNotRecord . fails $ setup' "configure" [] - assertOutputContains "indef-0.1.0.0" r - return () + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + withDirectory "repo/sigs-0.1.0.0" $ setup_install [] + withDirectory "repo/indef-0.1.0.0" $ setup_install [] + -- Forgot to build the instantiated versions! + withDirectory "repo/exe-0.1.0.0" $ do + -- Missing package message includes a unit identifier, + -- which wobbles when version numbers change + r <- recordMode DoNotRecord . fails $ setup' "configure" [] + assertOutputContains "indef-0.1.0.0" r + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs index d7ae9a1921d..d0bc7e6fd37 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs @@ -1,6 +1,7 @@ -import Test.Cabal.Prelude -import Data.List import qualified Data.Char as Char +import Data.List +import Test.Cabal.Prelude + main = setupAndCabalTest $ do skipUnlessGhcVersion ">= 8.1" ghc <- isGhcVersion "== 9.0.2 || == 9.2.* || == 9.4.* || == 9.6.*" @@ -12,13 +13,20 @@ main = setupAndCabalTest $ do withDirectory "repo/sigs-0.1.0.0" $ do -- NB: this REUSES the dist directory that we typechecked -- indefinitely, but it's OK; the recompile checker should get it. - setup_install_with_docs ["--ipid", "sigs-0.1.0.0", - "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] + setup_install_with_docs + [ "--ipid" + , "sigs-0.1.0.0" + , "--instantiate-with" + , "Data.Map=" ++ containers_id ++ ":Data.Map" + ] withDirectory "repo/indef-0.1.0.0" $ do -- Ditto. - setup_install_with_docs ["--ipid", "indef-0.1.0.0", - "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] + setup_install_with_docs + [ "--ipid" + , "indef-0.1.0.0" + , "--instantiate-with" + , "Data.Map=" ++ containers_id ++ ":Data.Map" + ] withDirectory "repo/exe-0.1.0.0" $ do setup_install [] runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" - diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs index 7cecb11eb67..edb56058c36 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs @@ -1,9 +1,9 @@ import Test.Cabal.Prelude -main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - setup_install [] - _ <- runM "touch" ["repo/indef-0.1.0.0/Foo.hs"] Nothing - setup "build" [] - runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" +main = setupAndCabalTest $ do + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + setup_install [] + _ <- runM "touch" ["repo/indef-0.1.0.0/Foo.hs"] Nothing + setup "build" [] + runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/Main.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/Main.hs index deff3c42855..cb3574631b2 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/Main.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/Main.hs @@ -1,2 +1,3 @@ import C + main = putStrLn (take 10 (show x)) diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs index 07415f6d39b..88f61543344 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/A.hs @@ -1,4 +1,6 @@ module A where + import B + data A = A B - deriving (Show) + deriving (Show) diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/B.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/B.hs index db413d7f7c6..12d85447e9f 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/B.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/B.hs @@ -1,4 +1,6 @@ module B where + import {-# SOURCE #-} A + data B = B A - deriving (Show) + deriving (Show) diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/Rec.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/Rec.hs index 41f9996fd80..38b8c8dc7a6 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/impl/Rec.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/impl/Rec.hs @@ -1,3 +1,4 @@ -module Rec(A(..), B(..)) where +module Rec (A (..), B (..)) where + import A import B diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/indef/C.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/indef/C.hs index 1d44c0b3033..b9982fec13e 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/indef/C.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/indef/C.hs @@ -1,4 +1,6 @@ module C where + import A import B + x = A (B x) diff --git a/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs index e2bc083d4df..eb8be3d3928 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - setup_install [] - runExe' "exe" [] >>= assertOutputContains "A (B (A (B" + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + setup_install [] + runExe' "exe" [] >>= assertOutputContains "A (B (A (B" diff --git a/cabal-testsuite/PackageTests/Backpack/Includes5/A.hs b/cabal-testsuite/PackageTests/Backpack/Includes5/A.hs index 8958c14a1dc..4e0ed7997ac 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes5/A.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes5/A.hs @@ -1,2 +1,3 @@ module A where + import Quxbaz diff --git a/cabal-testsuite/PackageTests/Backpack/Includes5/B.hs b/cabal-testsuite/PackageTests/Backpack/Includes5/B.hs index 9cf3a891f48..ed89aeee623 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes5/B.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes5/B.hs @@ -1,2 +1,3 @@ module B where + import Foobar -- fails diff --git a/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs index 265bcc1a802..135713a9e10 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - setup "configure" [] - r <- fails $ setup' "build" [] - assertOutputContains "Foobar" r - assertRegex - "error should be about not being able to find a module" - "Could not (find|load) module" - r - return () + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + r <- fails $ setup' "build" [] + assertOutputContains "Foobar" r + assertRegex + "error should be about not being able to find a module" + "Could not (find|load) module" + r + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Indef1/Provide.hs b/cabal-testsuite/PackageTests/Backpack/Indef1/Provide.hs index 3e2c51efa68..4fdfb485f4b 100644 --- a/cabal-testsuite/PackageTests/Backpack/Indef1/Provide.hs +++ b/cabal-testsuite/PackageTests/Backpack/Indef1/Provide.hs @@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Provide where + import Map + newtype MyMap a = MyMap (Map String a) - deriving (Functor) + deriving (Functor) diff --git a/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs index 0e94748ee42..e77308f69cd 100644 --- a/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - setup "configure" [] - setup "build" [] - return () + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + setup "build" [] + return () diff --git a/cabal-testsuite/PackageTests/Backpack/Reexport1/q/Q.hs b/cabal-testsuite/PackageTests/Backpack/Reexport1/q/Q.hs index 52ec664be3d..77343dbbd39 100644 --- a/cabal-testsuite/PackageTests/Backpack/Reexport1/q/Q.hs +++ b/cabal-testsuite/PackageTests/Backpack/Reexport1/q/Q.hs @@ -1,2 +1,3 @@ module Q where + import Map diff --git a/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs index 0070e6d5109..b8feca2d3dc 100644 --- a/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - withPackageDb $ do - withDirectory "p" $ setup_install_with_docs [] - withDirectory "q" $ do - setup_build [] - setup "haddock" [] + skipUnlessGhcVersion ">= 8.1" + withPackageDb $ do + withDirectory "p" $ setup_install_with_docs [] + withDirectory "q" $ do + setup_build [] + setup "haddock" [] diff --git a/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs b/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs index caf6922c15b..5c6d63d0e8c 100644 --- a/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = cabalTest $ do - r <- fails $ cabal' "v2-build" [] - assertOutputContains "Asdf" r - assertOutputContains "Reexport2" r + r <- fails $ cabal' "v2-build" [] + assertOutputContains "Asdf" r + assertOutputContains "Reexport2" r diff --git a/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs index 1a6fd8ba716..80627316b8c 100644 --- a/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - fails (setup' "configure" []) - >>= assertRegex "Expect problem with Asdf" "Asdf" + skipUnlessGhcVersion ">= 8.1" + fails (setup' "configure" []) + >>= assertRegex "Expect problem with Asdf" "Asdf" diff --git a/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs b/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs index 25f5c49d576..de106fe48f9 100644 --- a/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs +++ b/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs @@ -1,2 +1,3 @@ module Main where + main = return () diff --git a/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs index e93fb1bb8e7..5f0c1b0477a 100644 --- a/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - fails $ setup "configure" [] + skipUnlessGhcVersion ">= 8.1" + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/Backpack/T4754/P.hs b/cabal-testsuite/PackageTests/Backpack/T4754/P.hs index 5418cf8fc61..d6af82a48bf 100644 --- a/cabal-testsuite/PackageTests/Backpack/T4754/P.hs +++ b/cabal-testsuite/PackageTests/Backpack/T4754/P.hs @@ -1,3 +1,3 @@ module P where -import Sig +import Sig diff --git a/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs b/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs index 1b21501e163..8db1fba0a0c 100644 --- a/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs +++ b/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs @@ -1,2 +1,3 @@ import P + main = return () diff --git a/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs index 97dae2b597c..b3e2f9e2b3e 100644 --- a/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - skipUnless "no profiling libs" =<< hasProfiledLibraries - setup "configure" ["--enable-profiling"] - setup "build" [] + skipUnlessGhcVersion ">= 8.1" + skipUnless "no profiling libs" =<< hasProfiledLibraries + setup "configure" ["--enable-profiling"] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/Backpack/T5634/Go.hs b/cabal-testsuite/PackageTests/Backpack/T5634/Go.hs index 4f742fbdcfd..ee3f7a494c0 100644 --- a/cabal-testsuite/PackageTests/Backpack/T5634/Go.hs +++ b/cabal-testsuite/PackageTests/Backpack/T5634/Go.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} + module Go where + import THFuns thfun ''Int diff --git a/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs index d897955dd74..b2df773a2b9 100644 --- a/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T5634/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - setup "configure" [] - setup "build" [] + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/Backpack/T5634/sig-with-th/THFuns.hs b/cabal-testsuite/PackageTests/Backpack/T5634/sig-with-th/THFuns.hs index 84140983e0a..bfd7edbc2a4 100644 --- a/cabal-testsuite/PackageTests/Backpack/T5634/sig-with-th/THFuns.hs +++ b/cabal-testsuite/PackageTests/Backpack/T5634/sig-with-th/THFuns.hs @@ -1,2 +1,3 @@ module THFuns where + thfun _ = return [] diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs index 4d2e8f207a9..e1234e956be 100644 --- a/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs +++ b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs @@ -1,6 +1,8 @@ {-# LANGUAGE RoleAnnotations #-} + module Data.Map where + type role Map nominal representational data Map k a = Map instance Functor (Map k) where - fmap _ Map = Map + fmap _ Map = Map diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs index 1555552cd08..5c60ad2b2d9 100644 --- a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do skipUnlessGhcVersion ">= 8.1" diff --git a/cabal-testsuite/PackageTests/Backpack/T8582/Main.hs b/cabal-testsuite/PackageTests/Backpack/T8582/Main.hs index 25f5c49d576..de106fe48f9 100644 --- a/cabal-testsuite/PackageTests/Backpack/T8582/Main.hs +++ b/cabal-testsuite/PackageTests/Backpack/T8582/Main.hs @@ -1,2 +1,3 @@ module Main where + main = return () diff --git a/cabal-testsuite/PackageTests/Backpack/T8582/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/T8582/setup.test.hs index e93fb1bb8e7..5f0c1b0477a 100644 --- a/cabal-testsuite/PackageTests/Backpack/T8582/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T8582/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - fails $ setup "configure" [] + skipUnlessGhcVersion ">= 8.1" + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs b/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs index c6186ec2cb2..b7d127c6118 100644 --- a/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs +++ b/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs @@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module M where -$( [d| x = True |] ) + +$([d|x = True|]) diff --git a/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs index d897955dd74..b2df773a2b9 100644 --- a/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 8.1" - setup "configure" [] - setup "build" [] + skipUnlessGhcVersion ">= 8.1" + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/Main.hs b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/Main.hs index 4a96334c827..0975bfeee34 100644 --- a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/Main.hs +++ b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/Main.hs @@ -1,2 +1,3 @@ import Q + main = print out diff --git a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs index 5a30f6a867a..758c86d5970 100644 --- a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- GHC 8.2.2 had a regression ("unknown package: hole"), see also #4908 - skipUnlessGhcVersion ">= 8.2 && <8.2.2 || >8.2.2" - skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 - cabal "v2-build" ["all"] + -- GHC 8.2.2 had a regression ("unknown package: hole"), see also #4908 + skipUnlessGhcVersion ">= 8.2 && <8.2.2 || >8.2.2" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/impl/H.hs b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/impl/H.hs index 0644066ce81..b21485e0f2e 100644 --- a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/impl/H.hs +++ b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/impl/H.hs @@ -1,2 +1,3 @@ module H where + x = True diff --git a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/p/P.hs b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/p/P.hs index 875c3709154..d30337228c7 100644 --- a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/p/P.hs +++ b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/p/P.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} + module P where + import H + y = x diff --git a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/q/Q.hs b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/q/Q.hs index ada5c03dc56..8d52a044875 100644 --- a/cabal-testsuite/PackageTests/Backpack/bkpcabal01/q/Q.hs +++ b/cabal-testsuite/PackageTests/Backpack/bkpcabal01/q/Q.hs @@ -1,3 +1,5 @@ module Q where + import P + out = y diff --git a/cabal-testsuite/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs b/cabal-testsuite/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs index 6951caccc46..8441dc99b47 100644 --- a/cabal-testsuite/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs +++ b/cabal-testsuite/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs @@ -4,5 +4,6 @@ import Foo import System.Exit main :: IO () -main | fooTest [] = exitSuccess - | otherwise = exitFailure +main + | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs b/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs index 4880f7190b4..af920d64e17 100644 --- a/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs +++ b/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test if exitcode-stdio-1.0 benchmark builds correctly main = setupAndCabalTest $ setup_build ["--enable-benchmarks"] diff --git a/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs b/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs index 95d81b3a974..e0b0a28c37e 100644 --- a/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs +++ b/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs @@ -1,9 +1,12 @@ import Test.Cabal.Prelude + -- Test --benchmark-option(s) flags on ./Setup bench main = setupAndCabalTest $ do - setup_build ["--enable-benchmarks"] - setup "bench" [ "--benchmark-options=1 2 3" ] - setup "bench" [ "--benchmark-option=1" - , "--benchmark-option=2" - , "--benchmark-option=3" - ] + setup_build ["--enable-benchmarks"] + setup "bench" ["--benchmark-options=1 2 3"] + setup + "bench" + [ "--benchmark-option=1" + , "--benchmark-option=2" + , "--benchmark-option=3" + ] diff --git a/cabal-testsuite/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs b/cabal-testsuite/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs index 7c21bff136c..b89e40e3c64 100644 --- a/cabal-testsuite/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs +++ b/cabal-testsuite/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs @@ -1,11 +1,11 @@ module Main where -import System.Environment ( getArgs ) -import System.Exit ( exitFailure, exitSuccess ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = do - args <- getArgs - if args == ["1", "2", "3"] - then exitSuccess - else putStrLn ("Got: " ++ show args) >> exitFailure + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs b/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs index eee6c0dd269..db40b3918cf 100644 --- a/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs +++ b/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs @@ -1,29 +1,31 @@ import Test.Cabal.Prelude -import Distribution.Version -import Distribution.Simple.LocalBuildInfo +import Control.Monad.IO.Class import Distribution.Package import Distribution.PackageDescription -import Distribution.Types.UnqualComponentName -import Control.Monad.IO.Class import Distribution.Simple.Configure +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Version main = setupAndCabalTest $ do - assertOutputDoesNotContain "unknown section type" - =<< setup' "configure" ["--enable-benchmarks"] - lbi <- getLocalBuildInfoM - let gotBenchmark = head $ benchmarks (localPkgDescr lbi) - assertEqual "benchmarkName" - (mkUnqualComponentName "dummy") - (benchmarkName gotBenchmark) - assertEqual "benchmarkInterface" - (BenchmarkExeV10 (mkVersion [1,0]) "dummy.hs") - (benchmarkInterface gotBenchmark) - -- NB: Not testing targetBuildDepends (benchmarkBuildInfo gotBenchmark), - -- as the dependency varies with cabal-install - assertEqual - "benchmarkBuildInfo/hsSourceDirs" - [sameDirectory] - (hsSourceDirs (benchmarkBuildInfo gotBenchmark)) - return () + assertOutputDoesNotContain "unknown section type" + =<< setup' "configure" ["--enable-benchmarks"] + lbi <- getLocalBuildInfoM + let gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual + "benchmarkName" + (mkUnqualComponentName "dummy") + (benchmarkName gotBenchmark) + assertEqual + "benchmarkInterface" + (BenchmarkExeV10 (mkVersion [1, 0]) "dummy.hs") + (benchmarkInterface gotBenchmark) + -- NB: Not testing targetBuildDepends (benchmarkBuildInfo gotBenchmark), + -- as the dependency varies with cabal-install + assertEqual + "benchmarkBuildInfo/hsSourceDirs" + [sameDirectory] + (hsSourceDirs (benchmarkBuildInfo gotBenchmark)) + return () diff --git a/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs b/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs index 96c0a362c5b..c150092fa02 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + main = cabalTest $ do - r <- fails $ cabal' "v2-build" [] - assertOutputContains "cycl" r -- match cyclic or cycle - assertOutputContains "bar" r - assertOutputContains "foo" r - assertOutputContains "DepCycle" r + r <- fails $ cabal' "v2-build" [] + assertOutputContains "cycl" r -- match cyclic or cycle + assertOutputContains "bar" r + assertOutputContains "foo" r + assertOutputContains "DepCycle" r diff --git a/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs index d9795f92efa..ff05bfc7c10 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - r <- fails $ setup' "configure" [] - assertOutputContains "cycl" r -- match cyclic or cycle - assertOutputContains "bar" r - assertOutputContains "foo" r + r <- fails $ setup' "configure" [] + assertOutputContains "cycl" r -- match cyclic or cycle + assertOutputContains "bar" r + assertOutputContains "foo" r diff --git a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs index 4dde5c403aa..619c73b7e46 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -1,22 +1,21 @@ module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where -import Test.Tasty.HUnit +import Control.Exception +import Data.List import PackageTests.PackageTester import System.FilePath -import Data.List -import Control.Exception +import Test.Tasty.HUnit import Prelude hiding (catch) - suite :: FilePath -> Assertion suite ghcPath = do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] - result <- cabal_build spec ghcPath - do - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - let sb = "Could not find module `Prelude'" - assertBool ("cabal output should be "++show sb) $ - sb `isInfixOf` outputText result - `catch` \exc -> do - putStrLn $ "Cabal result was "++show result - throwIO (exc :: SomeException) + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] + result <- cabal_build spec ghcPath + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + let sb = "Could not find module `Prelude'" + assertBool ("cabal output should be " ++ show sb) $ + sb `isInfixOf` outputText result + `catch` \exc -> do + putStrLn $ "Cabal result was " ++ show result + throwIO (exc :: SomeException) diff --git a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs index 6286d4982f7..a4d185b0547 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -1,22 +1,21 @@ module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where -import Test.Tasty.HUnit +import Control.Exception +import Data.List import PackageTests.PackageTester import System.FilePath -import Data.List -import Control.Exception +import Test.Tasty.HUnit import Prelude hiding (catch) - suite :: FilePath -> Assertion suite ghcPath = do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] - result <- cabal_build spec ghcPath - do - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - let sb = "Could not find module `Prelude'" - assertBool ("cabal output should be "++show sb) $ - sb `isInfixOf` outputText result - `catch` \exc -> do - putStrLn $ "Cabal result was "++show result - throwIO (exc :: SomeException) + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] + result <- cabal_build spec ghcPath + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + let sb = "Could not find module `Prelude'" + assertBool ("cabal output should be " ++ show sb) $ + sb `isInfixOf` outputText result + `catch` \exc -> do + putStrLn $ "Cabal result was " ++ show result + throwIO (exc :: SomeException) diff --git a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs index a775b158cc1..d2344bec499 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -2,6 +2,6 @@ import qualified Data.ByteString.Char8 as C import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - let text = "lemon" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs index 069816c1e91..b6865772894 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -1,6 +1,6 @@ -import Text.PrettyPrint import MyLibrary +import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - myLibFunc + putStrLn (render (text "foo")) + myLibFunc diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs index f8ce6269208..56aef023045 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + -- Test attempt to have executable depend on internal -- library, but setup-version is too old. main = setupAndCabalTest $ do - r <- fails $ setup' "configure" [] - -- Should tell you how to enable the desired behavior - let sb = "library which is defined within the same package." - assertOutputContains sb r + r <- fails $ setup' "configure" [] + -- Should tell you how to enable the desired behavior + let sb = "library which is defined within the same package." + assertOutputContains sb r diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs index e5fe782b4ab..8787ea0092b 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["lemon"] + cabal "v2-build" ["lemon"] diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs index 069816c1e91..b6865772894 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -1,6 +1,6 @@ -import Text.PrettyPrint import MyLibrary +import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - myLibFunc + putStrLn (render (text "foo")) + myLibFunc diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs index 867e5777765..fd67e1f1ab2 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + -- Test executable depends on internal library. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs index 85dc40b882e..a292742ed36 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc internal" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs index 069816c1e91..b6865772894 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -1,6 +1,6 @@ -import Text.PrettyPrint import MyLibrary +import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - myLibFunc + putStrLn (render (text "foo")) + myLibFunc diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs index e36e33823d2..214d5a91828 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs @@ -1,9 +1,10 @@ import Test.Cabal.Prelude + main = setupAndCabalTest . withPackageDb $ do - withDirectory "to-install" $ setup_install [] - setup_build [] - r <- runExe' "lemon" [] - assertEqual - ("executable should have linked with the internal library") - ("foo foo myLibFunc internal") - (concatOutput (resultOutput r)) + withDirectory "to-install" $ setup_install [] + setup_build [] + r <- runExe' "lemon" [] + assertEqual + ("executable should have linked with the internal library") + ("foo foo myLibFunc internal") + (concatOutput (resultOutput r)) diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs index b92822a3f05..c8ce69a229b 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc installed" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs index 85dc40b882e..a292742ed36 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc internal" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs index 069816c1e91..b6865772894 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -1,6 +1,6 @@ -import Text.PrettyPrint import MyLibrary +import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - myLibFunc + putStrLn (render (text "foo")) + myLibFunc diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs index 549e8bf8bb4..fddbd8d2b59 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + -- Test that internal library is preferred to an installed on -- with the same name and LATER version main = setupAndCabalTest . withPackageDb $ do - withDirectory "to-install" $ setup_install [] - setup_build [] - r <- runExe' "lemon" [] - assertEqual - ("executable should have linked with the internal library") - ("foo foo myLibFunc internal") - (concatOutput (resultOutput r)) + withDirectory "to-install" $ setup_install [] + setup_build [] + r <- runExe' "lemon" [] + assertEqual + ("executable should have linked with the internal library") + ("foo foo myLibFunc internal") + (concatOutput (resultOutput r)) diff --git a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs index b92822a3f05..c8ce69a229b 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc installed" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs index a775b158cc1..d2344bec499 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -2,6 +2,6 @@ import qualified Data.ByteString.Char8 as C import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - let text = "lemon" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs index 9fc719b9c71..2b7df87e14f 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -2,6 +2,6 @@ import qualified Data.ByteString.Char8 as C import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - let text = "pineapple" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "pineapple" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs index 613ff39d640..517e7add9e1 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude + -- Test "old build-dep behavior", where we should get the -- same package dependencies on all targets if setup-version -- is sufficiently old. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs index a775b158cc1..d2344bec499 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -2,6 +2,6 @@ import qualified Data.ByteString.Char8 as C import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - let text = "lemon" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs index 790afd6aa2b..55b90652d46 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs @@ -1,11 +1,13 @@ import Test.Cabal.Prelude + -- Test "new build-dep behavior", where each target gets -- separate dependencies. This tests that an executable -- dep does not leak into the library. main = setupAndCabalTest $ do - setup "configure" [] - r <- fails $ setup' "build" [] - assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r - assertRegex - "error should be \"Could not find module `Text\\.PrettyPrint\"" - "(Could not (load|find) module|Failed to load interface for).*Text\\.PrettyPrint" r + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not (load|find) module|Failed to load interface for).*Text\\.PrettyPrint" + r diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs index ffdccbc57ad..6b23438b510 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs @@ -1,5 +1,5 @@ import qualified Data.ByteString.Char8 as C main = do - let text = "lemon" - C.putStrLn $ C.pack text + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs index 27267c84362..fa7b34156f4 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- This is a control on ../TargetSpecificDeps1/setup.test.hs; it should -- succeed. main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs index 52980f5bb7c..0ee8a579aa6 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -5,6 +5,6 @@ import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs index a775b158cc1..d2344bec499 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -2,6 +2,6 @@ import qualified Data.ByteString.Char8 as C import Text.PrettyPrint main = do - putStrLn (render (text "foo")) - let text = "lemon" - C.putStrLn $ C.pack text + putStrLn (render (text "foo")) + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs index 7132bb9c9e8..7603bab50a3 100644 --- a/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs @@ -1,11 +1,13 @@ import Test.Cabal.Prelude + -- Test "new build-dep behavior", where each target gets -- separate dependencies. This tests that an library -- dep does not leak into the executable. main = setupAndCabalTest $ do - setup "configure" [] - r <- fails $ setup' "build" [] - assertRegex "error should be in lemon.hs" "^lemon.hs:" r - assertRegex - "error should be \"Could not find module `Text\\.PrettyPrint\"" - "(Could not (load|find) module|Failed to load interface for).*Text\\.PrettyPrint" r + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in lemon.hs" "^lemon.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not (load|find) module|Failed to load interface for).*Text\\.PrettyPrint" + r diff --git a/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs b/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs index 507d0d9a4fe..2b72b43cc42 100644 --- a/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs @@ -1,10 +1,11 @@ import Test.Cabal.Prelude + -- Test error message we report when a non-buildable target is -- requested to be built -- TODO: We can give a better error message here, see #3858. -- NB: Do NOT test on cabal-install, as we fail differently -- in that case main = setupTest $ do - setup "configure" [] - assertOutputContains "the component is marked as disabled" - =<< fails (setup' "build" ["not-buildable-exe"]) + setup "configure" [] + assertOutputContains "the component is marked as disabled" + =<< fails (setup' "build" ["not-buildable-exe"]) diff --git a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs index db38bc68347..c079bccb10d 100644 --- a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs +++ b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs @@ -1,4 +1,4 @@ -import Module (message) import Distribution.Simple +import Module (message) main = putStrLn ("Setup.hs: " ++ message) >> defaultMain diff --git a/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs b/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs index 01597416321..307c6611107 100644 --- a/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs +++ b/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF zero-to-one #-} + module Main where a :: String diff --git a/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs b/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs index 09c949ab176..b9dfebe75f7 100644 --- a/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs +++ b/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs @@ -5,7 +5,7 @@ import System.IO main :: IO () main = do - (_:source:target:_) <- getArgs + (_ : source : target : _) <- getArgs let f '0' = '1' f c = c - writeFile target . map f =<< readFile source + writeFile target . map f =<< readFile source diff --git a/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs b/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs index 47f69cba6f4..7d38835e851 100644 --- a/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test build-tool-depends between two packages main = cabalTest $ do - cabal "v2-build" ["client"] + cabal "v2-build" ["client"] diff --git a/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs b/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs index 4f92e937e2e..43852982c98 100644 --- a/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test missing internal build-tool-depends does indeed fail main = setupAndCabalTest $ do - assertOutputContains "missing internal executable" - =<< fails (setup' "configure" []) + assertOutputContains "missing internal executable" + =<< fails (setup' "configure" []) diff --git a/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs b/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs index bc73d0c4747..ca6b7cb06c2 100644 --- a/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs +++ b/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test legacy `build-tools` dependency on external package -- We use one of the hard-coded names to accomplish this main = cabalTest $ do - cabal "v2-build" ["client"] + cabal "v2-build" ["client"] diff --git a/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs b/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs index 2573eba65c2..2cb97f12f51 100644 --- a/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs +++ b/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF happy #-} + module Main where a :: String diff --git a/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs b/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs index 09c949ab176..b9dfebe75f7 100644 --- a/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs +++ b/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs @@ -5,7 +5,7 @@ import System.IO main :: IO () main = do - (_:source:target:_) <- getArgs + (_ : source : target : _) <- getArgs let f '0' = '1' f c = c - writeFile target . map f =<< readFile source + writeFile target . map f =<< readFile source diff --git a/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs b/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs index eae7f4476f3..c619e465927 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF my-foreign-preprocessor #-} + module A where a :: String diff --git a/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs b/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs index 9860683f7b0..6b33ccdf775 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs @@ -7,9 +7,9 @@ import System.Environment -- Test PATH-munging -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - path <- liftIO $ getEnv "PATH" - cwd <- testCurrentDir <$> getTestEnv - r <- withEnv [("PATH", Just $ cwd ++ ":" ++ path)] $ setup_build [] - runExe' "hello-world" [] - >>= assertOutputContains "1111" + skipIfWindows + path <- liftIO $ getEnv "PATH" + cwd <- testCurrentDir <$> getTestEnv + r <- withEnv [("PATH", Just $ cwd ++ ":" ++ path)] $ setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "1111" diff --git a/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs b/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs index e437123fa59..5400b38bf8e 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF my-cpp #-} + module A where a :: String diff --git a/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs b/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs index 09c949ab176..b9dfebe75f7 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs @@ -5,7 +5,7 @@ import System.IO main :: IO () main = do - (_:source:target:_) <- getArgs + (_ : source : target : _) <- getArgs let f '0' = '1' f c = c - writeFile target . map f =<< readFile source + writeFile target . map f =<< readFile source diff --git a/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs b/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs index 445be513cec..27d45c63f15 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test leacy `build-tools` dependency on internal library main = cabalTest $ do - cabal "v2-build" ["foo", "hello-world"] + cabal "v2-build" ["foo", "hello-world"] diff --git a/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs b/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs index 8db6edcbd80..4a248eca712 100644 --- a/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test PATH-munging main = setupAndCabalTest $ do - setup_build [] - runExe' "hello-world" [] - >>= assertOutputContains "1111" + setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "1111" diff --git a/cabal-testsuite/PackageTests/BuildableField/setup.test.hs b/cabal-testsuite/PackageTests/BuildableField/setup.test.hs index 6342e427569..62bd3154e88 100644 --- a/cabal-testsuite/PackageTests/BuildableField/setup.test.hs +++ b/cabal-testsuite/PackageTests/BuildableField/setup.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + -- Test that setup can choose flags to disable building a component when that -- component's dependencies are unavailable. The build should succeed without -- requiring the component's dependencies or imports. main = setupAndCabalTest $ do - r <- setup' "configure" ["-v"] - assertOutputContains "Flags chosen: build-exe=False" r - setup "build" [] + r <- setup' "configure" ["-v"] + assertOutputContains "Flags chosen: build-exe=False" r + setup "build" [] diff --git a/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs b/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs index dbc10efa7a3..0cddbd5de47 100644 --- a/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs +++ b/cabal-testsuite/PackageTests/CCompilerOverride/setup.test.hs @@ -7,12 +7,13 @@ main = setupAndCabalTest $ do skipUnlessGhcVersion ">= 8.8" isWin <- isWindows ghc94 <- isGhcVersion "== 9.4.*" - env <- getTestEnv - let pwd = testCurrentDir env + env <- getTestEnv + let pwd = testCurrentDir env customCC = pwd ++ "/custom-cc" ++ if isWin then ".bat" else "" expectBrokenIf (isWin && ghc94) 8451 $ do - setup "configure" + setup + "configure" [ "--ghc-option=-DNOERROR1" , "--ghc-option=-optc=-DNOERROR2" , "--ghc-option=-optP=-DNOERROR3" diff --git a/cabal-testsuite/PackageTests/CMain/Bar.hs b/cabal-testsuite/PackageTests/CMain/Bar.hs index 69ec792cc9c..cca6e8387e4 100644 --- a/cabal-testsuite/PackageTests/CMain/Bar.hs +++ b/cabal-testsuite/PackageTests/CMain/Bar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-} + module Bar where bar :: IO () diff --git a/cabal-testsuite/PackageTests/CMain/setup.test.hs b/cabal-testsuite/PackageTests/CMain/setup.test.hs index af4aa089c58..174a3515178 100644 --- a/cabal-testsuite/PackageTests/CMain/setup.test.hs +++ b/cabal-testsuite/PackageTests/CMain/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test building an executable whose main() function is defined in a C -- file main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs b/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs index af4aa089c58..174a3515178 100644 --- a/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs +++ b/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test building an executable whose main() function is defined in a C -- file main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/CabalMacros/Mdl.hs b/cabal-testsuite/PackageTests/CabalMacros/Mdl.hs index abd5d06f140..2df18eb626b 100644 --- a/cabal-testsuite/PackageTests/CabalMacros/Mdl.hs +++ b/cabal-testsuite/PackageTests/CabalMacros/Mdl.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Mdl where answer :: Int diff --git a/cabal-testsuite/PackageTests/CabalMacros/setup.test.hs b/cabal-testsuite/PackageTests/CabalMacros/setup.test.hs index 16fdbe51277..17486863ad0 100644 --- a/cabal-testsuite/PackageTests/CabalMacros/setup.test.hs +++ b/cabal-testsuite/PackageTests/CabalMacros/setup.test.hs @@ -1,18 +1,19 @@ -import Test.Cabal.Prelude import qualified Data.ByteString.Char8 as BS8 +import Test.Cabal.Prelude main = setupAndCabalTest $ do - env <- getTestEnv - let mode = testRecordMode env + env <- getTestEnv + let mode = testRecordMode env - setup_build [] - let autogenDir = testDistDir env "build" "autogen" + setup_build [] + let autogenDir = testDistDir env "build" "autogen" - defaultRecordMode RecordAll $ recordHeader ["cabal_macros.h"] - contents <- liftIO $ BS8.readFile $ autogenDir "cabal_macros.h" - -- we are only interested in CURRENT_ lines - -- others change a lot based on available tools in the environment - let contents' = BS8.unlines - $ filter (BS8.isInfixOf $ BS8.pack "CURRENT") - $ BS8.lines contents - liftIO $ BS8.appendFile (testActualFile env) contents' + defaultRecordMode RecordAll $ recordHeader ["cabal_macros.h"] + contents <- liftIO $ BS8.readFile $ autogenDir "cabal_macros.h" + -- we are only interested in CURRENT_ lines + -- others change a lot based on available tools in the environment + let contents' = + BS8.unlines $ + filter (BS8.isInfixOf $ BS8.pack "CURRENT") $ + BS8.lines contents + liftIO $ BS8.appendFile (testActualFile env) contents' diff --git a/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs b/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs index db7621a77d0..a44caa5ddac 100644 --- a/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs +++ b/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs @@ -1,31 +1,33 @@ import Test.Cabal.Prelude import Control.Monad -import Distribution.Version -import Distribution.Simple.LocalBuildInfo import Distribution.Package -import Distribution.Types.Dependency import Distribution.PackageDescription -import Language.Haskell.Extension (Language(..)) +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.Dependency import Distribution.Utils.Path +import Distribution.Version +import Language.Haskell.Extension (Language (..)) -- Test that setup parses '^>=' operator correctly. -- Don't bother with the cabal-install test as the build-depends -- is updated by this point so that we lost the caret parsing. main = setupTest $ do - -- Don't run this for GHC 7.0/7.2, which doesn't have a recent - -- enough version of pretty. (But this is pretty dumb.) - skipUnlessGhcVersion ">= 7.3" - assertOutputDoesNotContain "Parse of field 'build-depends' failed" - =<< setup' "configure" [] - lbi <- getLocalBuildInfoM + -- Don't run this for GHC 7.0/7.2, which doesn't have a recent + -- enough version of pretty. (But this is pretty dumb.) + skipUnlessGhcVersion ">= 7.3" + assertOutputDoesNotContain "Parse of field 'build-depends' failed" + =<< setup' "configure" [] + lbi <- getLocalBuildInfoM - let Just gotLib = library (localPkgDescr lbi) - bi = libBuildInfo gotLib - assertEqual "defaultLanguage" (Just Haskell2010) (defaultLanguage bi) - forM_ (targetBuildDepends bi) $ \(Dependency pn vr _) -> - when (pn == mkPackageName "pretty") $ - assertEqual "targetBuildDepends/pretty" - vr (majorBoundVersion (mkVersion [1,1,1,0])) - assertEqual "hsSourceDirs" [sameDirectory] (hsSourceDirs bi) - return () + let Just gotLib = library (localPkgDescr lbi) + bi = libBuildInfo gotLib + assertEqual "defaultLanguage" (Just Haskell2010) (defaultLanguage bi) + forM_ (targetBuildDepends bi) $ \(Dependency pn vr _) -> + when (pn == mkPackageName "pretty") $ + assertEqual + "targetBuildDepends/pretty" + vr + (majorBoundVersion (mkVersion [1, 1, 1, 0])) + assertEqual "hsSourceDirs" [sameDirectory] (hsSourceDirs bi) + return () diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsExtraLibDirs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsExtraLibDirs/cabal.test.hs index c737bd44a73..c9fb01de214 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsExtraLibDirs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsExtraLibDirs/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `cc-options`, use `extra-lib-dirs` instead of `-L`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsInclude/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsInclude/cabal.test.hs index ffffa21236f..a27ddb7c27b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsInclude/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CCOptionsInclude/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `cc-options`, use `include-dirs` instead of `-I`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CppNotPortable/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CppNotPortable/cabal.test.hs index 6696307dde0..68af989e86b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CppNotPortable/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CppNotPortable/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `cpp-options`, do not use use non portable flags. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOptionsExtraLibraries/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOptionsExtraLibraries/cabal.test.hs index bc28ce906e5..5cd69c55fac 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOptionsExtraLibraries/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOptionsExtraLibraries/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `cxx-options`, use `extra-libraries` instead of `-l`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOs/cabal.test.hs index af9d416967c..e0553c48a35 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/COptions/CxxOs/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `cxx-options`, do not use `-O1`. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/AutoGenMods/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/AutoGenMods/cabal.test.hs index 01f93e1b837..96651dcaae1 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/AutoGenMods/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/AutoGenMods/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- autogenerated modules in `autogen-modules` w/ ≥ 2.0. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/CustomSetup/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/CustomSetup/cabal.test.hs index e338049d49b..f2436e898a4 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/CustomSetup/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/CustomSetup/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `custom-setup` on ≥1.24. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultExtension/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultExtension/cabal.test.hs index ed1e8720e0c..bf232c7087d 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultExtension/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultExtension/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `default-extensions` need ≥1.10. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguage/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguage/cabal.test.hs index aefcb6e899e..f3b83eb6100 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguage/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguage/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `default-language` need ≥1.10. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguageSpec/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguageSpec/cabal.test.hs index 15dc554b94e..4cefab2fc59 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguageSpec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/DefaultLanguageSpec/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- You need to specify `default-language`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtensionBreak/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtensionBreak/cabal.test.hs index f72156fdb47..223e31604ba 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtensionBreak/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtensionBreak/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Some extension need ≥1.2. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Extensions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Extensions/cabal.test.hs index e83235af117..8a2e6d9f0aa 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Extensions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Extensions/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `extensions` deprecated. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDoc/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDoc/cabal.test.hs index d116082bb1e..e412ac5ba43 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDoc/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDoc/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `extra-doc-files` need ≥1.18. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDynamicLibraryFlavour/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDynamicLibraryFlavour/cabal.test.hs index ea93456bba3..ffcf4fb4ef5 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDynamicLibraryFlavour/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraDynamicLibraryFlavour/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `extra-dynamic-library-flavour` need ≥3.0. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraFrameworkDirs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraFrameworkDirs/cabal.test.hs index 058046b0fcc..dbcdc0f7e25 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraFrameworkDirs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/ExtraFrameworkDirs/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `extra-framework-dirs` need ≥1.24. (just warning) -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Mixins/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Mixins/cabal.test.hs index b1d092438d8..0c1112acd8b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Mixins/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Mixins/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `mixins` need ≥2.0. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/MultiLibs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/MultiLibs/cabal.test.hs index 927052c9945..12aa7ab4b20 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/MultiLibs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/MultiLibs/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Multilibs or named libs need ≥2.0. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Reexported/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Reexported/cabal.test.hs index e173ed3f705..831428225a8 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Reexported/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Reexported/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `reexported-module` need ≥1.22. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/SourceRepository/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/SourceRepository/cabal.test.hs index 36ef8b047c6..c6b211df6db 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/SourceRepository/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/SourceRepository/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `source-repository` need ≥1.6. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Sources/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Sources/cabal.test.hs index 5b8c31c0b66..6533f9833e0 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Sources/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Sources/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `cmm-sources` and friends need ≥3.0. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Testsuite1.8/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Testsuite1.8/cabal.test.hs index 91087a24a25..c10218f8499 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Testsuite1.8/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/Testsuite1.8/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- test-suite need ≥1.8. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/VirtualModules/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/VirtualModules/cabal.test.hs index 7a92518d401..398302ce8d5 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/VirtualModules/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/CabalVersion/VirtualModules/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `virtual-modules` need ≥2.2. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/DeprecatedExtension/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/DeprecatedExtension/cabal.test.hs index 73f0a75bdee..e5f2bcd235b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/DeprecatedExtension/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/DeprecatedExtension/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Deprecated extension. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ImpossibleVersionRangeLib/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ImpossibleVersionRangeLib/cabal.test.hs index b87d9515df6..ab11b7641a0 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ImpossibleVersionRangeLib/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ImpossibleVersionRangeLib/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Impossible version range for internal library. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/InvalidTestedWithRange/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/InvalidTestedWithRange/cabal.test.hs index b6c5f5181aa..18960bb2dbc 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/InvalidTestedWithRange/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/InvalidTestedWithRange/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Invalid `tested-with` range. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/LanguageAsExtension/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/LanguageAsExtension/cabal.test.hs index 777c89b63da..6f3a5964e20 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/LanguageAsExtension/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/LanguageAsExtension/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Language listed as extension. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoBuildTypeSpecified/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoBuildTypeSpecified/cabal.test.hs index 6a714da135d..eca771e191e 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoBuildTypeSpecified/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoBuildTypeSpecified/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No build-type specified. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCategory/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCategory/cabal.test.hs index 50fb012514d..68b38f16ae2 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCategory/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCategory/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- No category. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCustom/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCustom/cabal.test.hs index 9856b9b34c2..eae6f1de82e 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCustom/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoCustom/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No custom-setup with build-type: simple. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoDescription/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoDescription/cabal.test.hs index ee2c3ac0018..441e4a82b13 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoDescription/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoDescription/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- No description. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoMaintainer/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoMaintainer/cabal.test.hs index 832b74a21a3..ece93fd3a3f 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoMaintainer/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoMaintainer/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- No maintainer. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoSynopsis/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoSynopsis/cabal.test.hs index f2ee05944ac..e0b93ed0bc7 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoSynopsis/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoSynopsis/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- No synopsis. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoZPrefix/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoZPrefix/cabal.test.hs index 66da874df88..928f0275707 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoZPrefix/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/NoZPrefix/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- no z-prefixed package names -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ShortDescription/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ShortDescription/cabal.test.hs index 723a2dca2dc..da3b362038e 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ShortDescription/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/ShortDescription/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Description should be longer than synopsis. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownCompiler/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownCompiler/cabal.test.hs index ac58286df3d..f39cc42de38 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownCompiler/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownCompiler/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown compiler in `tested-with`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownExtension/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownExtension/cabal.test.hs index 622972f0667..ca8f8753c4f 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownExtension/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownExtension/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown extension. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownLanguage/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownLanguage/cabal.test.hs index 0c728375b0a..2b41a4aa199 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownLanguage/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Fields/UnknownLanguage/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown language. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCOptions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCOptions/cabal.test.hs index d4f68cb45fb..564a73afa3b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCOptions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCOptions/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Tricky option in `ghc-options`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCProfOptions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCProfOptions/cabal.test.hs index f80a80c47e2..ab1b419c92e 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCProfOptions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCProfOptions/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Tricky option in `ghc-prof-options`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCSharedOptions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCSharedOptions/cabal.test.hs index 672a005ed41..41e2268cab9 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCSharedOptions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/GHCOptions/GHCSharedOptions/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Tricky option in `ghc-shared-options`. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/Compatibility/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/Compatibility/cabal.test.hs index f9314ffefe7..0aeb2c3d6ea 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/Compatibility/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/Compatibility/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Compatibility w/ ≤1.4. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoFileSpecified/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoFileSpecified/cabal.test.hs index fb5a68e5bac..721feaae196 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoFileSpecified/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoFileSpecified/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `license-file` missing. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoLicense/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoLicense/cabal.test.hs index 5fca021e0e4..c47f368d1d1 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoLicense/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoLicense/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No license. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoneLicense/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoneLicense/cabal.test.hs index 8f0167886bb..5fe19f78015 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoneLicense/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/NoneLicense/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- NONE license. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousLicense/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousLicense/cabal.test.hs index 37ee44418e0..a909d326839 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousLicense/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousLicense/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Suspicious license BSD4. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousVersion/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousVersion/cabal.test.hs index 9ba2f98306d..db75b9a1541 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousVersion/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/SuspiciousVersion/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Suspicious license version. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/UnknownLicence/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/UnknownLicence/cabal.test.hs index e044445d913..4d3a7f504f6 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/UnknownLicence/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/UnknownLicence/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Unknown license. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/WarnAllRightsReserved/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/WarnAllRightsReserved/cabal.test.hs index 7719c9ffd9e..160f0d22b9d 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/WarnAllRightsReserved/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/License/WarnAllRightsReserved/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Dubious AllRightsReserved. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.test.hs index 313653d572f..6f50f962d02 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/AbsolutePath/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Absolute path. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/DistPoint/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/DistPoint/cabal.test.hs index 88daf4d4c02..c8a657aa985 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/DistPoint/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/DistPoint/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Points to dist. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/InvalidWin/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/InvalidWin/cabal.test.hs index e99fccc6bc4..90c8c1a3021 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/InvalidWin/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/InvalidWin/cabal.test.hs @@ -8,6 +8,6 @@ main = cabalTest . withSourceCopy $ do cwd <- testCurrentDir <$> getTestEnv liftIO $ createDirectoryIfMissing False $ cwd "n?ul" liftIO $ writeFile (cwd "n?ul" "test.a") "" - -- A directory named like `n?ul` on Windows will make external - -- tools like git — and hence the whole testsuite — error. + -- A directory named like `n?ul` on Windows will make external + -- tools like git — and hence the whole testsuite — error. fails $ cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs index 60a32cb7374..0af71e75f3b 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RelativeOutside/RelativeOutsideInner/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RelativeOutside/RelativeOutsideInner/cabal.test.hs index 09a670ffb24..568936da2af 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RelativeOutside/RelativeOutsideInner/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RelativeOutside/RelativeOutsideInner/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Relative filepath outside source tree. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOther/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOther/cabal.test.hs index c4993d305a0..02c67dce074 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOther/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOther/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-modules` have to appear in `other-modules` or -- `exposed-modules`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherBenchmark/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherBenchmark/cabal.test.hs index f5bae2b7719..ef669020855 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherBenchmark/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherBenchmark/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-modules` have to appear in `other-modules` or -- `exposed-modules` (benchmark). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherExe/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherExe/cabal.test.hs index 5ae464e34c8..4f7d17e4630 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherExe/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-modules` have to appear in `other-modules` or -- `exposed-modules` (executables). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherTestsuite/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherTestsuite/cabal.test.hs index b1376d3e707..6f1d11ddd15 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherTestsuite/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenExposedOtherTestsuite/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-modules` have to appear in `other-modules` or -- `exposed-modules` (testsuite). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludes/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludes/cabal.test.hs index 4aa8ec52fa3..858196e67fe 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludes/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludes/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-includes` should appear in `install-includes` or -- `includes`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesBenchmark/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesBenchmark/cabal.test.hs index b77926c7b20..004a1065e25 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesBenchmark/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesBenchmark/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-includes` should appear in `install-includes` or -- `includes` (benchmark). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesExe/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesExe/cabal.test.hs index 16bea7097fa..eb7dcb47795 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesExe/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-includes` should appear in `install-includes` or -- `includes` (executable). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesTestsuite/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesTestsuite/cabal.test.hs index 4831b0d10ce..fe1bd537675 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesTestsuite/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/AutogenIncludesTestsuite/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- All `autogen-includes` should appear in `install-includes` or -- `includes` (testsuite). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersion/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersion/cabal.test.hs index 9ea2870a5a7..1395777f980 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersion/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersion/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- You need `cabal-version` ≥ 1.18 to use C/C++/obj-C source files -- in `main-is`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersionTestsuite/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersionTestsuite/cabal.test.hs index 321d9f405c0..1e76538b114 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersionTestsuite/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/CMainIsVersionTestsuite/cabal.test.hs @@ -2,5 +2,7 @@ import Test.Cabal.Prelude -- You need `cabal-version` ≥ 1.18 to use C/C++/obj-C source files -- in `main-is`. (testsuite) -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIs/cabal.test.hs index 7b9587e9dd4..e8d1f575126 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIs/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `main-is` has to be a `.hs` or `.lhs` file (or C* source file). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsBenchmark/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsBenchmark/cabal.test.hs index 8a04366f0ff..bd600514882 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsBenchmark/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsBenchmark/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `main-is` has to be a `.hs` or `.lhs` file (or C* source file) (benchmark). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsTestsuite/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsTestsuite/cabal.test.hs index 9e146620e9c..03f256b2bf7 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsTestsuite/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/MalformedMainIsTestsuite/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `main-is` has to be a `.hs` or `.lhs` file (or C* source file) (testsuite). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoBody/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoBody/cabal.test.hs index fa4a9ef2372..a4ac307e0ff 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoBody/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoBody/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No exec, library, test or benchmark. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.test.hs index 0d5a1a175af..43dcc0fb04f 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoDupNames/cabal.test.hs @@ -3,5 +3,7 @@ import Test.Cabal.Prelude -- Duplicate section names. -- This will be caught by an `error` before `check` has the opportunity -- to report it. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoExposedModules/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoExposedModules/cabal.test.hs index 603e9a04ed7..9e69e252e95 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoExposedModules/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoExposedModules/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- No exposed modules. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoInternalNameClash/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoInternalNameClash/cabal.test.hs index 66ad00ddbd2..9184e6c7e44 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoInternalNameClash/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoInternalNameClash/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Internal library / package name clash. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoMainIs/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoMainIs/cabal.test.hs index b7417753322..230a224c2f5 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoMainIs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/NoMainIs/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Missing `main-is`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/OkDupNamesExe/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/OkDupNamesExe/cabal.test.hs index cff44832998..955846d7ffc 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/OkDupNamesExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/OkDupNamesExe/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- It is OK for executables to have the same name of the external library. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/VersionSignatures/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/VersionSignatures/cabal.test.hs index da01864a554..ae1612abfa7 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/VersionSignatures/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Sanity/VersionSignatures/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- `signatures` field used with cabal-version < 2.0 -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoGoodRelative/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoGoodRelative/cabal.test.hs index 5807e5dd6b6..e8e8088c33f 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoGoodRelative/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoGoodRelative/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `subdir` is not a good relative path. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoLocation/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoLocation/cabal.test.hs index 1c134698b82..9f843722bb8 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoLocation/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoLocation/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No `location`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoModuleCVS/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoModuleCVS/cabal.test.hs index 579548e5ae6..8783bf60937 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoModuleCVS/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoModuleCVS/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No `module` (CVS only). -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoType/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoType/cabal.test.hs index 082ea0f5194..54c1ed68412 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoType/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NoType/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No `type`. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NonRecognisedRepo/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NonRecognisedRepo/cabal.test.hs index d7cd8fd959e..8a9639ef15a 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NonRecognisedRepo/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/NonRecognisedRepo/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Non-regonised (head, this, etc.) repo. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/SubdirRelative/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/SubdirRelative/cabal.test.hs index b29b30c2cc4..9060e79de14 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/SubdirRelative/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/SubdirRelative/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `subdir` is not a relative path. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/ThisTag/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/ThisTag/cabal.test.hs index 4b7ef7bab88..986a3fe00f7 100644 --- a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/ThisTag/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/SourceRepos/ThisTag/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `tag` needed in `this` repos. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/DifferentGhcOptions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/DifferentGhcOptions/cabal.test.hs index 425b3bfe301..d57f8e16590 100644 --- a/cabal-testsuite/PackageTests/Check/DifferentGhcOptions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/DifferentGhcOptions/cabal.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = cabalTest $ fails $ cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs index 3e2d39fa5bc..bfb75393234 100644 --- a/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs @@ -1,3 +1,6 @@ import Test.Cabal.Prelude -main = cabalTest $ - fails $ cabal "check" [] + +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs index 990042dd00d..0af71e75f3b 100644 --- a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "check" [] + +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs index 38f3844d593..8c739def386 100644 --- a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = cabalTest $ cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/MultiDotGlob2.2/check.test.hs b/cabal-testsuite/PackageTests/Check/MultiDotGlob2.2/check.test.hs index 60a32cb7374..0af71e75f3b 100644 --- a/cabal-testsuite/PackageTests/Check/MultiDotGlob2.2/check.test.hs +++ b/cabal-testsuite/PackageTests/Check/MultiDotGlob2.2/check.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NoGlobMatches/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NoGlobMatches/cabal.test.hs index 38f3844d593..8c739def386 100644 --- a/cabal-testsuite/PackageTests/Check/NoGlobMatches/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NoGlobMatches/cabal.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = cabalTest $ cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownArch/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownArch/cabal.test.hs index 0101fcda527..f95c585e4bb 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownArch/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownArch/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown arch name. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownCompiler/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownCompiler/cabal.test.hs index ff47c4f5a0c..ae90c9c72c5 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownCompiler/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownCompiler/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown compiler. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownOS/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownOS/cabal.test.hs index 93bf2b230c2..b57c5dbe36c 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownOS/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/Conditionals/UnknownOS/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Uknown OS name. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/DebugFlag/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/DebugFlag/cabal.test.hs index 4201f98493e..16a65386cf4 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/DebugFlag/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/DebugFlag/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Debug flags are inappropriate for release. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/FDeferTypeErrors/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/FDeferTypeErrors/cabal.test.hs index 205edb3f122..af1eef9f9d4 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/FDeferTypeErrors/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/FDeferTypeErrors/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- -fdefer-type-errors -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Jn/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Jn/cabal.test.hs index 91996417d99..6c2b9199fa0 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Jn/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Jn/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- j[n]. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Profiling/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Profiling/cabal.test.hs index ac7dc0a3ef8..c93784e0e14 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Profiling/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/Profiling/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Profiling flags unsuited for distribution. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/WError/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/WError/cabal.test.hs index 1a0686e1180..ef775ceb631 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/WError/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DevOnlyFlags/WError/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- WError without -W/-Wall. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/DuplicatedModules/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/DuplicatedModules/cabal.test.hs index 42bdba4b1e2..0db69ab4b42 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/DuplicatedModules/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/DuplicatedModules/cabal.test.hs @@ -1,8 +1,10 @@ import Test.Cabal.Prelude -- Duplicated module. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] - -- TODO: note how conditional give a “potential duplicate”, - -- which is not true at all. +-- TODO: note how conditional give a “potential duplicate”, +-- which is not true at all. diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/PackageVersions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/PackageVersions/cabal.test.hs index 52dbeb0e1b2..5422a84e8d6 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/PackageVersions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/PackageVersions/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Unbounded (top) base. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/PathsExtensions/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/PathsExtensions/cabal.test.hs index f7344949083..e832dc39f3b 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/PathsExtensions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/PathsExtensions/cabal.test.hs @@ -3,5 +3,7 @@ import Test.Cabal.Prelude -- cabal-version <2.2, Paths_pkg *and* `default extensions` w/ -- RebindableSyntax plus OverloadedList or similar do not get well -- together. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/SetupBounds/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/SetupBounds/cabal.test.hs index 26f10dec4ca..0c888e635fd 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/SetupBounds/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/SetupBounds/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- `custom-setup` bounds. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/UnicodeCustomFields/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/UnicodeCustomFields/cabal.test.hs index 83304dd6138..e68c129f83f 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/UnicodeCustomFields/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/UnicodeCustomFields/cabal.test.hs @@ -1,9 +1,11 @@ import Test.Cabal.Prelude -- No unicode in custom fields. -main = cabalTest . recordMode DoNotRecord $ - fails $ cabal "check" [] +main = + cabalTest . recordMode DoNotRecord $ + fails $ + cabal "check" [] - -- You cannot check this against the output, - -- as the way to display “Wnknown unicode - -- char” wobbles between OSes. +-- You cannot check this against the output, +-- as the way to display “Wnknown unicode +-- char” wobbles between OSes. diff --git a/cabal-testsuite/PackageTests/Check/NonConfCheck/UnusedFlags/cabal.test.hs b/cabal-testsuite/PackageTests/Check/NonConfCheck/UnusedFlags/cabal.test.hs index 15c29338ada..422c1741fa0 100644 --- a/cabal-testsuite/PackageTests/Check/NonConfCheck/UnusedFlags/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/NonConfCheck/UnusedFlags/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Unused flag. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/BOM/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/BOM/cabal.test.hs index 2699c60af44..919c54d5b14 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/BOM/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/BOM/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- BOM at top of .cabal file. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/ExtensionMatch/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/ExtensionMatch/cabal.test.hs index 0bd96291d1e..c48afe15be3 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/ExtensionMatch/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/ExtensionMatch/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Partial extension match & <2.4. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/FileName/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/FileName/cabal.test.hs index 01e7ef31baf..30ce1fe044b 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/FileName/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/FileName/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Mismatched package name/filename. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/LocalPaths/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/LocalPaths/cabal.test.hs index 25ab96fa0b8..2dbda4c645a 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/LocalPaths/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/LocalPaths/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Invalid local paths. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/Missing/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/Missing/cabal.test.hs index 044ca815dfc..2c6450ab9e4 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/Missing/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/Missing/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No .cabal file. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/NoConfigureFile/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/NoConfigureFile/cabal.test.hs index 9f833f51ee1..1f7e7c07433 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/NoConfigureFile/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/NoConfigureFile/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No `configure` script. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/NoLicenseFile/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/NoLicenseFile/cabal.test.hs index 68ab3bee604..8a85ec294fd 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/NoLicenseFile/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/NoLicenseFile/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- Missing license file. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/NoSetupFile/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/NoSetupFile/cabal.test.hs index 4b8afd255a8..011296be495 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/NoSetupFile/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/NoSetupFile/cabal.test.hs @@ -1,5 +1,7 @@ import Test.Cabal.Prelude -- No Setup.hs/lhs. -main = cabalTest $ - fails $ cabal "check" [] +main = + cabalTest $ + fails $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/PackageFiles/VCSInfo/cabal.test.hs b/cabal-testsuite/PackageTests/Check/PackageFiles/VCSInfo/cabal.test.hs index a2321d77b22..5837c95e639 100644 --- a/cabal-testsuite/PackageTests/Check/PackageFiles/VCSInfo/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Check/PackageFiles/VCSInfo/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude -- Missing VCS info. -main = cabalTest $ - cabal "check" [] +main = + cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/CheckSetup/Setup.hs b/cabal-testsuite/PackageTests/CheckSetup/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/CheckSetup/Setup.hs +++ b/cabal-testsuite/PackageTests/CheckSetup/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs b/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs index 96ed4395785..c276cc32108 100644 --- a/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs +++ b/cabal-testsuite/PackageTests/CheckSetup/setup.test.hs @@ -2,19 +2,18 @@ import Test.Cabal.Prelude -- Test that setup shows all the 'autogen-modules' warnings. main = cabalTest $ do + checkResult <- fails $ cabal_raw' ["check"] Nothing - checkResult <- fails $ cabal_raw' ["check"] Nothing + -- Package check messages. + let libError1 = + "The dependency 'setup-depends: 'Cabal' does not specify " + ++ "an upper bound on the version number" + libError2 = + "The dependency 'setup-depends: 'base' does not specify " + ++ "an upper bound on the version number" - -- Package check messages. - let libError1 = - "The dependency 'setup-depends: 'Cabal' does not specify " - ++ "an upper bound on the version number" - libError2 = - "The dependency 'setup-depends: 'base' does not specify " - ++ "an upper bound on the version number" + -- Asserts for the desired check messages after configure. + assertOutputContains libError1 checkResult + assertOutputContains libError2 checkResult - -- Asserts for the desired check messages after configure. - assertOutputContains libError1 checkResult - assertOutputContains libError2 checkResult - - return () + return () diff --git a/cabal-testsuite/PackageTests/CmmSources/cabal.test.hs b/cabal-testsuite/PackageTests/CmmSources/cabal.test.hs index 0fa879eaedb..d1a39c90247 100644 --- a/cabal-testsuite/PackageTests/CmmSources/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CmmSources/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "v2-run" ["demo"] - assertOutputContains "= Post common block elimination =" res - assertOutputContains "In Box we have 0x" res + res <- cabal' "v2-run" ["demo"] + assertOutputContains "= Post common block elimination =" res + assertOutputContains "In Box we have 0x" res diff --git a/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs b/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs index e220ffc4c7c..7f5294e790a 100644 --- a/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs +++ b/cabal-testsuite/PackageTests/CmmSources/demo/Main.hs @@ -1,2 +1,3 @@ module Main (module Demo) where + import Demo (main) diff --git a/cabal-testsuite/PackageTests/CmmSources/setup.test.hs b/cabal-testsuite/PackageTests/CmmSources/setup.test.hs index 7bf57f2628f..72316509327 100644 --- a/cabal-testsuite/PackageTests/CmmSources/setup.test.hs +++ b/cabal-testsuite/PackageTests/CmmSources/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = setupTest $ do - skipUnlessGhcVersion ">= 7.8" - setup "configure" [] - res <- setup' "build" [] - assertOutputContains "= Post common block elimination =" res + skipUnlessGhcVersion ">= 7.8" + setup "configure" [] + res <- setup' "build" [] + assertOutputContains "= Post common block elimination =" res diff --git a/cabal-testsuite/PackageTests/CmmSources/src/Demo.hs b/cabal-testsuite/PackageTests/CmmSources/src/Demo.hs index ad44a3b650e..8addea7fa37 100644 --- a/cabal-testsuite/PackageTests/CmmSources/src/Demo.hs +++ b/cabal-testsuite/PackageTests/CmmSources/src/Demo.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} + module Demo (main) where #include "MachDeps.h" @@ -19,19 +20,19 @@ tAG_MASK = (1 `shift` TAG_BITS) - 1 data Box = Box Any instance Show Box where - showsPrec _ (Box a) rs = + showsPrec _ (Box a) rs = -- unsafePerformIO (print "↓" >> pClosure a) `seq` - pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs - where - ptr = W# (aToWord# a) - tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) - addr = ptr - tag - pad_out ls = '0':'x':ls + pad_out (showHex addr "") ++ (if tag > 0 then "/" ++ show tag else "") ++ rs + where + ptr = W# (aToWord# a) + tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) + addr = ptr - tag + pad_out ls = '0' : 'x' : ls asBox :: a -> Box asBox x = Box (unsafeCoerce# x) main :: IO () main = do - let box = asBox "foobar" - putStrLn $ "In Box we have " ++ show box + let box = asBox "foobar" + putStrLn $ "In Box we have " ++ show box diff --git a/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs b/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs index ee8aa155ac2..8c3faae7854 100644 --- a/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CmmSourcesDyn/cabal.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIfWindows - res <- cabal' "v2-run" ["demo"] - assertOutputContains "= Post common block elimination =" res - assertOutputContains "In Box we have 0x" res + skipIfWindows + res <- cabal' "v2-run" ["demo"] + assertOutputContains "= Post common block elimination =" res + assertOutputContains "In Box we have 0x" res diff --git a/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs b/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs index e864c8bce51..5153fac8caa 100644 --- a/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs +++ b/cabal-testsuite/PackageTests/CmmSourcesDyn/demo/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Main (main) where -- Qualified due to https://gitlab.haskell.org/ghc/ghc/-/issues/19397 diff --git a/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs b/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs index 800a540696a..0e07390795d 100644 --- a/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs +++ b/cabal-testsuite/PackageTests/CmmSourcesDyn/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = setupTest $ do - skipIf "ghc < 7.8" =<< isGhcVersion "< 7.8" - setup "configure" [] - res <- setup' "build" [] - assertOutputContains "= Post common block elimination =" res + skipIf "ghc < 7.8" =<< isGhcVersion "< 7.8" + setup "configure" [] + res <- setup' "build" [] + assertOutputContains "= Post common block elimination =" res diff --git a/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs b/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs index ad44a3b650e..8addea7fa37 100644 --- a/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs +++ b/cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} + module Demo (main) where #include "MachDeps.h" @@ -19,19 +20,19 @@ tAG_MASK = (1 `shift` TAG_BITS) - 1 data Box = Box Any instance Show Box where - showsPrec _ (Box a) rs = + showsPrec _ (Box a) rs = -- unsafePerformIO (print "↓" >> pClosure a) `seq` - pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs - where - ptr = W# (aToWord# a) - tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) - addr = ptr - tag - pad_out ls = '0':'x':ls + pad_out (showHex addr "") ++ (if tag > 0 then "/" ++ show tag else "") ++ rs + where + ptr = W# (aToWord# a) + tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) + addr = ptr - tag + pad_out ls = '0' : 'x' : ls asBox :: a -> Box asBox x = Box (unsafeCoerce# x) main :: IO () main = do - let box = asBox "foobar" - putStrLn $ "In Box we have " ++ show box + let box = asBox "foobar" + putStrLn $ "In Box we have " ++ show box diff --git a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs index 92ad43e8ba1..4e03fc94a7a 100644 --- a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do - cabal "v2-run" [ "some-exe" ] - fails $ cabal "v2-build" [ "--project-file=cabal-cyclical.project" ] - fails $ cabal "v2-build" [ "--project-file=cabal-bad-conditional.project" ] + cabal "v2-run" ["some-exe"] + fails $ cabal "v2-build" ["--project-file=cabal-cyclical.project"] + fails $ cabal "v2-build" ["--project-file=cabal-bad-conditional.project"] diff --git a/cabal-testsuite/PackageTests/ConfigFile/InitSectionFields/cabal.test.hs b/cabal-testsuite/PackageTests/ConfigFile/InitSectionFields/cabal.test.hs index ac7c93345f7..3e97c4440db 100644 --- a/cabal-testsuite/PackageTests/ConfigFile/InitSectionFields/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ConfigFile/InitSectionFields/cabal.test.hs @@ -1,21 +1,22 @@ +import Data.Function (on) +import Data.List (groupBy, isInfixOf) import Test.Cabal.Prelude -import Data.List ( isInfixOf, groupBy ) -import Data.Function ( on ) main = cabalTest $ do - workdir <- fmap testWorkDir getTestEnv - let conf = workdir "cabal-config" - cabalG ["--config-file", conf] "user-config" ["init"] - confContents <- liftIO $ readFile conf - let ls = lines confContents - sections = groupBy ((==) `on` (== "")) ls - [initLs] = filter ((== "init") . head) sections - init = unlines initLs - assertInitSectionContainsField init "quiet" - assertInitSectionContainsField init "no-comments" - assertInitSectionContainsField init "minimal" - assertInitSectionContainsField init "simple" + workdir <- fmap testWorkDir getTestEnv + let conf = workdir "cabal-config" + cabalG ["--config-file", conf] "user-config" ["init"] + confContents <- liftIO $ readFile conf + let ls = lines confContents + sections = groupBy ((==) `on` (== "")) ls + [initLs] = filter ((== "init") . head) sections + init = unlines initLs + assertInitSectionContainsField init "quiet" + assertInitSectionContainsField init "no-comments" + assertInitSectionContainsField init "minimal" + assertInitSectionContainsField init "simple" assertInitSectionContainsField section field = - assertBool ("init section of config should contain the field " ++ field) - ((field ++ ":") `isInfixOf` section) + assertBool + ("init section of config should contain the field " ++ field) + ((field ++ ":") `isInfixOf` section) diff --git a/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs b/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs index 35536f47822..dc5d77f014b 100644 --- a/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ConfigFile/T7705/cabal.test.hs @@ -18,6 +18,7 @@ import Test.Cabal.Prelude main = cabalTest $ do fails $ - cabalG [ "--config-file", "does.not.exist" ] "info" [ "happy" ] - fails $ withEnv [("CABAL_CONFIG", Just "absent.file")] $ - cabal "info" [ "alex" ] + cabalG ["--config-file", "does.not.exist"] "info" ["happy"] + fails $ + withEnv [("CABAL_CONFIG", Just "absent.file")] $ + cabal "info" ["alex"] diff --git a/cabal-testsuite/PackageTests/ConfigFile/T8487/cabal.test.hs b/cabal-testsuite/PackageTests/ConfigFile/T8487/cabal.test.hs index 010c47ea4b4..f450d919e59 100644 --- a/cabal-testsuite/PackageTests/ConfigFile/T8487/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ConfigFile/T8487/cabal.test.hs @@ -4,4 +4,4 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabalG [ "--config-file", "config.file" ] "build" [ "test" ] + cabalG ["--config-file", "config.file"] "build" ["test"] diff --git a/cabal-testsuite/PackageTests/Configure/Setup.hs b/cabal-testsuite/PackageTests/Configure/Setup.hs index f598ab71ac3..494eece6dad 100644 --- a/cabal-testsuite/PackageTests/Configure/Setup.hs +++ b/cabal-testsuite/PackageTests/Configure/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMainWithHooks autoconfUserHooks diff --git a/cabal-testsuite/PackageTests/Configure/cabal.test.hs b/cabal-testsuite/PackageTests/Configure/cabal.test.hs index afcc00cbf7a..800528cf7b5 100644 --- a/cabal-testsuite/PackageTests/Configure/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Configure/cabal.test.hs @@ -1,10 +1,11 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class import Data.Maybe import System.Directory +import Test.Cabal.Prelude + -- Test for 'build-type: Configure' example from the setup manual. main = cabalTest $ do - hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" - skipUnless "no autoreconf" hasAutoreconf - _ <- shell "autoreconf" ["-i"] - cabal "v2-build" [] + hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" + skipUnless "no autoreconf" hasAutoreconf + _ <- shell "autoreconf" ["-i"] + cabal "v2-build" [] diff --git a/cabal-testsuite/PackageTests/Configure/setup.test.hs b/cabal-testsuite/PackageTests/Configure/setup.test.hs index 559b88c6ff2..2a4c0c31be5 100644 --- a/cabal-testsuite/PackageTests/Configure/setup.test.hs +++ b/cabal-testsuite/PackageTests/Configure/setup.test.hs @@ -1,10 +1,11 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class import Data.Maybe import System.Directory +import Test.Cabal.Prelude + -- Test for 'build-type: Configure' example from the setup manual. main = setupTest $ do - hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" - skipUnless "no autoreconf" hasAutoreconf - _ <- shell "autoreconf" ["-i"] - setup_build [] + hasAutoreconf <- liftIO $ fmap isJust $ findExecutable "autoreconf" + skipUnless "no autoreconf" hasAutoreconf + _ <- shell "autoreconf" ["-i"] + setup_build [] diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs index d19227b209e..6bb9cda055e 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - withPackageDb $ do - setup_install ["goodexe"] - runExe' "goodexe" [] >>= assertOutputContains "OK" + withPackageDb $ do + setup_install ["goodexe"] + runExe' "goodexe" [] >>= assertOutputContains "OK" diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.hs b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.hs index 1d7d07d5cba..90f603eb047 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/Lib.hs @@ -1,2 +1,3 @@ module Lib where + lib = "OK" diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs index 6ee3fb933aa..a0a07bb9c81 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs @@ -1,2 +1,3 @@ import Lib + main = putStrLn lib diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs index ccae2152f9a..26464a73500 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs @@ -1,11 +1,17 @@ - import Test.Cabal.Prelude + -- NB: The --dependency flag is not supported by cabal-install main = setupTest $ do - withPackageDb $ do - base_id <- getIPID "base" - setup_install ["sublib", "--cid", "sublib-0.1-abc"] - r <- fails $ setup' "configure" - [ "exe", "--exact-configuration" - , "--dependency", "base=" ++ base_id ] - assertOutputContains "sublib" r + withPackageDb $ do + base_id <- getIPID "base" + setup_install ["sublib", "--cid", "sublib-0.1-abc"] + r <- + fails $ + setup' + "configure" + [ "exe" + , "--exact-configuration" + , "--dependency" + , "base=" ++ base_id + ] + assertOutputContains "sublib" r diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs index 49d59c69df0..da18d16ddc2 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs @@ -1,10 +1,16 @@ import Test.Cabal.Prelude + -- NB: The --dependency flag is not supported by cabal-install main = setupTest $ do - withPackageDb $ do - base_id <- getIPID "base" - setup_install ["sublib", "--cid", "sublib-0.1-abc"] - setup_install [ "exe", "--exact-configuration" - , "--dependency", "Lib:sublib=sublib-0.1-abc" - , "--dependency", "base=" ++ base_id ] - runExe' "exe" [] >>= assertOutputContains "OK" + withPackageDb $ do + base_id <- getIPID "base" + setup_install ["sublib", "--cid", "sublib-0.1-abc"] + setup_install + [ "exe" + , "--exact-configuration" + , "--dependency" + , "Lib:sublib=sublib-0.1-abc" + , "--dependency" + , "base=" ++ base_id + ] + runExe' "exe" [] >>= assertOutputContains "OK" diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs index bdc6ab2e602..8a4d3e8185c 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + -- NB: This currently doesn't work with cabal-install, as the depsolver -- doesn't know to compute a dependency for sublib in exe, resulting in -- Setup not being called with enough dependencies. Shout if this is -- a problem for you; the advised workaround is to use Setup directly -- if you need per-component builds. main = setupTest $ do - withPackageDb $ do - setup_install ["sublib"] - setup_install ["exe"] - runExe' "exe" [] >>= assertOutputContains "OK" + withPackageDb $ do + setup_install ["sublib"] + setup_install ["exe"] + runExe' "exe" [] >>= assertOutputContains "OK" diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/Test/Lib.hs b/cabal-testsuite/PackageTests/ConfigureComponent/Test/Lib.hs index 1d7d07d5cba..90f603eb047 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/Test/Lib.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/Test/Lib.hs @@ -1,2 +1,3 @@ module Lib where + lib = "OK" diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs index 4bca4a8641b..79ae8df7041 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + -- NB: This doesn't work with cabal-install, because the -- dependency solver doesn't know how to solve for only -- a single component of a package. main = setupTest $ do - withPackageDb $ do - setup_install ["test-for-cabal"] - withDirectory "testlib" $ setup_install [] - setup "configure" ["testsuite"] - setup "build" [] - setup "test" [] + withPackageDb $ do + setup_install ["test-for-cabal"] + withDirectory "testlib" $ setup_install [] + setup "configure" ["testsuite"] + setup "build" [] + setup "test" [] diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs b/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs index d3104869944..eb5057e962c 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs @@ -1,3 +1,5 @@ module TestLib where + import Lib + testlib = lib diff --git a/cabal-testsuite/PackageTests/ConfigureComponent/Test/tests/Test.hs b/cabal-testsuite/PackageTests/ConfigureComponent/Test/tests/Test.hs index 63654821ba5..debb5dfc92b 100644 --- a/cabal-testsuite/PackageTests/ConfigureComponent/Test/tests/Test.hs +++ b/cabal-testsuite/PackageTests/ConfigureComponent/Test/tests/Test.hs @@ -1,2 +1,3 @@ import TestLib + main = putStrLn testlib diff --git a/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs b/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs index 1924a3801bb..71920ca09d9 100644 --- a/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs +++ b/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- Test that per-component copy works, when only building one executable main = setupAndCabalTest $ do - withPackageDb $ do - setup "configure" [] - setup "build" ["myprog"] - setup "copy" ["myprog"] + withPackageDb $ do + setup "configure" [] + setup "build" ["myprog"] + setup "copy" ["myprog"] diff --git a/cabal-testsuite/PackageTests/CopyComponent/Lib/Main.hs b/cabal-testsuite/PackageTests/CopyComponent/Lib/Main.hs index 16e38b05f3d..634df3726a7 100644 --- a/cabal-testsuite/PackageTests/CopyComponent/Lib/Main.hs +++ b/cabal-testsuite/PackageTests/CopyComponent/Lib/Main.hs @@ -1,2 +1,3 @@ import P + main = print p diff --git a/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs b/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs index 660120c3ec6..f0c3084b416 100644 --- a/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs +++ b/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- Test that per-component copy works, when only building library main = setupAndCabalTest $ do - withPackageDb $ do - setup "configure" [] - setup "build" ["lib:p"] - setup "copy" ["lib:p"] + withPackageDb $ do + setup "configure" [] + setup "build" ["lib:p"] + setup "copy" ["lib:p"] diff --git a/cabal-testsuite/PackageTests/CopyComponent/Lib/src/P.hs b/cabal-testsuite/PackageTests/CopyComponent/Lib/src/P.hs index 8089dce8529..ed4c34fd05b 100644 --- a/cabal-testsuite/PackageTests/CopyComponent/Lib/src/P.hs +++ b/cabal-testsuite/PackageTests/CopyComponent/Lib/src/P.hs @@ -1,2 +1,3 @@ module P where + p = 12 diff --git a/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs b/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs index b1c3aa98802..eae7dcb5243 100644 --- a/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- NB: This variant seems to use the bootstrapped Cabal? - skipUnless "no Cabal for GHC" =<< hasCabalForGhc - -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 - skipUnlessGhcVersion "< 8.2" - -- This test depends heavily on what packages are in the global - -- database, don't record the output - recordMode DoNotRecord $ do - -- TODO: Hack, delete me - withEnvFilter (`notElem` ["HOME", "CABAL_DIR"]) $ do - cabal "v2-build" ["all"] + -- NB: This variant seems to use the bootstrapped Cabal? + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 + skipUnlessGhcVersion "< 8.2" + -- This test depends heavily on what packages are in the global + -- database, don't record the output + recordMode DoNotRecord $ do + -- TODO: Hack, delete me + withEnvFilter (`notElem` ["HOME", "CABAL_DIR"]) $ do + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/CustomDep/client/B.hs b/cabal-testsuite/PackageTests/CustomDep/client/B.hs index af119169669..ce9e7e4932f 100644 --- a/cabal-testsuite/PackageTests/CustomDep/client/B.hs +++ b/cabal-testsuite/PackageTests/CustomDep/client/B.hs @@ -1,2 +1,3 @@ module B where + import A diff --git a/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs b/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs +++ b/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs b/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs +++ b/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/CustomPlain/Setup.hs b/cabal-testsuite/PackageTests/CustomPlain/Setup.hs index 20b960ede90..9fe7e6d4804 100644 --- a/cabal-testsuite/PackageTests/CustomPlain/Setup.hs +++ b/cabal-testsuite/PackageTests/CustomPlain/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple import System.IO + main = hPutStrLn stderr "ThisIsCustomYeah" >> defaultMain diff --git a/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs b/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs index 42c64595594..e265ae8318c 100644 --- a/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 - skipUnlessGhcVersion "< 8.2" - -- Regression test for #4393 - recordMode DoNotRecord $ do - -- TODO: Hack; see also CustomDep/cabal.test.hs - withEnvFilter (`notElem` ["HOME", "CABAL_DIR"]) $ do - -- On -v2, we don't have vQuiet set, which suppressed - -- the error - cabal "v2-build" ["-v1"] + -- implicit setup-depends conflict with GHC >= 8.2; c.f. #415 + skipUnlessGhcVersion "< 8.2" + -- Regression test for #4393 + recordMode DoNotRecord $ do + -- TODO: Hack; see also CustomDep/cabal.test.hs + withEnvFilter (`notElem` ["HOME", "CABAL_DIR"]) $ do + -- On -v2, we don't have vQuiet set, which suppressed + -- the error + cabal "v2-build" ["-v1"] diff --git a/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs b/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs index 2b4a27b1388..1531407bbcf 100644 --- a/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs +++ b/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc - setup' "configure" [] >>= assertOutputContains "ThisIsCustomYeah" - setup' "build" [] >>= assertOutputContains "ThisIsCustomYeah" + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + setup' "configure" [] >>= assertOutputContains "ThisIsCustomYeah" + setup' "build" [] >>= assertOutputContains "ThisIsCustomYeah" diff --git a/cabal-testsuite/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs b/cabal-testsuite/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs index 07a4ef33900..b14ae843a96 100644 --- a/cabal-testsuite/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs +++ b/cabal-testsuite/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs @@ -5,5 +5,5 @@ import System.Environment main :: IO () main = do - (source:target:_) <- getArgs + (source : target : _) <- getArgs copyFile source target diff --git a/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs b/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs index 93ff6a015e9..396bab42d56 100644 --- a/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs +++ b/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} +{- FOURMOLU_DISABLE -} -- The logic here is tricky. -- If this is compiled by cabal-install, then the MIN_VERSION_Cabal is set diff --git a/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs b/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs index 93588d88c3f..b813baa4239 100644 --- a/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomPreProcess/cabal.test.hs @@ -1,13 +1,14 @@ import Test.Cabal.Prelude + -- Test internal custom preprocessor main = cabalTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc + skipUnless "no Cabal for GHC" =<< hasCabalForGhc - -- old Cabal's ./Setup.hs output is difficult to normalise - recordMode DoNotRecord $ - cabal "v2-build" [] + -- old Cabal's ./Setup.hs output is difficult to normalise + recordMode DoNotRecord $ + cabal "v2-build" [] - -- here, we only care that result works: - withPlan $ do - r <- runPlanExe' "internal-preprocessor-test" "hello-world" [] - assertOutputContains "hello from A" r + -- here, we only care that result works: + withPlan $ do + r <- runPlanExe' "internal-preprocessor-test" "hello-world" [] + assertOutputContains "hello from A" r diff --git a/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs b/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs index 2dab697b8d4..44839d431f3 100644 --- a/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs +++ b/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- Test internal custom preprocessor main = setupTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc - setup_build [] - runExe' "hello-world" [] - >>= assertOutputContains "hello from A" + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "hello from A" diff --git a/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs b/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs index a6c74dab745..ecd551d9c54 100644 --- a/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- TODO: this test ought to work on Windows too - skipUnless "not Linux" =<< isLinux - skipUnlessGhcVersion ">= 7.8" - fails $ cabal' "v2-build" [] >>= assertOutputContains "SIGSEGV" + -- TODO: this test ought to work on Windows too + skipUnless "not Linux" =<< isLinux + skipUnlessGhcVersion ">= 7.8" + fails $ cabal' "v2-build" [] >>= assertOutputContains "SIGSEGV" diff --git a/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs b/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs index bf1aad8a41d..16d234340f6 100644 --- a/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude -main = cabalTest $ do - -- This package has explicit setup dependencies that do not include Cabal. - -- v2-build should try to build it, but configure should fail because - -- Setup.hs just prints an error message and exits. - r <- fails $ cabal' "v2-build" ["custom-setup-without-cabal"] - assertOutputContains "My custom Setup" r +main = cabalTest $ do + -- This package has explicit setup dependencies that do not include Cabal. + -- v2-build should try to build it, but configure should fail because + -- Setup.hs just prints an error message and exits. + r <- fails $ cabal' "v2-build" ["custom-setup-without-cabal"] + assertOutputContains "My custom Setup" r diff --git a/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs b/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs index 1f45729c71e..a8afee24584 100644 --- a/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs +++ b/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs @@ -1,16 +1,19 @@ import Test.Cabal.Prelude + main = cabalTest $ do + -- This package has explicit setup dependencies that do not include Cabal. + -- Compilation should fail because Setup.hs imports Distribution.Simple. + r <- fails $ cabal' "v2-build" ["custom-setup-without-cabal-defaultMain"] + assertRegex + "Should not have been able to import Cabal" + "(Could not (find|load) module|Failed to load interface for).*Distribution\\.Simple" + r - -- This package has explicit setup dependencies that do not include Cabal. - -- Compilation should fail because Setup.hs imports Distribution.Simple. - r <- fails $ cabal' "v2-build" ["custom-setup-without-cabal-defaultMain"] - assertRegex "Should not have been able to import Cabal" - "(Could not (find|load) module|Failed to load interface for).*Distribution\\.Simple" r - {- - -- TODO: With GHC 8.2, this no longer is displayed - -- When using --with-ghc, this message is not necessarily output - has_cabal <- hasCabalForGhc - when has_cabal $ - assertRegex "It is a member of the hidden package .*Cabal-" - "It is a member of the hidden package" r - -} +{- +-- TODO: With GHC 8.2, this no longer is displayed +-- When using --with-ghc, this message is not necessarily output +has_cabal <- hasCabalForGhc +when has_cabal $ + assertRegex "It is a member of the hidden package .*Cabal-" + "It is a member of the hidden package" r +-} diff --git a/cabal-testsuite/PackageTests/DeterministicAr/Lib.hs b/cabal-testsuite/PackageTests/DeterministicAr/Lib.hs index f927d0c0510..29db9910249 100644 --- a/cabal-testsuite/PackageTests/DeterministicAr/Lib.hs +++ b/cabal-testsuite/PackageTests/DeterministicAr/Lib.hs @@ -2,4 +2,3 @@ module Lib where dummy :: IO () dummy = return () - diff --git a/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs b/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs index fc59fd54e51..7bd89b96bfe 100644 --- a/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs +++ b/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs @@ -1,4 +1,3 @@ - import Test.Cabal.Prelude import Control.Monad.IO.Class @@ -7,7 +6,7 @@ import Test.Cabal.CheckArMetadata -- Test that setup deterministically generates object archives main = setupAndCabalTest $ do - setup_build [] - dist_dir <- fmap testDistDir getTestEnv - lbi <- getLocalBuildInfoM - liftIO $ checkMetadata lbi (dist_dir "build") + setup_build [] + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + liftIO $ checkMetadata lbi (dist_dir "build") diff --git a/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs b/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs index 0d18b42dcf9..cf5d468828f 100644 --- a/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs +++ b/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs @@ -1,4 +1,3 @@ - import Test.Cabal.Prelude import Control.Monad.IO.Class @@ -7,7 +6,7 @@ import Test.Cabal.CheckArMetadata -- Test that setup deterministically generates object archives main = setupAndCabalTest $ do - setup_build ["--disable-response-files"] - dist_dir <- fmap testDistDir getTestEnv - lbi <- getLocalBuildInfoM - liftIO $ checkMetadata lbi (dist_dir "build") + setup_build ["--disable-response-files"] + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + liftIO $ checkMetadata lbi (dist_dir "build") diff --git a/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs b/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs index 3739c793e8f..a1621c907c2 100644 --- a/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs +++ b/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + -- Test that if two components have the same module name, they do not -- clobber each other. main = setupAndCabalTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc -- use of library test suite - setup_build ["--enable-tests"] - r1 <- fails $ setup' "test" ["foo"] - assertOutputContains "test B" r1 - assertOutputContains "test A" r1 - r2 <- fails $ setup' "test" ["foo2"] - assertOutputContains "test C" r2 - assertOutputContains "test A" r2 + skipUnless "no Cabal for GHC" =<< hasCabalForGhc -- use of library test suite + setup_build ["--enable-tests"] + r1 <- fails $ setup' "test" ["foo"] + assertOutputContains "test B" r1 + assertOutputContains "test A" r1 + r2 <- fails $ setup' "test" ["foo2"] + assertOutputContains "test C" r2 + assertOutputContains "test A" r2 diff --git a/cabal-testsuite/PackageTests/DuplicateModuleName/src/Foo.hs b/cabal-testsuite/PackageTests/DuplicateModuleName/src/Foo.hs index a964bac5203..f697232898a 100644 --- a/cabal-testsuite/PackageTests/DuplicateModuleName/src/Foo.hs +++ b/cabal-testsuite/PackageTests/DuplicateModuleName/src/Foo.hs @@ -3,10 +3,14 @@ module Foo where import Distribution.TestSuite tests :: IO [Test] -tests = return [Test $ TestInstance +tests = + return + [ Test $ + TestInstance { run = return (Finished (Fail "A")) , name = "test A" , tags = [] , options = [] - , setOption = \_ _-> Left "No Options" - }] + , setOption = \_ _ -> Left "No Options" + } + ] diff --git a/cabal-testsuite/PackageTests/DuplicateModuleName/tests/Foo.hs b/cabal-testsuite/PackageTests/DuplicateModuleName/tests/Foo.hs index c6c894ffc58..bf5568a30e3 100644 --- a/cabal-testsuite/PackageTests/DuplicateModuleName/tests/Foo.hs +++ b/cabal-testsuite/PackageTests/DuplicateModuleName/tests/Foo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} + module Foo where import Distribution.TestSuite @@ -6,13 +7,17 @@ import qualified "DuplicateModuleName" Foo as T tests :: IO [Test] tests = do - r <- T.tests - return $ [Test $ TestInstance + r <- T.tests + return $ + [ Test $ + TestInstance { run = return (Finished (Fail "B")) , name = "test B" , tags = [] , options = [] - , setOption = \_ _-> Left "No Options" - }] ++ r + , setOption = \_ _ -> Left "No Options" + } + ] + ++ r this_is_test = True diff --git a/cabal-testsuite/PackageTests/DuplicateModuleName/tests2/Foo.hs b/cabal-testsuite/PackageTests/DuplicateModuleName/tests2/Foo.hs index 68836baa8e3..5f7acd4cbb5 100644 --- a/cabal-testsuite/PackageTests/DuplicateModuleName/tests2/Foo.hs +++ b/cabal-testsuite/PackageTests/DuplicateModuleName/tests2/Foo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} + module Foo where import Distribution.TestSuite @@ -6,13 +7,17 @@ import qualified "DuplicateModuleName" Foo as T tests :: IO [Test] tests = do - r <- T.tests - return $ [Test $ TestInstance + r <- T.tests + return $ + [ Test $ + TestInstance { run = return (Finished (Fail "C")) , name = "test C" , tags = [] , options = [] - , setOption = \_ _-> Left "No Options" - }] ++ r + , setOption = \_ _ -> Left "No Options" + } + ] + ++ r this_is_test2 = True diff --git a/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs b/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs index 0ff9eccf929..f481a829185 100644 --- a/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs +++ b/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test build when the library is empty, for #1241 main = setupAndCabalTest $ withDirectory "empty" $ setup_build [] diff --git a/cabal-testsuite/PackageTests/Exec/My.hs b/cabal-testsuite/PackageTests/Exec/My.hs index b467ba86e09..34a0b6a0742 100644 --- a/cabal-testsuite/PackageTests/Exec/My.hs +++ b/cabal-testsuite/PackageTests/Exec/My.hs @@ -2,4 +2,4 @@ module Main where main :: IO () main = do - putStrLn "This is my-executable" + putStrLn "This is my-executable" diff --git a/cabal-testsuite/PackageTests/Exec/cabal.test.hs b/cabal-testsuite/PackageTests/Exec/cabal.test.hs index 55d07b4fe23..0bc9082fa3f 100644 --- a/cabal-testsuite/PackageTests/Exec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Exec/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- NB: cabal-version: >= 1.2 in my.cabal means we exercise - -- the non per-component code path - cabal "v2-build" ["my-executable"] - withPlan $ runPlanExe "my" "my-executable" [] + -- NB: cabal-version: >= 1.2 in my.cabal means we exercise + -- the non per-component code path + cabal "v2-build" ["my-executable"] + withPlan $ runPlanExe "my" "my-executable" [] diff --git a/cabal-testsuite/PackageTests/ExecModern/My.hs b/cabal-testsuite/PackageTests/ExecModern/My.hs index b467ba86e09..34a0b6a0742 100644 --- a/cabal-testsuite/PackageTests/ExecModern/My.hs +++ b/cabal-testsuite/PackageTests/ExecModern/My.hs @@ -2,4 +2,4 @@ module Main where main :: IO () main = do - putStrLn "This is my-executable" + putStrLn "This is my-executable" diff --git a/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs b/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs index 55d07b4fe23..0bc9082fa3f 100644 --- a/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- NB: cabal-version: >= 1.2 in my.cabal means we exercise - -- the non per-component code path - cabal "v2-build" ["my-executable"] - withPlan $ runPlanExe "my" "my-executable" [] + -- NB: cabal-version: >= 1.2 in my.cabal means we exercise + -- the non per-component code path + cabal "v2-build" ["my-executable"] + withPlan $ runPlanExe "my" "my-executable" [] diff --git a/cabal-testsuite/PackageTests/ExtraCompilationArtifacts/test.hs b/cabal-testsuite/PackageTests/ExtraCompilationArtifacts/test.hs index 44141cdb7b7..c8ebfe7f8f4 100644 --- a/cabal-testsuite/PackageTests/ExtraCompilationArtifacts/test.hs +++ b/cabal-testsuite/PackageTests/ExtraCompilationArtifacts/test.hs @@ -1,7 +1,7 @@ import Distribution.Simple.LocalBuildInfo -import Test.Cabal.Prelude import System.Directory import System.FilePath +import Test.Cabal.Prelude -- Test if extra-compilation-artifacts are installed main = setupAndCabalTest . recordMode DoNotRecord $ do @@ -29,4 +29,3 @@ generateExtraCompArtifactsToBuildDir = do genArtifact $ "ghc-plugin-X" "data-dir" "content-A.txt" genArtifact $ "ghc-plugin-X" "data-dir" "content-B.txt" genArtifact $ "ghc-plugin-Y" "content-Y.txt" - diff --git a/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs b/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs index 575b067db7d..aa5a2dc602f 100644 --- a/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExtraPackages/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do - cabal "v2-run" [ "some-exe" ] + cabal "v2-run" ["some-exe"] diff --git a/cabal-testsuite/PackageTests/ExtraProgPath/setup.test.hs b/cabal-testsuite/PackageTests/ExtraProgPath/setup.test.hs index 80ee56f6287..ef2088acbae 100644 --- a/cabal-testsuite/PackageTests/ExtraProgPath/setup.test.hs +++ b/cabal-testsuite/PackageTests/ExtraProgPath/setup.test.hs @@ -5,4 +5,4 @@ main = cabalTest $ do -- skipped on windows because using a script to dummy up an executable doesn't work the same. skipIfWindows cdir <- testCurrentDir `fmap` getTestEnv - fails $ cabal "v2-build" ["--extra-prog-path="++cdir] + fails $ cabal "v2-build" ["--extra-prog-path=" ++ cdir] diff --git a/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs b/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs index 34c10adfd99..79680f06bfb 100644 --- a/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs +++ b/cabal-testsuite/PackageTests/FFI/ForeignOptsC/Main.hs @@ -9,8 +9,8 @@ foreign import ccall "clib.h meaning_of_life_c" main :: IO () main = do - secret <- meaning_of_life_c - -- The value 11 comes from __TESTOPT_C__ - see the cabal file. - if (secret == 11) - then putStrLn ("The secret is " ++ show secret) - else error ("Expected value 11, got " ++ show secret) + secret <- meaning_of_life_c + -- The value 11 comes from __TESTOPT_C__ - see the cabal file. + if (secret == 11) + then putStrLn ("The secret is " ++ show secret) + else error ("Expected value 11, got " ++ show secret) diff --git a/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs b/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs index 7d5d4f0aff9..955e79e711f 100644 --- a/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs +++ b/cabal-testsuite/PackageTests/FFI/ForeignOptsC/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["foreign-opts-c-exe"] - withPlan $ runPlanExe "foreign-opts-c" "foreign-opts-c-exe" [] + cabal "v2-build" ["foreign-opts-c-exe"] + withPlan $ runPlanExe "foreign-opts-c" "foreign-opts-c-exe" [] diff --git a/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs b/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs index 2343305fc39..57224365516 100644 --- a/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs +++ b/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/Main.hs @@ -9,8 +9,8 @@ foreign import ccall "cxxlib.h meaning_of_life_cxx" main :: IO () main = do - secret <- meaning_of_life_cxx - -- The value 22 comes from __TESTOPT_CXX__ - see the cabal file. - if (secret == 22) - then putStrLn ("The secret is " ++ show secret) - else error ("Expected value 22, got " ++ show secret) + secret <- meaning_of_life_cxx + -- The value 22 comes from __TESTOPT_CXX__ - see the cabal file. + if (secret == 22) + then putStrLn ("The secret is " ++ show secret) + else error ("Expected value 22, got " ++ show secret) diff --git a/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs b/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs index 10024955a78..bcdd49cf2d6 100644 --- a/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs +++ b/cabal-testsuite/PackageTests/FFI/ForeignOptsCxx/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["foreign-opts-cxx-exe"] - withPlan $ runPlanExe "foreign-opts-cxx" "foreign-opts-cxx-exe" [] + cabal "v2-build" ["foreign-opts-cxx-exe"] + withPlan $ runPlanExe "foreign-opts-cxx" "foreign-opts-cxx-exe" [] diff --git a/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs b/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs index 2bd17605b72..4c0dbb272b8 100644 --- a/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs +++ b/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} import Control.Exception import Control.Monad.IO.Class @@ -11,8 +11,8 @@ import System.Posix (readSymbolicLink) #endif /* mingw32_HOST_OS */ import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types import Distribution.System import Distribution.Verbosity @@ -30,35 +30,42 @@ main = setupAndCabalTest . recordMode DoNotRecord $ do ghc94 <- isGhcVersion "== 9.4.*" expectBrokenIf (win && ghc94) 8451 $ withPackageDb $ do - setup_install [] - setup "copy" [] -- regression test #4156 - dist_dir <- fmap testDistDir getTestEnv - lbi <- getLocalBuildInfoM - let installDirs = absoluteInstallDirs (localPkgDescr lbi) lbi NoCopyDest + setup_install [] + setup "copy" [] -- regression test #4156 + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + let installDirs = absoluteInstallDirs (localPkgDescr lbi) lbi NoCopyDest - -- Link a C program against the library - _ <- runProgramM gccProgram - [ "-std=c11", "-Wall" - , "-o", "uselib" - , "UseLib.c" - , "-l", "myforeignlib" - , "-L", flibdir installDirs ] - Nothing + -- Link a C program against the library + _ <- + runProgramM + gccProgram + [ "-std=c11" + , "-Wall" + , "-o" + , "uselib" + , "UseLib.c" + , "-l" + , "myforeignlib" + , "-L" + , flibdir installDirs + ] + Nothing - -- Run the C program - let ldPath = case hostPlatform lbi of - Platform _ OSX -> "DYLD_LIBRARY_PATH" - Platform _ Windows -> "PATH" - Platform _ _other -> "LD_LIBRARY_PATH" - oldLdPath <- liftIO $ getEnv' ldPath - withEnv [ (ldPath, Just $ flibdir installDirs ++ [searchPathSeparator] ++ oldLdPath) ] $ do - cwd <- fmap testCurrentDir getTestEnv - result <- runM (cwd "uselib") [] Nothing - assertOutputContains "5678" result - assertOutputContains "189" result + -- Run the C program + let ldPath = case hostPlatform lbi of + Platform _ OSX -> "DYLD_LIBRARY_PATH" + Platform _ Windows -> "PATH" + Platform _ _other -> "LD_LIBRARY_PATH" + oldLdPath <- liftIO $ getEnv' ldPath + withEnv [(ldPath, Just $ flibdir installDirs ++ [searchPathSeparator] ++ oldLdPath)] $ do + cwd <- fmap testCurrentDir getTestEnv + result <- runM (cwd "uselib") [] Nothing + assertOutputContains "5678" result + assertOutputContains "189" result - -- If we're on Linux, we should have built a library with a - -- version. We will now check that it was installed correctly. +-- If we're on Linux, we should have built a library with a +-- version. We will now check that it was installed correctly. #ifndef mingw32_HOST_OS case hostPlatform lbi of Platform _ Linux -> do @@ -84,6 +91,7 @@ main = setupAndCabalTest . recordMode DoNotRecord $ do getEnv' :: String -> IO String getEnv' = handle handler . getEnv where - handler e = if isDoesNotExistError e - then return "" - else throw e + handler e = + if isDoesNotExistError e + then return "" + else throw e diff --git a/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Export.hs b/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Export.hs index 2e80c8b8a04..4c316a94124 100644 --- a/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Export.hs +++ b/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Export.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module MyForeignLib.Export - ( foo ) where + +module MyForeignLib.Export (foo) where foo :: Int -> Int foo x = x + 1 diff --git a/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs b/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs index a9e54986dc6..5a0201a90ea 100644 --- a/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs +++ b/cabal-testsuite/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs @@ -1,13 +1,16 @@ -- | Module with single foreign export module MyForeignLib.Hello (sayHi) where -import MyForeignLib.SomeBindings import MyForeignLib.AnotherVal +import MyForeignLib.SomeBindings foreign export ccall sayHi :: IO () -- | Say hi! sayHi :: IO () -sayHi = putStrLn $ - "Hi from a foreign library! Foo has value " ++ show valueOfFoo - ++ " and anotherVal has value " ++ show anotherVal +sayHi = + putStrLn $ + "Hi from a foreign library! Foo has value " + ++ show valueOfFoo + ++ " and anotherVal has value " + ++ show anotherVal diff --git a/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs b/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs index 52ef66110de..94a355c61a4 100644 --- a/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - cabal "v1-freeze" ["--disable-benchmarks"] - cwd <- fmap testCurrentDir getTestEnv - assertFileDoesNotContain (cwd "cabal.config") "criterion" + withRepo "repo" . withSourceCopy $ do + cabal "v1-freeze" ["--disable-benchmarks"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "criterion" diff --git a/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs b/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs index a959240586c..5eb64268c77 100644 --- a/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - cabal "v1-freeze" ["--disable-tests"] - cwd <- fmap testCurrentDir getTestEnv - assertFileDoesNotContain (cwd "cabal.config") "test-framework" + withRepo "repo" . withSourceCopy $ do + cabal "v1-freeze" ["--disable-tests"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "test-framework" diff --git a/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs b/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs index 11130ba8c2c..e95f4788e43 100644 --- a/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - recordMode DoNotRecord $ cabal "v1-freeze" ["--dry-run"] - cwd <- fmap testCurrentDir getTestEnv - shouldNotExist (cwd "cabal.config") + withRepo "repo" . withSourceCopy $ do + recordMode DoNotRecord $ cabal "v1-freeze" ["--dry-run"] + cwd <- fmap testCurrentDir getTestEnv + shouldNotExist (cwd "cabal.config") diff --git a/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs b/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs index d525c1d26ff..bf78108a713 100644 --- a/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - cabal "v1-freeze" ["--enable-benchmarks"] - cwd <- fmap testCurrentDir getTestEnv - assertFileDoesContain (cwd "cabal.config") "criterion" - assertFileDoesContain (cwd "cabal.config") "ghc-prim" + withRepo "repo" . withSourceCopy $ do + cabal "v1-freeze" ["--enable-benchmarks"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesContain (cwd "cabal.config") "criterion" + assertFileDoesContain (cwd "cabal.config") "ghc-prim" diff --git a/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs b/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs index 8a43b5b6daf..17ad0a4cdea 100644 --- a/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - cabal "v1-freeze" ["--enable-tests"] - cwd <- fmap testCurrentDir getTestEnv - assertFileDoesContain (cwd "cabal.config") "test-framework" + withRepo "repo" . withSourceCopy $ do + cabal "v1-freeze" ["--enable-tests"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesContain (cwd "cabal.config") "test-framework" diff --git a/cabal-testsuite/PackageTests/Freeze/freeze.test.hs b/cabal-testsuite/PackageTests/Freeze/freeze.test.hs index 2961a0e0055..5a7c03d4bdb 100644 --- a/cabal-testsuite/PackageTests/Freeze/freeze.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/freeze.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withRepo "repo" . withSourceCopy $ do - cabal "v1-freeze" [] - cwd <- fmap testCurrentDir getTestEnv - assertFileDoesNotContain (cwd "cabal.config") "exceptions" - assertFileDoesNotContain (cwd "cabal.config") "my" - assertFileDoesContain (cwd "cabal.config") "base" + withRepo "repo" . withSourceCopy $ do + cabal "v1-freeze" [] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "exceptions" + assertFileDoesNotContain (cwd "cabal.config") "my" + assertFileDoesContain (cwd "cabal.config") "base" diff --git a/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs b/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs index fd7328da0c2..542a165ef17 100644 --- a/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs +++ b/cabal-testsuite/PackageTests/GHCJS/BuildRunner/cabal.test.hs @@ -1,19 +1,23 @@ import Test.Cabal.Prelude main = cabalTest . recordMode DoNotRecord $ do - skipIfWindows -- disabled because (I presume) Windows doesn't have BASH - cwd <- fmap testCurrentDir getTestEnv - testInvokedWithBuildRunner cwd "test" [] - testInvokedWithBuildRunner cwd "run" ["ghcjs-exe"] - testInvokedWithBuildRunner cwd "bench" [] + skipIfWindows -- disabled because (I presume) Windows doesn't have BASH + cwd <- fmap testCurrentDir getTestEnv + testInvokedWithBuildRunner cwd "test" [] + testInvokedWithBuildRunner cwd "run" ["ghcjs-exe"] + testInvokedWithBuildRunner cwd "bench" [] magicString = "SUCCESS! GHCJS was invoked with '-build-runner' option" testInvokedWithBuildRunner cwd cabalCmd extraArgs = do - output <- fails $ cabal' cabalCmd $ extraArgs ++ - [ "--ghcjs" - , "--with-compiler", cwd fakeGhcjsPath - ] - assertOutputContains magicString output + output <- + fails $ + cabal' cabalCmd $ + extraArgs + ++ [ "--ghcjs" + , "--with-compiler" + , cwd fakeGhcjsPath + ] + assertOutputContains magicString output where fakeGhcjsPath = "scripts/fake-ghcjs.sh" diff --git a/cabal-testsuite/PackageTests/Get/OnlyDescription/cabal.test.hs b/cabal-testsuite/PackageTests/Get/OnlyDescription/cabal.test.hs index 3b4a36553c7..400741087ca 100644 --- a/cabal-testsuite/PackageTests/Get/OnlyDescription/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Get/OnlyDescription/cabal.test.hs @@ -4,8 +4,9 @@ -- Make sure that `cabal get --only-package-description` works import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do cabal "update" [] cabal "get" - [ "criterion", "--only-package-description" ] + ["criterion", "--only-package-description"] diff --git a/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs b/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs index 782742f7ff0..25b94a51591 100644 --- a/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Get/T7248/cabal.test.hs @@ -7,9 +7,11 @@ -- Needs to be checked manually whether it meets expectations. import Test.Cabal.Prelude -main = cabalTest $ - fails $ - cabalG - [ "--config-file", "cabal.config" ] - "get" - [ "a-b-s-e-n-t" ] + +main = + cabalTest $ + fails $ + cabalG + ["--config-file", "cabal.config"] + "get" + ["a-b-s-e-n-t"] diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs index 85b30b87523..97935291985 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs @@ -1,10 +1,13 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc"] - assertOutputContains "is version 9999999" r + skipIfWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs index 746c8015fca..c7cc3a6049b 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs @@ -1,10 +1,13 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc-7.10"] - assertOutputContains "is version 9999999" r + skipIfWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc-7.10"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs index 746c8015fca..c7cc3a6049b 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs @@ -1,10 +1,13 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc-7.10"] - assertOutputContains "is version 9999999" r + skipIfWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc-7.10"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs index eab35100802..74923172613 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs @@ -1,11 +1,14 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - withSymlink "bin/ghc" "ghc" $ do - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc"] - assertOutputContains "is version 9999999" r + skipIfWindows + withSymlink "bin/ghc" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs index eb95044b941..6bf4a05e2df 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs @@ -1,11 +1,14 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - withSymlink "bin/ghc-7.10" "ghc" $ do - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc"] - assertOutputContains "is version 9999999" r + skipIfWindows + withSymlink "bin/ghc-7.10" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs b/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs index eb95044b941..6bf4a05e2df 100644 --- a/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs +++ b/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs @@ -1,11 +1,14 @@ import Test.Cabal.Prelude + -- TODO: Enable this test on Windows main = setupAndCabalTest $ do - skipIfWindows - withSymlink "bin/ghc-7.10" "ghc" $ do - env <- getTestEnv - let cwd = testCurrentDir env - ghc_path <- programPathM ghcProgram - r <- withEnv [("WITH_GHC", Just ghc_path)] - . fails $ setup' "configure" ["-w", cwd "ghc"] - assertOutputContains "is version 9999999" r + skipIfWindows + withSymlink "bin/ghc-7.10" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- + withEnv [("WITH_GHC", Just ghc_path)] + . fails + $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal-testsuite/PackageTests/Haddock/NoCPP.hs b/cabal-testsuite/PackageTests/Haddock/NoCPP.hs index 417f368b37c..d1f70aa689e 100644 --- a/cabal-testsuite/PackageTests/Haddock/NoCPP.hs +++ b/cabal-testsuite/PackageTests/Haddock/NoCPP.hs @@ -4,5 +4,6 @@ module NoCPP (Haystack) where data Haystack = Haystack -- | Causes a build failure if the CPP language extension is enabled. -stringGap = "Foo\ -\Bar" +stringGap = + "Foo\ + \Bar" diff --git a/cabal-testsuite/PackageTests/Haddock/setup.test.hs b/cabal-testsuite/PackageTests/Haddock/setup.test.hs index e9f25b013dc..6f3703fc431 100644 --- a/cabal-testsuite/PackageTests/Haddock/setup.test.hs +++ b/cabal-testsuite/PackageTests/Haddock/setup.test.hs @@ -1,11 +1,13 @@ import Test.Cabal.Prelude + -- Test that "./Setup haddock" works correctly main = setupAndCabalTest $ do - env <- getTestEnv - let haddocksDir = testDistDir env "doc" "html" "Haddock" - setup "configure" [] - setup "haddock" [] - let docFiles - = map (haddocksDir ) - ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] - mapM_ (assertFindInFile "For hiding needles.") docFiles + env <- getTestEnv + let haddocksDir = testDistDir env "doc" "html" "Haddock" + setup "configure" [] + setup "haddock" [] + let docFiles = + map + (haddocksDir ) + ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] + mapM_ (assertFindInFile "For hiding needles.") docFiles diff --git a/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs b/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs index 531072e3139..0e5ca54ad0e 100644 --- a/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs +++ b/cabal-testsuite/PackageTests/HaddockArgs/hoogle.test.hs @@ -4,7 +4,9 @@ main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ withRepo "repo -- Checks if hoogle txt files are generated. -- Logs contain something like "Documentation created: dist/doc/html/indef/indef.txt", so we don't need -- to do extra check - cabalG ["--store-dir=" ++ storeDir] "v2-build" + cabalG + ["--store-dir=" ++ storeDir] + "v2-build" [ "example" , "--enable-documentation" , "--haddock-hoogle" diff --git a/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs b/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs index 3b8a3281d69..7cd94644e22 100644 --- a/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs +++ b/cabal-testsuite/PackageTests/HaddockArgs/quickjump.test.hs @@ -4,7 +4,9 @@ import System.Directory import System.FilePath main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ withRepo "repo" $ do - cabalG ["--store-dir=" ++ storeDir] "v2-build" + cabalG + ["--store-dir=" ++ storeDir] + "v2-build" [ "example" , "--enable-documentation" , "--haddock-quickjump" diff --git a/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs b/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs index e0cb6d02c6e..61c4ba8c73a 100644 --- a/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs +++ b/cabal-testsuite/PackageTests/HaddockArgs/repo/exe-0.1.0.0/Main.hs @@ -1,4 +1,5 @@ -import qualified Data.Map as Map import Data.Map (Map) +import qualified Data.Map as Map import Foo -main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) + +main = print $ f (+ 1) (Map.fromList [(0, 1), (2, 3)] :: Map Int Int) diff --git a/cabal-testsuite/PackageTests/HaddockNewline/Setup.hs b/cabal-testsuite/PackageTests/HaddockNewline/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/HaddockNewline/Setup.hs +++ b/cabal-testsuite/PackageTests/HaddockNewline/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs b/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs index b29a8aa8514..835a3468762 100644 --- a/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs +++ b/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test that Haddock with a newline in synopsis works correctly, #3004 main = setupAndCabalTest $ do - setup "configure" [] - setup "haddock" [] + setup "configure" [] + setup "haddock" [] diff --git a/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs b/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs index d593d42d8f6..6dab2ea4ee1 100644 --- a/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs +++ b/cabal-testsuite/PackageTests/HaddockWarn/cabal.test.hs @@ -1,4 +1,4 @@ -import Test.Cabal.Prelude import System.Exit (ExitCode (..)) +import Test.Cabal.Prelude main = cabalTest $ cabal "v2-haddock" [] diff --git a/cabal-testsuite/PackageTests/Init/init-backup.test.hs b/cabal-testsuite/PackageTests/Init/init-backup.test.hs index f1c4ab0fc74..aa60a49d9ec 100644 --- a/cabal-testsuite/PackageTests/Init/init-backup.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-backup.test.hs @@ -5,15 +5,18 @@ main = cabalTest $ cwd <- fmap testSourceCopyDir getTestEnv (initOut, buildOut) <- withDirectory cwd $ do - initOut <- cabalWithStdin "init" ["-i"] - "2\ny\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n" + initOut <- + cabalWithStdin + "init" + ["-i"] + "2\ny\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n" setup "configure" [] buildOut <- setup' "build" ["app"] return (initOut, buildOut) - assertFileDoesContain (cwd "app.cabal") "3.0" - assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" - assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesContain (cwd "app.cabal") "3.0" + assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" + assertFileDoesContain (cwd "app.cabal") "Simple" shouldDirectoryExist (cwd "app.save0") assertOutputContains "Backing up old version in app.save0" initOut assertOutputContains "Overwriting directory ./app" initOut diff --git a/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs b/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs index 8b53ce18b30..97db8bf23fa 100644 --- a/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-interactive-ghc2021.test.hs @@ -5,7 +5,9 @@ main = cabalTest $ cwd <- fmap testSourceCopyDir getTestEnv buildOut <- withDirectory cwd $ do - cabalWithStdin "init" ["-i"] + cabalWithStdin + "init" + ["-i"] "2\n\n5\n\n\n2\n\n\n\n\n\n\n\n3\n\n" assertFileDoesContain (cwd "app.cabal") "GHC2021" diff --git a/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs b/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs index 3fd9415d570..f72614ca8e5 100644 --- a/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-interactive-legacy.test.hs @@ -5,14 +5,16 @@ main = cabalTest $ cwd <- fmap testSourceCopyDir getTestEnv buildOut <- withDirectory cwd $ do - cabalWithStdin "init" ["-i"] + cabalWithStdin + "init" + ["-i"] "2\n\n1\n\n\n10\n\n\n\n\n\n\n\n\n\n" setup "configure" [] setup' "build" ["app"] - assertFileDoesContain (cwd "app.cabal") "1.24" - assertFileDoesContain (cwd "app.cabal") "BSD3" - assertFileDoesContain (cwd "app.cabal") "Simple" - assertFileDoesNotContain (cwd "app.cabal") "^>=" - assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertFileDoesContain (cwd "app.cabal") "1.24" + assertFileDoesContain (cwd "app.cabal") "BSD3" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesNotContain (cwd "app.cabal") "^>=" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" assertOutputContains "Linking" buildOut diff --git a/cabal-testsuite/PackageTests/Init/init-interactive.test.hs b/cabal-testsuite/PackageTests/Init/init-interactive.test.hs index 86bda8b028a..21af465a810 100644 --- a/cabal-testsuite/PackageTests/Init/init-interactive.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-interactive.test.hs @@ -5,13 +5,15 @@ main = cabalTest $ cwd <- fmap testSourceCopyDir getTestEnv buildOut <- withDirectory cwd $ do - cabalWithStdin "init" ["-i"] + cabalWithStdin + "init" + ["-i"] "2\n\n5\n\n\n\n\n\n\n\n\n\n\n\n\n" setup "configure" [] setup' "build" ["app"] - assertFileDoesContain (cwd "app.cabal") "3.0" - assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" - assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesContain (cwd "app.cabal") "3.0" + assertFileDoesContain (cwd "app.cabal") "BSD-3-Clause" + assertFileDoesContain (cwd "app.cabal") "Simple" assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" assertOutputContains "Linking" buildOut diff --git a/cabal-testsuite/PackageTests/Init/init-legacy.test.hs b/cabal-testsuite/PackageTests/Init/init-legacy.test.hs index eac7b312fb5..ec3f76fcd59 100644 --- a/cabal-testsuite/PackageTests/Init/init-legacy.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-legacy.test.hs @@ -9,8 +9,8 @@ main = cabalTest $ setup "configure" [] setup' "build" ["app"] - assertFileDoesContain (cwd "app.cabal") "1.24" - assertFileDoesContain (cwd "app.cabal") "Simple" - assertFileDoesNotContain (cwd "app.cabal") "^>=" - assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" + assertFileDoesContain (cwd "app.cabal") "1.24" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesNotContain (cwd "app.cabal") "^>=" + assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" assertOutputContains "Linking" buildOut diff --git a/cabal-testsuite/PackageTests/Init/init.test.hs b/cabal-testsuite/PackageTests/Init/init.test.hs index 83a512d5893..3d29940f34f 100644 --- a/cabal-testsuite/PackageTests/Init/init.test.hs +++ b/cabal-testsuite/PackageTests/Init/init.test.hs @@ -9,7 +9,7 @@ main = cabalTest $ setup "configure" [] setup' "build" ["app"] - assertFileDoesContain (cwd "app.cabal") "Simple" - assertFileDoesContain (cwd "app.cabal") "base ^>=" + assertFileDoesContain (cwd "app.cabal") "Simple" + assertFileDoesContain (cwd "app.cabal") "base ^>=" assertFileDoesContain (cwd "app/Main.hs") "This should remain as is!" assertOutputContains "Linking" buildOut diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Executable/exe/Main.hs b/cabal-testsuite/PackageTests/InternalLibraries/Executable/exe/Main.hs index e8ab9fd0d1e..191fe2ba2ed 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Executable/exe/Main.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Executable/exe/Main.hs @@ -1,2 +1,3 @@ import Foo + main = print (foo 23) diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs index dc674bc0987..b0125c78b36 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs @@ -1,54 +1,71 @@ -import Test.Cabal.Prelude -import Control.Monad.IO.Class import Control.Monad -import Distribution.System (buildPlatform) +import Control.Monad.IO.Class import Distribution.Package -import Distribution.Simple.Configure import Distribution.Simple.BuildPaths -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.InstallDirs import Distribution.Simple.Compiler -import Distribution.Types.TargetInfo +import Distribution.Simple.Configure +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo +import Distribution.System (buildPlatform) import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName import System.Directory +import Test.Cabal.Prelude -- Internal libraries used by a statically linked executable: -- no libraries should get installed or registered. (Note, -- this does build shared libraries just to make sure they -- don't get installed, so this test doesn't work on Windows.) main = setupAndCabalTest $ do - skipUnless "no shared libs" =<< hasSharedLibraries - withPackageDb $ do - -- MULTI - forM_ [False, True] $ \is_dynamic -> do - setup_install $ [ if is_dynamic then "--enable-executable-dynamic" - else "--disable-executable-dynamic" - , "--enable-shared"] - dist_dir <- fmap testDistDir getTestEnv - lbi <- liftIO $ getPersistBuildConfig dist_dir - let pkg_descr = localPkgDescr lbi - compiler_id = compilerId (compiler lbi) - cname = CLibName $ LSubLibName $ mkUnqualComponentName "foo-internal" - [target] = componentNameTargets' pkg_descr lbi cname - uid = componentUnitId (targetCLBI target) - InstallDirs{libdir=dir,dynlibdir=dyndir} = - absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest - assertBool "interface files should be installed" - =<< liftIO (doesFileExist (dir "Foo.hi")) - assertBool "static library should be installed" - =<< liftIO (doesFileExist (dir mkLibName uid)) - if is_dynamic - then - assertBool "dynamic library MUST be installed" - =<< liftIO (doesFileExist (dyndir mkSharedLibName - buildPlatform compiler_id uid)) - else - assertBool "dynamic library should be installed" - =<< liftIO (doesFileExist (dyndir mkSharedLibName - buildPlatform compiler_id uid)) - fails $ ghcPkg "describe" ["foo"] - -- clean away the dist directory so that we catch accidental - -- dependence on the inplace files - setup "clean" [] - runInstalledExe' "foo" [] >>= assertOutputContains "46" + skipUnless "no shared libs" =<< hasSharedLibraries + withPackageDb $ do + -- MULTI + forM_ [False, True] $ \is_dynamic -> do + setup_install $ + [ if is_dynamic + then "--enable-executable-dynamic" + else "--disable-executable-dynamic" + , "--enable-shared" + ] + dist_dir <- fmap testDistDir getTestEnv + lbi <- liftIO $ getPersistBuildConfig dist_dir + let pkg_descr = localPkgDescr lbi + compiler_id = compilerId (compiler lbi) + cname = CLibName $ LSubLibName $ mkUnqualComponentName "foo-internal" + [target] = componentNameTargets' pkg_descr lbi cname + uid = componentUnitId (targetCLBI target) + InstallDirs{libdir = dir, dynlibdir = dyndir} = + absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest + assertBool "interface files should be installed" + =<< liftIO (doesFileExist (dir "Foo.hi")) + assertBool "static library should be installed" + =<< liftIO (doesFileExist (dir mkLibName uid)) + if is_dynamic + then + assertBool "dynamic library MUST be installed" + =<< liftIO + ( doesFileExist + ( dyndir + mkSharedLibName + buildPlatform + compiler_id + uid + ) + ) + else + assertBool "dynamic library should be installed" + =<< liftIO + ( doesFileExist + ( dyndir + mkSharedLibName + buildPlatform + compiler_id + uid + ) + ) + fails $ ghcPkg "describe" ["foo"] + -- clean away the dist directory so that we catch accidental + -- dependence on the inplace files + setup "clean" [] + runInstalledExe' "foo" [] >>= assertOutputContains "46" diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Executable/src/Foo.hs b/cabal-testsuite/PackageTests/InternalLibraries/Executable/src/Foo.hs index 23413de77f4..bb935e3e326 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Executable/src/Foo.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Executable/src/Foo.hs @@ -1,4 +1,5 @@ module Foo where + {-# NOINLINE foo #-} foo :: Int -> Int foo x = x + 23 diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs index 27d36f9638a..92f93a127f6 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Haddock/haddock.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- https://github.com/haskell/cabal/issues/1919 main = setupAndCabalTest $ - withPackageDb $ do - setup_install [] - setup "haddock" [] + withPackageDb $ do + setup_install [] + setup "haddock" [] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/Foo.hs b/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/Foo.hs index cf77232aaa3..e5ef69577ed 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/Foo.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/Foo.hs @@ -1,3 +1,5 @@ module Foo where + import Internal + foo = internal + 2 diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs b/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs index 2cb2e601ab7..5ee6ee96c06 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs @@ -1,4 +1,5 @@ module Internal where + {-# NOINLINE internal #-} internal :: Int internal = 23 diff --git a/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs index daaf862ae22..ad4c677ee6b 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs @@ -1,10 +1,11 @@ import Test.Cabal.Prelude + -- Internal library used by public library; it must be installed and -- registered. main = setupAndCabalTest $ - withPackageDb $ do - withDirectory "foolib" $ setup_install [] - withDirectory "fooexe" $ do - setup_build [] - runExe' "fooexe" [] - >>= assertOutputContains "25" + withPackageDb $ do + withDirectory "foolib" $ setup_install [] + withDirectory "fooexe" $ do + setup_build [] + runExe' "fooexe" [] + >>= assertOutputContains "25" diff --git a/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs index 47b4ee7166c..1909dbbb018 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - fails $ cabal "v2-build" ["--disable-per-component", "p"] + fails $ cabal "v2-build" ["--disable-per-component", "p"] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs index 3597c664b98..f45c4d6b878 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["p"] + cabal "v2-build" ["p"] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/p/Foo.hs b/cabal-testsuite/PackageTests/InternalLibraries/p/Foo.hs index a03c8743b85..c000e24c8fe 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/p/Foo.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/p/Foo.hs @@ -1,2 +1,3 @@ import Q + main = putStrLn q diff --git a/cabal-testsuite/PackageTests/InternalLibraries/p/p/P.hs b/cabal-testsuite/PackageTests/InternalLibraries/p/p/P.hs index dd40eb4547c..5c0a446377a 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/p/p/P.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/p/p/P.hs @@ -1,3 +1,5 @@ module P where + import Q + p = "P: " ++ q diff --git a/cabal-testsuite/PackageTests/InternalLibraries/p/q/Q.hs b/cabal-testsuite/PackageTests/InternalLibraries/p/q/Q.hs index eeb2056f6fb..6adac228252 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/p/q/Q.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/p/q/Q.hs @@ -1,2 +1,3 @@ module Q where + q = "I AM THE ONE" diff --git a/cabal-testsuite/PackageTests/InternalLibraries/q/Q.hs b/cabal-testsuite/PackageTests/InternalLibraries/q/Q.hs index f44c49ac234..b4c67b23e28 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/q/Q.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/q/Q.hs @@ -1,2 +1,3 @@ module Q where + q = "DO NOT SEE ME" diff --git a/cabal-testsuite/PackageTests/InternalLibraries/r/R.hs b/cabal-testsuite/PackageTests/InternalLibraries/r/R.hs index d5a74e2f80f..e8f2c949679 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/r/R.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/r/R.hs @@ -1,3 +1,5 @@ module R where + import P + r = "R: " ++ p diff --git a/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs index 4ebc3a3f5c6..284af82a46d 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs @@ -1,24 +1,27 @@ -import Test.Cabal.Prelude import Control.Monad import Control.Monad.IO.Class -import System.Directory import Data.List +import System.Directory +import Test.Cabal.Prelude + -- Test to see if --gen-pkg-config works. main = setupAndCabalTest $ do - withPackageDb $ do - withDirectory "p" $ do - setup_build [] - setup "copy" [] - let dir = "pkg-config.bak" - setup "register" ["--gen-pkg-config=" ++ dir] - -- Infelicity! Does not respect CWD. - env <- getTestEnv - let cwd = testCurrentDir env - notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - confs <- fmap (sort . filter notHidden) - . liftIO $ getDirectoryContents (cwd dir) - forM_ confs $ \conf -> ghcPkg "register" [cwd dir conf] + withPackageDb $ do + withDirectory "p" $ do + setup_build [] + setup "copy" [] + let dir = "pkg-config.bak" + setup "register" ["--gen-pkg-config=" ++ dir] + -- Infelicity! Does not respect CWD. + env <- getTestEnv + let cwd = testCurrentDir env + notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + confs <- + fmap (sort . filter notHidden) + . liftIO + $ getDirectoryContents (cwd dir) + forM_ confs $ \conf -> ghcPkg "register" [cwd dir conf] - -- Make sure we can see p - withDirectory "r" $ setup_install [] + -- Make sure we can see p + withDirectory "r" $ setup_install [] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs index 644d437b8ab..c6e0a38cc59 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs @@ -1,15 +1,17 @@ import Test.Cabal.Prelude + -- Test to see if --gen-script main = setupAndCabalTest $ do - is_windows <- isWindows - withPackageDb $ do - withDirectory "p" $ do - setup_build [] - setup "copy" [] - setup "register" ["--gen-script"] - _ <- if is_windows - then shell "cmd" ["/C", "register.bat"] - else shell "sh" ["register.sh"] - return () - -- Make sure we can see p - withDirectory "r" $ setup_install [] + is_windows <- isWindows + withPackageDb $ do + withDirectory "p" $ do + setup_build [] + setup "copy" [] + setup "register" ["--gen-script"] + _ <- + if is_windows + then shell "cmd" ["/C", "register.bat"] + else shell "sh" ["register.sh"] + return () + -- Make sure we can see p + withDirectory "r" $ setup_install [] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs index 7df67266894..f49cd4cd233 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude + -- No cabal test because per-component is broken for it main = setupTest $ do - withPackageDb $ do - withDirectory "p" $ do - setup_install ["q"] - setup_install ["p"] - setup_install ["foo"] - runInstalledExe "foo" [] - + withPackageDb $ do + withDirectory "p" $ do + setup_install ["q"] + setup_install ["p"] + setup_install ["foo"] + runInstalledExe "foo" [] diff --git a/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs b/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs index 83341ad85f8..7c4e9f921ab 100644 --- a/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + -- Basic test for internal libraries (in p); package q is to make -- sure that the internal library correctly is used, not the -- external library. main = setupAndCabalTest $ do - withPackageDb $ do - withDirectory "q" $ setup_install [] - withDirectory "p" $ do - setup_install [] - setup "clean" [] - r <- runInstalledExe' "foo" [] - assertOutputContains "I AM THE ONE" r + withPackageDb $ do + withDirectory "q" $ setup_install [] + withDirectory "p" $ do + setup_install [] + setup "clean" [] + r <- runInstalledExe' "foo" [] + assertOutputContains "I AM THE ONE" r diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs index 955e2554d8f..3cfff933a09 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test impossible version bound on internal build-tools deps main = setupAndCabalTest $ do - assertOutputContains "impossible version range" - =<< fails (setup' "configure" []) + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs index c006efe6f72..63725e7af9d 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test unneed version bound on internal build-tools deps main = setupAndCabalTest . expectBroken 7470 $ do - setup' "configure" [] - assertOutputContains "extraneous version range" - =<< setup' "sdist" [] + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs index 955e2554d8f..3cfff933a09 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test impossible version bound on internal build-tools deps main = setupAndCabalTest $ do - assertOutputContains "impossible version range" - =<< fails (setup' "configure" []) + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs index c006efe6f72..63725e7af9d 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test unneed version bound on internal build-tools deps main = setupAndCabalTest . expectBroken 7470 $ do - setup' "configure" [] - assertOutputContains "extraneous version range" - =<< setup' "sdist" [] + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs index 955e2554d8f..3cfff933a09 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test impossible version bound on internal build-tools deps main = setupAndCabalTest $ do - assertOutputContains "impossible version range" - =<< fails (setup' "configure" []) + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs b/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs index c006efe6f72..63725e7af9d 100644 --- a/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs +++ b/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test unneed version bound on internal build-tools deps main = setupAndCabalTest . expectBroken 7470 $ do - setup' "configure" [] - assertOutputContains "extraneous version range" - =<< setup' "sdist" [] + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal-testsuite/PackageTests/JS/JsSources/js-arch.test.hs b/cabal-testsuite/PackageTests/JS/JsSources/js-arch.test.hs index 1fed749bdb8..5193f59b89d 100644 --- a/cabal-testsuite/PackageTests/JS/JsSources/js-arch.test.hs +++ b/cabal-testsuite/PackageTests/JS/JsSources/js-arch.test.hs @@ -1,9 +1,9 @@ import Test.Cabal.Prelude main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 9.6" - skipUnlessJavaScript - skipIfWindows + skipUnlessGhcVersion ">= 9.6" + skipUnlessJavaScript + skipIfWindows - res <- cabal' "v2-run" ["demo"] - assertOutputContains "Hello JS!" res + res <- cabal' "v2-run" ["demo"] + assertOutputContains "Hello JS!" res diff --git a/cabal-testsuite/PackageTests/JS/JsSources/other-arch.test.hs b/cabal-testsuite/PackageTests/JS/JsSources/other-arch.test.hs index 187a9cf73bd..96c06dadf9b 100644 --- a/cabal-testsuite/PackageTests/JS/JsSources/other-arch.test.hs +++ b/cabal-testsuite/PackageTests/JS/JsSources/other-arch.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIfJavaScript - -- Ensure the field `js-sources` does not raise issues - res <- cabal' "v2-run" ["demo"] - assertOutputContains "Hello Not JS!" res + skipIfJavaScript + -- Ensure the field `js-sources` does not raise issues + res <- cabal' "v2-run" ["demo"] + assertOutputContains "Hello Not JS!" res diff --git a/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs b/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs index 9da924366f4..9ba2d5bd291 100644 --- a/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs @@ -28,7 +28,7 @@ import Test.Cabal.Prelude -- -- Based on the UniqueIPID test. -import Control.Monad (forM, foldM_) +import Control.Monad (foldM_, forM) import Data.List (isPrefixOf, tails) data Linking = Static | Dynamic deriving (Eq, Ord, Show) @@ -37,68 +37,65 @@ links :: [Linking] links = [Static, Dynamic] linkConfigFlags :: Linking -> [String] -linkConfigFlags Static = - [ - ] +linkConfigFlags Static = + [] linkConfigFlags Dynamic = - [ - "--enable-shared", - "--enable-executable-dynamic", - "--disable-library-vanilla" - ] + [ "--enable-shared" + , "--enable-executable-dynamic" + , "--disable-library-vanilla" + ] lrun :: [Linking] lrun = [Static, Dynamic, Static, Dynamic] main = cabalTest $ do - -- Skip if on Windows, since my default Chocolatey Windows setup (and the CI - -- server setup at the time, presumably) lacks support for dynamic builds - -- since the base package appears to be static only, lacking e.g. ‘.dyn_o’ - -- files. Normal Windows installations would need support for dynamic - -- builds, or else this test would fail when it tries to build with the - -- dynamic flags. - skipIfWindows + -- Skip if on Windows, since my default Chocolatey Windows setup (and the CI + -- server setup at the time, presumably) lacks support for dynamic builds + -- since the base package appears to be static only, lacking e.g. ‘.dyn_o’ + -- files. Normal Windows installations would need support for dynamic + -- builds, or else this test would fail when it tries to build with the + -- dynamic flags. + skipIfWindows - withPackageDb $ do - -- Phase 1: get 4 hashes according to config flags. - results <- forM (zip [0..] lrun) $ \(idx, linking) -> do - withDirectory "basic" $ do - withSourceCopyDir ("basic" ++ show idx) $ do - -- (Now do ‘cd ..’, since withSourceCopyDir made our previous - -- previous such withDirectories now accumulate to be - -- relative to setup.dist/basic0, not testSourceDir - -- (see 'testCurrentDir').) - withDirectory ".." $ do - packageEnv <- ( ("basic" ++ show idx ++ ".env")) . testWorkDir <$> getTestEnv - cabal "v2-install" $ ["--disable-deterministic", "--lib", "--package-env=" ++ packageEnv] ++ linkConfigFlags linking ++ ["basic"] - let exIPID s = takeWhile (/= '\n') . head . filter (\t -> any (`isPrefixOf` t) ["basic-0.1-", "bsc-0.1-"]) $ tails s - hashedIpid <- exIPID <$> liftIO (readFile packageEnv) - return $ ((idx, linking), hashedIpid) - -- Phase 2: make sure we have different hashes iff we have different config flags. - -- In particular make sure the dynamic config flags weren't silently - -- dropped and ignored, since this is the bug that prompted this test. - (\step -> foldM_ step (const $ return ()) results) $ \acc x -> do - acc x - return $ \future -> acc future >> do - let - ((thisIdx, thisLinking), thisHashedIpid) = x - ((futureIdx, futureLinking), futureHashedIpid) = future - when ((thisHashedIpid == futureHashedIpid) /= (thisLinking == futureLinking)) $ do - assertFailure . unlines $ - if thisLinking /= futureLinking - then - -- What we are primarily concerned with testing - -- here. - [ - "Error: static and dynamic config flags produced an IPID with the same hash; were the dynamic flags silently dropped?", - "\thashed IPID: " ++ thisHashedIpid - ] - else - -- Help test our test can also make equal - -- hashes. - [ - "Error: config flags were equal, yet a different IPID hash was produced.", - "\thashed IPID 1 : " ++ thisHashedIpid, - "\thashed IPID 2 : " ++ futureHashedIpid, - "\tlinking flags : " ++ show thisLinking - ] + withPackageDb $ do + -- Phase 1: get 4 hashes according to config flags. + results <- forM (zip [0 ..] lrun) $ \(idx, linking) -> do + withDirectory "basic" $ do + withSourceCopyDir ("basic" ++ show idx) $ do + -- (Now do ‘cd ..’, since withSourceCopyDir made our previous + -- previous such withDirectories now accumulate to be + -- relative to setup.dist/basic0, not testSourceDir + -- (see 'testCurrentDir').) + withDirectory ".." $ do + packageEnv <- ( ("basic" ++ show idx ++ ".env")) . testWorkDir <$> getTestEnv + cabal "v2-install" $ ["--disable-deterministic", "--lib", "--package-env=" ++ packageEnv] ++ linkConfigFlags linking ++ ["basic"] + let exIPID s = takeWhile (/= '\n') . head . filter (\t -> any (`isPrefixOf` t) ["basic-0.1-", "bsc-0.1-"]) $ tails s + hashedIpid <- exIPID <$> liftIO (readFile packageEnv) + return $ ((idx, linking), hashedIpid) + -- Phase 2: make sure we have different hashes iff we have different config flags. + -- In particular make sure the dynamic config flags weren't silently + -- dropped and ignored, since this is the bug that prompted this test. + (\step -> foldM_ step (const $ return ()) results) $ \acc x -> do + acc x + return $ \future -> + acc future >> do + let + ((thisIdx, thisLinking), thisHashedIpid) = x + ((futureIdx, futureLinking), futureHashedIpid) = future + when ((thisHashedIpid == futureHashedIpid) /= (thisLinking == futureLinking)) $ do + assertFailure . unlines $ + if thisLinking /= futureLinking + then -- What we are primarily concerned with testing + -- here. + + [ "Error: static and dynamic config flags produced an IPID with the same hash; were the dynamic flags silently dropped?" + , "\thashed IPID: " ++ thisHashedIpid + ] + else -- Help test our test can also make equal + -- hashes. + + [ "Error: config flags were equal, yet a different IPID hash was produced." + , "\thashed IPID 1 : " ++ thisHashedIpid + , "\thashed IPID 2 : " ++ futureHashedIpid + , "\tlinking flags : " ++ show thisLinking + ] diff --git a/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs b/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs index 48a5acbbfc4..efd5a0f0767 100644 --- a/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ListBin/Script/cabal.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - res <- cabal' "list-bin" ["script.hs"] + res <- cabal' "list-bin" ["script.hs"] - env <- getTestEnv - cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" - assertOutputContains cacheDir res + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + assertOutputContains cacheDir res diff --git a/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs b/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs index 4c48926862b..76bf4094449 100644 --- a/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ListBin/SelectedComponent/cabal.test.hs @@ -1,4 +1,4 @@ -import System.FilePath ( joinPath ) +import System.FilePath (joinPath) import Test.Cabal.Prelude @@ -6,7 +6,7 @@ import Test.Cabal.Prelude -- https://github.com/haskell/cabal/issues/8400 main = cabalTest . void $ do - res <- cabal' "list-bin" ["exe:testexe"] + res <- cabal' "list-bin" ["exe:testexe"] - let path = joinPath ["SelectedComponent-1.0.0", "build", "testexe", "testexe"] - assertOutputContains path res + let path = joinPath ["SelectedComponent-1.0.0", "build", "testexe", "testexe"] + assertOutputContains path res diff --git a/cabal-testsuite/PackageTests/Macros/A.hs b/cabal-testsuite/PackageTests/Macros/A.hs index 7afe6b81ddf..d9c18c4f44e 100644 --- a/cabal-testsuite/PackageTests/Macros/A.hs +++ b/cabal-testsuite/PackageTests/Macros/A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + import C #ifdef VERSION_filepath #error "Should not see macro from library" @@ -7,4 +8,4 @@ import C #error "Should not see macro from executable macros-b" #endif main = do - putStrLn CURRENT_COMPONENT_ID + putStrLn CURRENT_COMPONENT_ID diff --git a/cabal-testsuite/PackageTests/Macros/B.hs b/cabal-testsuite/PackageTests/Macros/B.hs index 600ce17ef5e..aeb3221afe1 100644 --- a/cabal-testsuite/PackageTests/Macros/B.hs +++ b/cabal-testsuite/PackageTests/Macros/B.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + import C #ifdef VERSION_filepath #error "Should not see macro from library" @@ -7,4 +8,4 @@ import C #error "Should not see macro from executable macros-a" #endif main = do - putStrLn CURRENT_COMPONENT_ID + putStrLn CURRENT_COMPONENT_ID diff --git a/cabal-testsuite/PackageTests/Macros/setup.test.hs b/cabal-testsuite/PackageTests/Macros/setup.test.hs index 6cf5650337d..93667d68e2c 100644 --- a/cabal-testsuite/PackageTests/Macros/setup.test.hs +++ b/cabal-testsuite/PackageTests/Macros/setup.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude + -- Test to ensure that setup_macros.h are computed per-component. main = setupAndCabalTest $ do - setup_build [] - runExe "macros-a" [] - runExe "macros-b" [] - + setup_build [] + runExe "macros-a" [] + runExe "macros-b" [] diff --git a/cabal-testsuite/PackageTests/Macros/src/C.hs b/cabal-testsuite/PackageTests/Macros/src/C.hs index c3517c37f11..38127233962 100644 --- a/cabal-testsuite/PackageTests/Macros/src/C.hs +++ b/cabal-testsuite/PackageTests/Macros/src/C.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module C where #ifdef VERSION_directory #error "Should not see macro from executable macros-a" diff --git a/cabal-testsuite/PackageTests/Manpage/cabal.test.hs b/cabal-testsuite/PackageTests/Manpage/cabal.test.hs index 6b19fa4d7ce..11b01a549be 100644 --- a/cabal-testsuite/PackageTests/Manpage/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Manpage/cabal.test.hs @@ -1,24 +1,26 @@ +import Distribution.System (OS (Linux, OSX, Windows), buildOS) import System.Process -import Distribution.System (OS(Windows,Linux,OSX), buildOS) import Test.Cabal.Prelude main = cabalTest $ do - r <- cabal' "man" ["--raw"] - assertOutputContains ".B cabal install" r - assertOutputDoesNotContain ".B cabal manpage" r + r <- cabal' "man" ["--raw"] + assertOutputContains ".B cabal install" r + assertOutputDoesNotContain ".B cabal manpage" r - -- The following test of `cabal man` needs `nroff` which is not available under Windows. - unless (buildOS == Windows) $ do - - -- Check that output of `cabal man --raw` can be passed through `nroff -man` - -- without producing any warnings (which are printed to stderr). - -- - -- NB: runM is not suitable as it mixes stdout and stderr - -- r2 <- runM "nroff" ["-man", "/dev/stdin"] $ Just $ resultOutput r - (ec, _output, errors) <- liftIO $ - readProcessWithExitCode "nroff" ["-man", "/dev/stdin"] $ resultOutput r - unless (null errors) $ - assertFailure $ unlines + -- The following test of `cabal man` needs `nroff` which is not available under Windows. + unless (buildOS == Windows) $ do + -- Check that output of `cabal man --raw` can be passed through `nroff -man` + -- without producing any warnings (which are printed to stderr). + -- + -- NB: runM is not suitable as it mixes stdout and stderr + -- r2 <- runM "nroff" ["-man", "/dev/stdin"] $ Just $ resultOutput r + (ec, _output, errors) <- + liftIO $ + readProcessWithExitCode "nroff" ["-man", "/dev/stdin"] $ + resultOutput r + unless (null errors) $ + assertFailure $ + unlines [ "Error: unexpected warnings produced by `nroff -man`:" , errors ] diff --git a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/cabal.test.hs b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/cabal.test.hs index 978b52e72ec..751c9dc7528 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest $ withRepo "repo" $ do - skipUnlessGhcVersion ">= 9.4" - void $ fails $ cabalWithStdin "v2-repl" ["--keep-temp-files","--enable-multi-repl","pkg-a", "pkg-b"] "" + skipUnlessGhcVersion ">= 9.4" + void $ fails $ cabalWithStdin "v2-repl" ["--keep-temp-files", "--enable-multi-repl", "pkg-a", "pkg-b"] "" diff --git a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Foo.hs b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Foo.hs index 997ca89eecd..208f04764de 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Foo.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Foo.hs @@ -2,4 +2,3 @@ module Foo where foo :: Int foo = 42 - diff --git a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Setup.hs b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Setup.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/CabalTooOld/pkg-a/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/cabal.test.hs b/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/cabal.test.hs index 54a0afeb91e..af9d9ad8da3 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/cabal.test.hs @@ -5,7 +5,7 @@ main = do skipUnlessGhcVersion ">= 9.4" -- Note: only the last package is interactive. -- this test should load pkg-b too. - res <- cabalWithStdin "v2-repl" ["--enable-multi-repl","pkg-a", "pkg-c"] "" + res <- cabalWithStdin "v2-repl" ["--enable-multi-repl", "pkg-a", "pkg-c"] "" -- we should check that pkg-c is indeed loaded, -- but currently the unit order is non-deterministic diff --git a/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/pkg-a/Foo.hs b/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/pkg-a/Foo.hs index 997ca89eecd..208f04764de 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/pkg-a/Foo.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/EnabledClosure/pkg-a/Foo.hs @@ -2,4 +2,3 @@ module Foo where foo :: Int foo = 42 - diff --git a/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/cabal.test.hs b/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/cabal.test.hs index d7433375c94..75510efc441 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/cabal.test.hs @@ -6,6 +6,6 @@ main = do -- the package order is non-deterministic. -- add Bar.Bar input to test that packages are trully loaded -- when GHC gets support for switching active units - res <- cabalWithStdin "v2-repl" ["--enable-multi-repl","pkg-a", "pkg-b"] "" + res <- cabalWithStdin "v2-repl" ["--enable-multi-repl", "pkg-a", "pkg-b"] "" -- assertOutputContains "3735929054" res return () diff --git a/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/pkg-a/Foo.hs b/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/pkg-a/Foo.hs index 997ca89eecd..208f04764de 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/pkg-a/Foo.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/EnabledSucc/pkg-a/Foo.hs @@ -2,4 +2,3 @@ module Foo where foo :: Int foo = 42 - diff --git a/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/cabal.test.hs b/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/cabal.test.hs index e5207a203ff..110a5123bbf 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/cabal.test.hs @@ -3,12 +3,12 @@ import Test.Cabal.Prelude main = do cabalTest' "multirepl-a" $ do skipUnlessGhcVersion ">= 9.4" - res <- fails $ cabalWithStdin "v2-repl" ["--disable-multi-repl","pkg-a", "pkg-b"] "foo" + res <- fails $ cabalWithStdin "v2-repl" ["--disable-multi-repl", "pkg-a", "pkg-b"] "foo" assertOutputContains "Cannot open a repl for multiple components at once." res assertOutputContains "Your compiler supports a multiple component repl but support is not enabled." res cabalTest' "multirepl-b" $ do skipUnlessGhcVersion "< 9.4" - res <- fails $ cabalWithStdin "v2-repl" ["--disable-multi-repl","pkg-a", "pkg-b"] "foo" + res <- fails $ cabalWithStdin "v2-repl" ["--disable-multi-repl", "pkg-a", "pkg-b"] "foo" assertOutputContains "Cannot open a repl for multiple components at once." res assertOutputContains "The reason for this limitation is that your version" res diff --git a/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/pkg-a/Foo.hs b/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/pkg-a/Foo.hs index 997ca89eecd..208f04764de 100644 --- a/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/pkg-a/Foo.hs +++ b/cabal-testsuite/PackageTests/MultiRepl/NotEnabledFail/pkg-a/Foo.hs @@ -2,4 +2,3 @@ module Foo where foo :: Int foo = 42 - diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.test.hs index 44f25b88d8a..36a2ec2f864 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/Failing/cabal.test.hs @@ -1,4 +1,6 @@ import Test.Cabal.Prelude -main = cabalTest $ - void $ fails (cabal' "v2-build" ["p"]) +main = + cabalTest $ + void $ + fails (cabal' "v2-build" ["p"]) diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.test.hs index 88606589192..3587bcb5ace 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/Successful/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-def:publib" +main = + cabalTest $ + cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-def:publib" diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/Successful/pkg-abc/Main.hs b/cabal-testsuite/PackageTests/MultipleLibraries/Successful/pkg-abc/Main.hs index b9cf6f41954..f79d792efb5 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/Successful/pkg-abc/Main.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/Successful/pkg-abc/Main.hs @@ -1,4 +1,5 @@ module Main (main) where + import PkgDef (defValue) main :: IO () diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.test.hs index 49ff98d44c8..10bbfccea39 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/cabal.test.hs @@ -2,5 +2,6 @@ import Test.Cabal.Prelude -- https://github.com/haskell/cabal/issues/6083 -- see pkg-abc.cabal -main = cabalTest $ +main = + cabalTest $ cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-def:pkg-def" diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/pkg-abc/exe/Main.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/pkg-abc/exe/Main.hs index b9cf6f41954..f79d792efb5 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/pkg-abc/exe/Main.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Post/pkg-abc/exe/Main.hs @@ -1,4 +1,5 @@ module Main (main) where + import PkgDef (defValue) main :: IO () diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.test.hs index 223349d5cf1..0f42d870f2d 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/cabal.test.hs @@ -2,5 +2,6 @@ import Test.Cabal.Prelude -- This is like T6083Pre, but also goes via mixins -- -main = cabalTest $ +main = + cabalTest $ cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-def:pkg-def" diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/pkg-abc/exe/Main.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/pkg-abc/exe/Main.hs index 8e287385c6b..d50e147fa94 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/pkg-abc/exe/Main.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PostMixin/pkg-abc/exe/Main.hs @@ -1,4 +1,5 @@ module Main (main) where + import Mixin (defValue) main :: IO () diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.test.hs index 1aa1889af13..b744442a950 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/cabal.test.hs @@ -2,5 +2,6 @@ import Test.Cabal.Prelude -- https://github.com/haskell/cabal/issues/6083 -- see pkg-abc.cabal -main = cabalTest $ +main = + cabalTest $ cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-abc:pkg-def" diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/pkg-abc/exe/Main.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/pkg-abc/exe/Main.hs index b9cf6f41954..f79d792efb5 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/pkg-abc/exe/Main.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083Pre/pkg-abc/exe/Main.hs @@ -1,4 +1,5 @@ module Main (main) where + import PkgDef (defValue) main :: IO () diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.test.hs index dec445d9afb..78b30ee3577 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/cabal.test.hs @@ -2,5 +2,6 @@ import Test.Cabal.Prelude -- This is like T6083Pre, but also goes via mixins -- -main = cabalTest $ +main = + cabalTest $ cabal' "v2-run" ["pkg-abc:program"] >>= assertOutputContains "pkg-abc:pkg-def" diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/pkg-abc/exe/Main.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/pkg-abc/exe/Main.hs index 8e287385c6b..d50e147fa94 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/pkg-abc/exe/Main.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6083PreMixin/pkg-abc/exe/Main.hs @@ -1,4 +1,5 @@ module Main (main) where + import Mixin (defValue) main :: IO () diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.test.hs index 2d840c018aa..87bd378bd64 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6894/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ + +main = + cabalTest $ cabal "v2-build" ["issue"] diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.test.hs index 5172e8fd0f9..11d08fb08a1 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T6894/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - setup_build [] + setup_build [] diff --git a/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs b/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs index 1d1df1d33f9..b5a1d61ebad 100644 --- a/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs +++ b/cabal-testsuite/PackageTests/MultipleLibraries/T7270/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ withPackageDb $ do withDirectory "dep" $ setup_install [] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs index 1dcbb707b0b..0e3066af401 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs @@ -1,10 +1,9 @@ import Test.Cabal.Prelude main = cabalTest $ do - res1 <- cabal' "v2-bench" ["foo"] - assertOutputContains "Hello Foo" res1 - assertOutputDoesNotContain "Hello Bar" res1 - res2 <- cabal' "v2-bench" ["all"] - assertOutputContains "Hello Foo" res2 - assertOutputContains "Hello Bar" res2 - + res1 <- cabal' "v2-bench" ["foo"] + assertOutputContains "Hello Foo" res1 + assertOutputDoesNotContain "Hello Bar" res1 + res2 <- cabal' "v2-bench" ["all"] + assertOutputContains "Hello Foo" res2 + assertOutputContains "Hello Bar" res2 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs index bbb67dcf14a..76aefd19b11 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs @@ -7,5 +7,5 @@ main :: IO () main = do args <- getArgs if args == ["1", "2 3", "4", "5 6"] - then exitSuccess - else putStrLn ("Got: " ++ show args) >> exitFailure + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs index 9174ba94a6c..180ab573660 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs @@ -1,9 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-bench" - [ "--benchmark-option=1" - , "--benchmark-options=\"2 3\"" - , "--benchmark-option=4" - , "--benchmark-options=\"5 6\"" - ] + cabal + "v2-bench" + [ "--benchmark-option=1" + , "--benchmark-options=\"2 3\"" + , "--benchmark-option=4" + , "--benchmark-options=\"5 6\"" + ] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/WarningRTS/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/WarningRTS/cabal.test.hs index 91ebf701799..ad7101f0111 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/WarningRTS/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/WarningRTS/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "bench" ["foo", "+RTS"] - assertOutputContains "Some RTS options were found standalone" res + res <- cabal' "bench" ["foo", "+RTS"] + assertOutputContains "Some RTS options were found standalone" res - res <- cabal' "bench" ["foo", "--benchmark-options=\"+RTS\"", "+RTS"] - assertOutputContains "Some RTS options were found standalone" res + res <- cabal' "bench" ["foo", "--benchmark-options=\"+RTS\"", "+RTS"] + assertOutputContains "Some RTS options were found standalone" res - res <- cabal' "bench" ["foo", "--benchmark-options=\"+RTS\""] - assertOutputDoesNotContain "Some RTS options were found standalone" res + res <- cabal' "bench" ["foo", "--benchmark-options=\"+RTS\""] + assertOutputDoesNotContain "Some RTS options were found standalone" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/Lib.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/Lib.hs index 19149c9bcc7..7b05586d595 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/Lib.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/Lib.hs @@ -1,2 +1,3 @@ module Lib where + lib = 1 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/cabal.test.hs index 98be02a3d60..ea6b97b6cf2 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/OnlyConfigure/cabal.test.hs @@ -1,24 +1,26 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "v2-build" ["--only-configure"] - assertOutputContains "Configuring library for" res - assertOutputContains "Configuring executable 'foo' for" res - assertOutputDoesNotContain "Configuring test suite 'bar' for" res - assertOutputDoesNotContain "Configuring benchmark 'baz' for" res - assertOutputDoesNotContain "Building" res + res <- cabal' "v2-build" ["--only-configure"] + assertOutputContains "Configuring library for" res + assertOutputContains "Configuring executable 'foo' for" res + assertOutputDoesNotContain "Configuring test suite 'bar' for" res + assertOutputDoesNotContain "Configuring benchmark 'baz' for" res + assertOutputDoesNotContain "Building" res - res <- cabal' "v2-build" ["--only-configure", "--enable-tests"] - assertOutputContains "Configuring library for" res - assertOutputContains "Configuring executable 'foo' for" res - assertOutputContains "Configuring test suite 'bar' for" res - assertOutputDoesNotContain "Configuring benchmark 'baz' for" res - assertOutputDoesNotContain "Building" res + res <- cabal' "v2-build" ["--only-configure", "--enable-tests"] + assertOutputContains "Configuring library for" res + assertOutputContains "Configuring executable 'foo' for" res + assertOutputContains "Configuring test suite 'bar' for" res + assertOutputDoesNotContain "Configuring benchmark 'baz' for" res + assertOutputDoesNotContain "Building" res - res <- cabal' "v2-build" - [ "--only-configure", "--enable-tests", "--enable-benchmarks"] - assertOutputContains "Configuring library for" res - assertOutputContains "Configuring executable 'foo' for" res - assertOutputContains "Configuring test suite 'bar' for" res - assertOutputContains "Configuring benchmark 'baz' for" res - assertOutputDoesNotContain "Building" res + res <- + cabal' + "v2-build" + ["--only-configure", "--enable-tests", "--enable-benchmarks"] + assertOutputContains "Configuring library for" res + assertOutputContains "Configuring executable 'foo' for" res + assertOutputContains "Configuring test suite 'bar' for" res + assertOutputContains "Configuring benchmark 'baz' for" res + assertOutputDoesNotContain "Building" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs index db31636dc42..f85d2cbfbb4 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/Script/cabal.test.hs @@ -1,10 +1,10 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-build" ["script.hs"] + cabal' "v2-build" ["script.hs"] - env <- getTestEnv - cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" - shouldExist $ cacheDir "fake-package.cabal" - shouldExist $ cacheDir "scriptlocation" + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs index 9c0f021da5d..1d50ff0d02e 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRepl/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-build" ["script.hs"] - cabalWithStdin "v2-repl" ["script.hs"] "" + cabal' "v2-build" ["script.hs"] + cabalWithStdin "v2-repl" ["script.hs"] "" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs index e46b56d4afd..e6a5ca0b6d1 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptBuildRun/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-build" ["script.hs"] - cabal' "v2-run" ["script.hs"] + cabal' "v2-build" ["script.hs"] + cabal' "v2-run" ["script.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs index 18c1becba42..42e4b85091a 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBuild/ScriptRerun/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-build" ["script.hs"] - cabal' "v2-build" ["script.hs"] + cabal' "v2-build" ["script.hs"] + cabal' "v2-build" ["script.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs index 79dbb04e549..efc4c207d0c 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanScriptWithNoScriptsBuilt/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-clean" [] - cabal' "v2-clean" ["script.hs"] + cabal' "v2-clean" [] + cabal' "v2-clean" ["script.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs index 8063d229034..fabd04a1234 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Keep/cabal.test.hs @@ -1,18 +1,18 @@ -import Test.Cabal.Prelude import System.Directory (copyFile, removeFile) +import Test.Cabal.Prelude main = cabalTest . void $ do - env <- getTestEnv - let td = testCurrentDir env + env <- getTestEnv + let td = testCurrentDir env - cabal' "v2-build" ["script.hs"] - liftIO $ copyFile (td "script.hs") (td "script2.hs") - cabal' "v2-build" ["script2.hs"] - liftIO $ removeFile (td "script2.hs") - cabal' "v2-clean" [] + cabal' "v2-build" ["script.hs"] + liftIO $ copyFile (td "script.hs") (td "script2.hs") + cabal' "v2-build" ["script2.hs"] + liftIO $ removeFile (td "script2.hs") + cabal' "v2-clean" [] - cacheDir <- getScriptCacheDirectory (td "script.hs") - cacheDir2 <- getScriptCacheDirectory (td "script2.hs") + cacheDir <- getScriptCacheDirectory (td "script.hs") + cacheDir2 <- getScriptCacheDirectory (td "script2.hs") - shouldDirectoryExist cacheDir - shouldDirectoryNotExist cacheDir2 + shouldDirectoryExist cacheDir + shouldDirectoryNotExist cacheDir2 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs index 39ba5185e94..6dcaa7a29c9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Orphan/cabal.test.hs @@ -1,18 +1,18 @@ -import Test.Cabal.Prelude import System.Directory (copyFile, removeFile) +import Test.Cabal.Prelude main = cabalTest . void $ do - env <- getTestEnv - let td = testCurrentDir env + env <- getTestEnv + let td = testCurrentDir env - cabal' "v2-build" ["script.hs"] - liftIO $ copyFile (td "script.hs") (td "script2.hs") - cabal' "v2-build" ["script2.hs"] - liftIO $ removeFile (td "script2.hs") - cabal' "v2-clean" ["script.hs"] + cabal' "v2-build" ["script.hs"] + liftIO $ copyFile (td "script.hs") (td "script2.hs") + cabal' "v2-build" ["script2.hs"] + liftIO $ removeFile (td "script2.hs") + cabal' "v2-clean" ["script.hs"] - cacheDir <- getScriptCacheDirectory (td "script.hs") - cacheDir2 <- getScriptCacheDirectory (td "script2.hs") + cacheDir <- getScriptCacheDirectory (td "script.hs") + cacheDir2 <- getScriptCacheDirectory (td "script2.hs") - shouldDirectoryNotExist cacheDir - shouldDirectoryNotExist cacheDir2 + shouldDirectoryNotExist cacheDir + shouldDirectoryNotExist cacheDir2 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs index d3870ce1520..bcf83d0d131 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/Script/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-build" ["script.hs"] - cabal' "v2-clean" ["script.hs"] + cabal' "v2-build" ["script.hs"] + cabal' "v2-clean" ["script.hs"] - env <- getTestEnv - cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") + env <- getTestEnv + cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") - shouldDirectoryNotExist cacheDir - shouldDirectoryNotExist (testDistDir env) + shouldDirectoryNotExist cacheDir + shouldDirectoryNotExist (testDistDir env) diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs index 6e3ea40e846..f7369b08bf8 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs @@ -1,2 +1,3 @@ import InplaceDep + main = f diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs index 5c1384dfdca..e47fe5e2f22 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs @@ -1,17 +1,19 @@ +import System.Directory -- (getDirectoryContents, removeFile) import Test.Cabal.Prelude -import System.Directory-- (getDirectoryContents, removeFile) + main = cabalTest $ do - cabal "v2-build" ["inplace-dep"] - env <- getTestEnv - liftIO $ removeEnvFiles $ testSourceDir env -- we don't want existing env files to interfere - -- Drop the compiled executable into the temporary directory, to avoid cluttering the tree. If compilation succeeds, we've tested what we need to! - tmpdir <- fmap testTmpDir getTestEnv - let dest = tmpdir "a.out" - cabal "v2-exec" ["ghc", "--", "Main.hs", "-o", dest] - -- TODO external (store) deps, once v2-install is working + cabal "v2-build" ["inplace-dep"] + env <- getTestEnv + liftIO $ removeEnvFiles $ testSourceDir env -- we don't want existing env files to interfere + -- Drop the compiled executable into the temporary directory, to avoid cluttering the tree. If compilation succeeds, we've tested what we need to! + tmpdir <- fmap testTmpDir getTestEnv + let dest = tmpdir "a.out" + cabal "v2-exec" ["ghc", "--", "Main.hs", "-o", dest] + +-- TODO external (store) deps, once v2-install is working -- copy-pasted from D.C.CmdClean. removeEnvFiles :: FilePath -> IO () removeEnvFiles dir = (mapM_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) - =<< getDirectoryContents dir + =<< getDirectoryContents dir diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs index 428dab1deb2..121515990ae 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs @@ -1,5 +1,4 @@ -module InplaceDep ( f ) where +module InplaceDep (f) where f :: IO () f = putStrLn "Hello world" - diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs index d9e4733bd83..55be503969a 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ do - cabal "v2-build" [] - cabal' "v2-exec" ["foo"] >>= assertOutputContains "Hello World" +main = cabalTest $ do + cabal "v2-build" [] + cabal' "v2-exec" ["foo"] >>= assertOutputContains "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs index f453256b186..a41922c68bd 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/Script/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - res <- cabalWithStdin "v2-repl" ["script.hs"] ":main" - assertOutputContains "Hello World" res + res <- cabalWithStdin "v2-repl" ["script.hs"] ":main" + assertOutputContains "Hello World" res - env <- getTestEnv - cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" + env <- getTestEnv + cacheDir <- getScriptCacheDirectory $ testCurrentDir env "script.hs" - shouldExist $ cacheDir "fake-package.cabal" - shouldExist $ cacheDir "scriptlocation" + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs index 4167c48b5ec..c1fa309793c 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabalWithStdin "v2-repl" ["script.hs"] "" - cabalWithStdin "v2-repl" ["script.hs"] "" + cabalWithStdin "v2-repl" ["script.hs"] "" + cabalWithStdin "v2-repl" ["script.hs"] "" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs index dc470c96b45..3a23efe4e9f 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs @@ -1,4 +1,3 @@ import LibFoo main = putStrLn =<< LibFoo.getData - diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs index ecce2e829fe..3595a91b50a 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ do - cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" - cabal' "v2-run" ["bar"] >>= assertOutputContains "Hello World" +main = cabalTest $ do + cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" + cabal' "v2-run" ["bar"] >>= assertOutputContains "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs index f024f4b4b83..37d22b7ebfe 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs @@ -1,4 +1,5 @@ module LibFoo where + import Paths_foo -getData = readFile =<< getDataFileName "hello.txt" +getData = readFile =<< getDataFileName "hello.txt" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs index 73c87d442a0..a0536fe835b 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs @@ -1,4 +1,3 @@ import Paths_foo main = putStrLn =<< readFile =<< getDataFileName "hello.txt" - diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs index c664ab54c8f..096c3419128 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs @@ -1,8 +1,8 @@ +import Control.Monad ((>=>)) import Test.Cabal.Prelude -import Control.Monad ( (>=>) ) -main = cabalTest $ do - -- the exe - cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" - -- the lib - fails (cabal' "v2-run" ["ExeAndLib"]) >>= assertOutputDoesNotContain "Hello World" +main = cabalTest $ do + -- the exe + cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" + -- the lib + fails (cabal' "v2-run" ["ExeAndLib"]) >>= assertOutputDoesNotContain "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs index 4e3be9585f5..e61481aa0ba 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs @@ -1,4 +1,3 @@ -import System.Exit (exitWith, ExitCode(ExitFailure)) +import System.Exit (ExitCode (ExitFailure), exitWith) main = exitWith $ ExitFailure 42 - diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs index 0882f03def1..846fcf2a1f2 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs @@ -1,6 +1,7 @@ +import Control.Monad ((>=>)) +import System.Exit (ExitCode (ExitFailure)) import Test.Cabal.Prelude -import Control.Monad ( (>=>) ) -import System.Exit (ExitCode(ExitFailure)) -main = cabalTest $ - fails (cabal' "v2-run" ["foo"]) >>= assertExitCode (ExitFailure 42) +main = + cabalTest $ + fails (cabal' "v2-run" ["foo"]) >>= assertExitCode (ExitFailure 42) diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs index e923f12bbf0..09a18b8146c 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs @@ -1,11 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - -- some ways of explicitly specifying an exe - cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello Foo" - cabal' "v2-run" ["exe:bar"] >>= assertOutputContains "Hello Bar" - cabal' "v2-run" ["MultipleExes:foo"] >>= assertOutputContains "Hello Foo" - -- there are multiple exes in ... - fails (cabal' "v2-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project - fails (cabal' "v2-run" ["MultipleExes"]) >>= assertOutputDoesNotContain "Hello" -- in the same package - + -- some ways of explicitly specifying an exe + cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello Foo" + cabal' "v2-run" ["exe:bar"] >>= assertOutputContains "Hello Bar" + cabal' "v2-run" ["MultipleExes:foo"] >>= assertOutputContains "Hello Foo" + -- there are multiple exes in ... + fails (cabal' "v2-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project + fails (cabal' "v2-run" ["MultipleExes"]) >>= assertOutputDoesNotContain "Hello" -- in the same package diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs index 3fed39f2ccb..1cd43048de9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs @@ -1,15 +1,14 @@ import Test.Cabal.Prelude main = cabalTest $ do - -- some ways of specifying an exe without ambiguities - cabal' "v2-run" ["bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" - cabal' "v2-run" ["bar:bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" - cabal' "v2-run" ["foo:foo-exe"] >>= assertOutputContains "Hello foo:foo-exe" - cabal' "v2-run" ["bar:foo-exe"] >>= assertOutputContains "Hello bar:foo-exe" - -- there are multiple exes ... - fails (cabal' "v2-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project - fails (cabal' "v2-run" ["bar"]) >>= assertOutputDoesNotContain "Hello" -- in the same package - fails (cabal' "v2-run" ["foo-exe"]) >>= assertOutputDoesNotContain "Hello" -- with the same name - -- invalid exes - fails (cabal' "v2-run" ["foo:bar-exe"]) >>= assertOutputDoesNotContain "Hello" -- does not exist - + -- some ways of specifying an exe without ambiguities + cabal' "v2-run" ["bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" + cabal' "v2-run" ["bar:bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" + cabal' "v2-run" ["foo:foo-exe"] >>= assertOutputContains "Hello foo:foo-exe" + cabal' "v2-run" ["bar:foo-exe"] >>= assertOutputContains "Hello bar:foo-exe" + -- there are multiple exes ... + fails (cabal' "v2-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project + fails (cabal' "v2-run" ["bar"]) >>= assertOutputDoesNotContain "Hello" -- in the same package + fails (cabal' "v2-run" ["foo-exe"]) >>= assertOutputDoesNotContain "Hello" -- with the same name + -- invalid exes + fails (cabal' "v2-run" ["foo:bar-exe"]) >>= assertOutputDoesNotContain "Hello" -- does not exist diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs index 88370b0fae4..a5188f40fa6 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/RunMainBad/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = cabalTest $ do - void . fails $ cabal' "v2-run" ["./Main.hs"] + void . fails $ cabal' "v2-run" ["./Main.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs index 045c88117d7..2ddb4105534 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "v2-run" ["script.hs"] - assertOutputContains "Hello World" res + res <- cabal' "v2-run" ["script.hs"] + assertOutputContains "Hello World" res - env <- getTestEnv - cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") + env <- getTestEnv + cacheDir <- getScriptCacheDirectory (testCurrentDir env "script.hs") - shouldExist $ cacheDir "fake-package.cabal" - shouldExist $ cacheDir "scriptlocation" + shouldExist $ cacheDir "fake-package.cabal" + shouldExist $ cacheDir "scriptlocation" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs index f1a7e4780d1..645b2ce2551 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptBad/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = cabalTest $ do - void . fails $ cabal' "v2-run" ["script.hs"] + void . fails $ cabal' "v2-run" ["script.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs index 64c858e8d0d..f97c67389a5 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "v2-run" ["script.lhs"] - assertOutputContains "Hello World" res + res <- cabal' "v2-run" ["script.lhs"] + assertOutputContains "Hello World" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs index b78a6941a79..67f399f33cd 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptNoExtension/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-run" ["with sp"] >>= assertOutputContains "Hello World" + cabal' "v2-run" ["with sp"] >>= assertOutputContains "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs index 7df7f1451bc..6a013bd40cf 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptRerun/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude main = cabalTest . void $ do - cabal' "v2-run" ["script.hs"] - cabal' "v2-run" ["script.hs"] + cabal' "v2-run" ["script.hs"] + cabal' "v2-run" ["script.hs"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs index 8c92079136b..a108347b01b 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptWithProjectBlock/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - -- script is called "s.hs" to avoid Windows long path issue in CI - res <- cabal' "v2-run" ["s.hs"] - assertOutputContains "Hello World" res + -- script is called "s.hs" to avoid Windows long path issue in CI + res <- cabal' "v2-run" ["s.hs"] + assertOutputContains "Hello World" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs index 4236ac551a0..112429e3d2a 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs @@ -1,14 +1,16 @@ +import Control.Monad ((>=>)) import Test.Cabal.Prelude -import Control.Monad ( (>=>) ) -main = cabalTest $ do - -- Some different ways of calling an executable that should all work - -- on a single-exe single-package project - mapM_ (cabal' "v2-run" >=> assertOutputContains "Hello World") - [ ["foo"] - , ["Single"] - , [] - , ["Single:foo"] - , ["exe:foo"] ] - -- non-existent exe - fails (cabal' "v2-run" ["bar"]) >>= assertOutputDoesNotContain "Hello World" +main = cabalTest $ do + -- Some different ways of calling an executable that should all work + -- on a single-exe single-package project + mapM_ + (cabal' "v2-run" >=> assertOutputContains "Hello World") + [ ["foo"] + , ["Single"] + , [] + , ["Single:foo"] + , ["exe:foo"] + ] + -- non-existent exe + fails (cabal' "v2-run" ["bar"]) >>= assertOutputDoesNotContain "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs index 0d938d882a6..51313e2f2a8 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs @@ -1,9 +1,9 @@ -import Control.Concurrent (killThread, threadDelay, myThreadId) +import Control.Concurrent (killThread, myThreadId, threadDelay) import Control.Exception (finally) -import qualified System.Posix.Signals as Signal -import System.Exit (exitFailure) import qualified Data.Time.Clock as Time import qualified Data.Time.Format as Time +import System.Exit (exitFailure) +import qualified System.Posix.Signals as Signal main = do -- timestamped logging to aid with #8416 @@ -13,10 +13,11 @@ main = do putStrLn $ tsfmt <> " [exe ] " <> msg mainThreadId <- myThreadId Signal.installHandler Signal.sigTERM (Signal.Catch $ killThread mainThreadId) Nothing - (do - log "about to write file" - writeFile "exe.run" "up and running" - log "about to sleep" - threadDelay 10000000 -- 10s - log "done sleeping") + ( do + log "about to write file" + writeFile "exe.run" "up and running" + log "about to sleep" + threadDelay 10000000 -- 10s + log "done sleeping" + ) `finally` log "exiting" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs index 9d5c8f91242..d2a233812a8 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs @@ -1,11 +1,11 @@ -import Test.Cabal.Prelude -import qualified System.Process as Process import Control.Concurrent (threadDelay) -import System.Directory (removeFile) import Control.Exception (catch, throwIO) -import System.IO.Error (isDoesNotExistError) import qualified Data.Time.Clock as Time import qualified Data.Time.Format as Time +import System.Directory (removeFile) +import System.IO.Error (isDoesNotExistError) +import qualified System.Process as Process +import Test.Cabal.Prelude {- This test verifies that 'cabal run' terminates its @@ -47,29 +47,32 @@ main = cabalTest $ do -- finishing its sleep assertOutputContains "exiting" r assertOutputDoesNotContain "done sleeping" r - where catchNoExist action handle = - action `catch` - (\e -> if isDoesNotExistError e then handle else throwIO e) + action + `catch` (\e -> if isDoesNotExistError e then handle else throwIO e) waitFile totalWait f | totalWait <= 0 = error "waitFile timed out" - | otherwise = readFile f `catchNoExist` do - threadDelay delta - waitFile (totalWait - delta) f + | otherwise = + readFile f `catchNoExist` do + threadDelay delta + waitFile (totalWait - delta) f delta = 50000 -- 0.05s total = 10000000 -- 10s cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do - configured_prog <- requireProgramM cabalProgram - env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) - (Just (testCurrentDir env)) - (testEnvironment env) - (programPath configured_prog) - args - Nothing - action - recordLog r - requireSuccess r + configured_prog <- requireProgramM cabalProgram + env <- getTestEnv + r <- + liftIO $ + runAction + (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + (programPath configured_prog) + args + Nothing + action + recordLog r + requireSuccess r diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs index 99b9f2008a2..55a94cee78f 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "run" ["foo", "+RTS"] - assertOutputContains "Warning: Your RTS options" res + res <- cabal' "run" ["foo", "+RTS"] + assertOutputContains "Warning: Your RTS options" res - res <- cabal' "run" ["foo", "+RTS", "--"] - assertOutputContains "Warning: Your RTS options" res + res <- cabal' "run" ["foo", "+RTS", "--"] + assertOutputContains "Warning: Your RTS options" res - res <- cabal' "run" ["foo", "--", "+RTS"] - assertOutputDoesNotContain "Warning: Your RTS options" res + res <- cabal' "run" ["foo", "--", "+RTS"] + assertOutputDoesNotContain "Warning: Your RTS options" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs b/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs index bbb67dcf14a..76aefd19b11 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs @@ -7,5 +7,5 @@ main :: IO () main = do args <- getArgs if args == ["1", "2 3", "4", "5 6"] - then exitSuccess - else putStrLn ("Got: " ++ show args) >> exitFailure + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs index e9b8f5b6c12..1ddf2aa4539 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs @@ -1,9 +1,10 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-test" - [ "--test-option=1" - , "--test-options=\"2 3\"" - , "--test-option=4" - , "--test-options=\"5 6\"" - ] + cabal + "v2-test" + [ "--test-option=1" + , "--test-options=\"2 3\"" + , "--test-option=4" + , "--test-options=\"5 6\"" + ] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdTest/WarningRTS/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdTest/WarningRTS/cabal.test.hs index fd759b05100..caefa65c77c 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdTest/WarningRTS/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdTest/WarningRTS/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest $ do - res <- cabal' "test" ["foo", "+RTS"] - assertOutputContains "Some RTS options were found standalone" res + res <- cabal' "test" ["foo", "+RTS"] + assertOutputContains "Some RTS options were found standalone" res - res <- cabal' "test" ["foo", "--test-options=\"+RTS\"", "+RTS"] - assertOutputContains "Some RTS options were found standalone" res + res <- cabal' "test" ["foo", "--test-options=\"+RTS\"", "+RTS"] + assertOutputContains "Some RTS options were found standalone" res - res <- cabal' "test" ["foo", "--test-options=\"+RTS\""] - assertOutputDoesNotContain "Some RTS options were found standalone" res + res <- cabal' "test" ["foo", "--test-options=\"+RTS\""] + assertOutputDoesNotContain "Some RTS options were found standalone" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs index 73ae18be616..f1ecc8a5b08 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs @@ -1,4 +1,4 @@ -import SetupDep (message) import Distribution.Simple +import SetupDep (message) main = putStrLn ("pkg Setup.hs: " ++ message) >> defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs b/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs index 5df3bd44e2e..3aa1bc96384 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs @@ -4,7 +4,6 @@ import Test.Cabal.Prelude -- setup dependency on remote-setup-dep-3.0. main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do - -- TODO: Debug this failure on Windows. skipIfWindows diff --git a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs index ad2600d6862..7f674ef0eeb 100644 --- a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withSourceCopy . withDelay $ do - copySourceFileTo "q/q-broken.cabal.in" "q/q.cabal" - fails $ cabal "v2-build" ["q"] - delay - copySourceFileTo "q/q-fixed.cabal.in" "q/q.cabal" - cabal "v2-build" ["q"] + withSourceCopy . withDelay $ do + copySourceFileTo "q/q-broken.cabal.in" "q/q.cabal" + fails $ cabal "v2-build" ["q"] + delay + copySourceFileTo "q/q-fixed.cabal.in" "q/q.cabal" + cabal "v2-build" ["q"] diff --git a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs index ff0763450b3..713261ab178 100644 --- a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs @@ -1,4 +1,6 @@ module Main where + import P + main :: IO () main = return () diff --git a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs b/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs index ac14f3ce5cb..aae23c62944 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs @@ -1,3 +1,4 @@ module C where + import A import B diff --git a/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs index 76895a63f05..a14fdcef7c2 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = cabalTest $ do - -- Parallel flag means output of this test is nondeterministic - recordMode DoNotRecord $ - cabal "v2-build" ["-j", "T3460"] + -- Parallel flag means output of this test is nondeterministic + recordMode DoNotRecord $ + cabal "v2-build" ["-j", "T3460"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs index f418538b074..200c2481edc 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do linux <- isLinux osx <- isOSX diff --git a/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs b/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs index 90c9d5f1204..e91e15ddee2 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs @@ -1,2 +1,3 @@ module P where + p = True diff --git a/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs b/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs index 370e8f7fd9c..d343fc5e6f5 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs @@ -1,3 +1,5 @@ module Main where + import P + main = print p diff --git a/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs index 19d792581ba..9b491764dc0 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - fails $ cabal "v2-build" ["q"] + fails $ cabal "v2-build" ["q"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs index 08ba40ee0ca..8747f16f11c 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["q"] + cabal "v2-build" ["q"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs index 3e3b8de853e..afef1408e2b 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4288/cabal.test.hs @@ -11,7 +11,8 @@ main = cabalTest $ do r <- recordMode DoNotRecord $ cabal' "v2-build" ["T4288"] assertOutputContains "This is setup-helper-1.0." r assertOutputContains - ("In order, the following will be built: " - ++ " - setup-helper-1.0 (lib:setup-helper) (first run) " - ++ " - T4288-1.0 (lib:T4288) (first run)") - r + ( "In order, the following will be built: " + ++ " - setup-helper-1.0 (lib:setup-helper) (first run) " + ++ " - T4288-1.0 (lib:T4288) (first run)" + ) + r diff --git a/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs index e13a7dfdeaf..62255a2bbeb 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = withShorterPathForNewBuildStore $ \storeDir -> -- TODO: is this test ever run? cabalTest $ do @@ -10,4 +11,4 @@ main = withShorterPathForNewBuildStore $ \storeDir -> -- we had the full Hackage index, we'd try it.) skipUnlessGhcVersion "< 8.1" withRepo "repo" $ do - cabalG ["--store-dir=" ++ storeDir] "v2-build" ["a"] + cabalG ["--store-dir=" ++ storeDir] "v2-build" ["a"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs b/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs index f4185b6527a..2bcd58c9f56 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs @@ -1,2 +1,3 @@ module System.Time where + import System.Locale diff --git a/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs index 06a1f7a5a43..c4d96556700 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["q"] - cabal "v2-build" ["q"] + cabal "v2-build" ["q"] + cabal "v2-build" ["q"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs b/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs index 8c7bcdc87b9..cd1b8b22d71 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs @@ -1,2 +1,3 @@ module Q where + import P diff --git a/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs index 43a9750805e..31f242d945e 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + main = cabalTest $ do - skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal - -- Custom Setups inconsistently report output depending - -- on your boot GHC. - recordMode DoNotRecord $ cabal "v2-build" ["foo"] - recordMode DoNotRecord $ cabal "v2-build" ["dep"] + skipUnless "no v2-build compatible boot-Cabal" =<< hasNewBuildCompatBootCabal + -- Custom Setups inconsistently report output depending + -- on your boot GHC. + recordMode DoNotRecord $ cabal "v2-build" ["foo"] + recordMode DoNotRecord $ cabal "v2-build" ["dep"] diff --git a/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs index e9ed7ec90e8..da3463d38b7 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" + cabal' "v2-run" ["foo"] >>= assertOutputContains "Hello World" diff --git a/cabal-testsuite/PackageTests/NewBuild/T5164/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/T5164/cabal.test.hs index 54fd969e2b0..8927396b6e2 100644 --- a/cabal-testsuite/PackageTests/NewBuild/T5164/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/T5164/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do - r1 <- recordMode DoNotRecord $ cabal' "v2-build" ["all"] - assertOutputContains "Example data file" r1 + r1 <- recordMode DoNotRecord $ cabal' "v2-build" ["all"] + assertOutputContains "Example data file" r1 diff --git a/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs b/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs +++ b/cabal-testsuite/PackageTests/NewConfigure/ConfigFile/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs b/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs +++ b/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs b/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs index ebb8c3d2f72..68957faf67b 100644 --- a/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs @@ -1,11 +1,11 @@ import Test.Cabal.Prelude main = cabalTest $ - withSourceCopy $ do - cabal' "v2-configure" [] >>= - assertOutputContains "backing it up to 'cabal.project.local~'" + withSourceCopy $ do + cabal' "v2-configure" [] + >>= assertOutputContains "backing it up to 'cabal.project.local~'" - -- With --project-file - cabal' "v2-configure" ["--project-file", "foo.project"] >>= - assertOutputContains - "'foo.project.local' already exists, backing it up to 'foo.project.local~'" + -- With --project-file + cabal' "v2-configure" ["--project-file", "foo.project"] + >>= assertOutputContains + "'foo.project.local' already exists, backing it up to 'foo.project.local~'" diff --git a/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.test.hs b/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.test.hs index ff35d59f53e..bb5bd71a60a 100644 --- a/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.test.hs +++ b/cabal-testsuite/PackageTests/NewFreeze/BuildTools/new_freeze.test.hs @@ -1,6 +1,6 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class import System.Directory +import Test.Cabal.Prelude -- Test that 'cabal v2-freeze' works with multiple versions of a build tool -- dependency. diff --git a/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.test.hs b/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.test.hs index 3aef354e222..e0f7f384636 100644 --- a/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.test.hs +++ b/cabal-testsuite/PackageTests/NewFreeze/Flags/new_freeze.test.hs @@ -1,35 +1,36 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class import Data.Char import System.Directory +import Test.Cabal.Prelude -- Test that 'cabal v2-freeze' freezes flag choices. my-local-package depends -- on my-library-dep. my-library-dep has a flag, my-flag, which defaults to -- true. -main = cabalTest $ withSourceCopy $ - withRepo "repo" $ do - cabal' "v2-build" ["--dry-run"] >>= assertDependencyFlagChoice True +main = cabalTest $ + withSourceCopy $ + withRepo "repo" $ do + cabal' "v2-build" ["--dry-run"] >>= assertDependencyFlagChoice True - cabal "v2-freeze" ["--constraint=my-library-dep -my-flag"] + cabal "v2-freeze" ["--constraint=my-library-dep -my-flag"] - cwd <- fmap testCurrentDir getTestEnv - let freezeFile = cwd "cabal.project.freeze" + cwd <- fmap testCurrentDir getTestEnv + let freezeFile = cwd "cabal.project.freeze" - -- The freeze file should constrain the version and the flag. - -- TODO: The flag constraint should be qualified. See - -- https://github.com/haskell/cabal/issues/5134. - assertFileDoesContain freezeFile "any.my-library-dep ==1.0" - assertFileDoesContain freezeFile "my-library-dep -my-flag" + -- The freeze file should constrain the version and the flag. + -- TODO: The flag constraint should be qualified. See + -- https://github.com/haskell/cabal/issues/5134. + assertFileDoesContain freezeFile "any.my-library-dep ==1.0" + assertFileDoesContain freezeFile "my-library-dep -my-flag" - -- cabal should be able to find an install plan that fits the constraints - -- from the freeze file. - cabal' "v2-build" ["--dry-run"] >>= assertDependencyFlagChoice False + -- cabal should be able to find an install plan that fits the constraints + -- from the freeze file. + cabal' "v2-build" ["--dry-run"] >>= assertDependencyFlagChoice False where -- my-library-dep's flag controls whether it depends on true-dep or -- false-dep, so this function uses the dependency to infer the flag choice. assertDependencyFlagChoice True out = do - assertOutputContains "true-dep-1.0 (lib)" out - assertOutputDoesNotContain "false-dep" out + assertOutputContains "true-dep-1.0 (lib)" out + assertOutputDoesNotContain "false-dep" out assertDependencyFlagChoice False out = do - assertOutputContains "false-dep-1.0 (lib)" out - assertOutputDoesNotContain "true-dep" out + assertOutputContains "false-dep-1.0 (lib)" out + assertOutputDoesNotContain "true-dep" out diff --git a/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs b/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs index 912649bba8c..5c6961da09b 100644 --- a/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs +++ b/cabal-testsuite/PackageTests/NewFreeze/FreezeFile/new_freeze.test.hs @@ -1,58 +1,59 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class import Data.Char import System.Directory +import Test.Cabal.Prelude -- Test for 'cabal v2-freeze' with only a single library dependency. -- my-local-package depends on my-library-dep, which has versions 1.0 and 2.0. main = withShorterPathForNewBuildStore $ \storeDir -> - cabalTest $ withSourceCopy $ - withRepo "repo" $ do - cwd <- fmap testCurrentDir getTestEnv - let freezeFile = cwd "cabal.project.freeze" - - shouldNotExist freezeFile - - -- v2-build should choose the latest version for the dependency. - cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["--dry-run"] >>= assertUsesLatestDependency - - -- should not create freeze file with --dry-run or --only-download flags - cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--dry-run"] - cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--only-download"] - shouldNotExist freezeFile - - -- Freeze a dependency on the older version. - cabalG ["--store-dir=" ++ storeDir] "v2-freeze" ["--constraint=my-library-dep==1.0"] - - -- The file should constrain the dependency, but not the local package. - shouldExist freezeFile - assertFileDoesContain freezeFile "any.my-library-dep ==1.0" - assertFileDoesNotContain freezeFile "my-local-package" - - -- cabal should be able to build the package using the constraint from the - -- freeze file. - cabalG' ["--store-dir=" ++ storeDir] "v2-build" [] >>= assertDoesNotUseLatestDependency - - -- Re-running v2-freeze should not change the constraints, because cabal - -- should use the existing freeze file when choosing the new install plan. - cabalG ["--store-dir=" ++ storeDir] "v2-freeze" [] - assertFileDoesContain freezeFile "any.my-library-dep ==1.0" - - -- cabal should choose the latest version again after the freeze file is - -- removed. - liftIO $ removeFile freezeFile - cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["--dry-run"] >>= assertUsesLatestDependency - - -- Re-running v2-freeze with no constraints or freeze file should constrain - -- the dependency to the latest version. - cabalG ["--store-dir=" ++ storeDir] "v2-freeze" [] - assertFileDoesContain freezeFile "any.my-library-dep ==2.0" - assertFileDoesNotContain freezeFile "my-local-package" - where - assertUsesLatestDependency out = do - assertOutputContains "my-library-dep-2.0 (lib)" out - assertOutputDoesNotContain "my-library-dep-1.0" out - - assertDoesNotUseLatestDependency out = do - assertOutputContains "my-library-dep-1.0 (lib)" out - assertOutputDoesNotContain "my-library-dep-2.0" out + cabalTest $ + withSourceCopy $ + withRepo "repo" $ do + cwd <- fmap testCurrentDir getTestEnv + let freezeFile = cwd "cabal.project.freeze" + + shouldNotExist freezeFile + + -- v2-build should choose the latest version for the dependency. + cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["--dry-run"] >>= assertUsesLatestDependency + + -- should not create freeze file with --dry-run or --only-download flags + cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--dry-run"] + cabalG' ["--store-dir=" ++ storeDir] "v2-freeze" ["--only-download"] + shouldNotExist freezeFile + + -- Freeze a dependency on the older version. + cabalG ["--store-dir=" ++ storeDir] "v2-freeze" ["--constraint=my-library-dep==1.0"] + + -- The file should constrain the dependency, but not the local package. + shouldExist freezeFile + assertFileDoesContain freezeFile "any.my-library-dep ==1.0" + assertFileDoesNotContain freezeFile "my-local-package" + + -- cabal should be able to build the package using the constraint from the + -- freeze file. + cabalG' ["--store-dir=" ++ storeDir] "v2-build" [] >>= assertDoesNotUseLatestDependency + + -- Re-running v2-freeze should not change the constraints, because cabal + -- should use the existing freeze file when choosing the new install plan. + cabalG ["--store-dir=" ++ storeDir] "v2-freeze" [] + assertFileDoesContain freezeFile "any.my-library-dep ==1.0" + + -- cabal should choose the latest version again after the freeze file is + -- removed. + liftIO $ removeFile freezeFile + cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["--dry-run"] >>= assertUsesLatestDependency + + -- Re-running v2-freeze with no constraints or freeze file should constrain + -- the dependency to the latest version. + cabalG ["--store-dir=" ++ storeDir] "v2-freeze" [] + assertFileDoesContain freezeFile "any.my-library-dep ==2.0" + assertFileDoesNotContain freezeFile "my-local-package" + where + assertUsesLatestDependency out = do + assertOutputContains "my-library-dep-2.0 (lib)" out + assertOutputDoesNotContain "my-library-dep-1.0" out + + assertDoesNotUseLatestDependency out = do + assertOutputContains "my-library-dep-1.0 (lib)" out + assertOutputDoesNotContain "my-library-dep-2.0" out diff --git a/cabal-testsuite/PackageTests/NewHaddock/DisableDoc/cabal.test.hs b/cabal-testsuite/PackageTests/NewHaddock/DisableDoc/cabal.test.hs index d7d58cdb3f9..e15a7d58e33 100644 --- a/cabal-testsuite/PackageTests/NewHaddock/DisableDoc/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewHaddock/DisableDoc/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test that `cabal haddock --disable-documention` works as expected and leads -- to a warning if a local package makes an outer reference. main = cabalTest . withRepo "repo" $ do - r <- cabal' "haddock" ["--disable-documentation", "B"] - assertOutputContains "Warning: B: could not find link destinations for" r + r <- cabal' "haddock" ["--disable-documentation", "B"] + assertOutputContains "Warning: B: could not find link destinations for" r diff --git a/cabal-testsuite/PackageTests/NewHaddock/Fails/Example.hs b/cabal-testsuite/PackageTests/NewHaddock/Fails/Example.hs index 76287b43f72..c29012fc826 100644 --- a/cabal-testsuite/PackageTests/NewHaddock/Fails/Example.hs +++ b/cabal-testsuite/PackageTests/NewHaddock/Fails/Example.hs @@ -1,6 +1,6 @@ -module Example where - -import Prelude - -example :: Int -example = False +module Example where + +import Prelude + +example :: Int +example = False diff --git a/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.test.hs b/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.test.hs index e872b316459..093dad1003e 100644 --- a/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.test.hs @@ -1,6 +1,6 @@ -import Test.Cabal.Prelude import System.Exit (ExitCode (..)) +import Test.Cabal.Prelude main = cabalTest $ do - fails $ cabal "v2-build" ["example"] - fails $ cabal "v2-haddock" ["example"] + fails $ cabal "v2-build" ["example"] + fails $ cabal "v2-haddock" ["example"] diff --git a/cabal-testsuite/PackageTests/NewHaddock/ImplyDependencies/cabal.test.hs b/cabal-testsuite/PackageTests/NewHaddock/ImplyDependencies/cabal.test.hs index 39ea4c51cbb..0269e66b9ef 100644 --- a/cabal-testsuite/PackageTests/NewHaddock/ImplyDependencies/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewHaddock/ImplyDependencies/cabal.test.hs @@ -1,6 +1,8 @@ import Test.Cabal.Prelude + -- Test that `cabal haddock` doesn't require explicit -- `--enable-dependencies` to happily process links to external packages. -- In this example package B depends on an external package A. -main = cabalTest . withRepo "repo" $ +main = + cabalTest . withRepo "repo" $ cabal "haddock" ["B"] diff --git a/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs b/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs index 67c2944b39c..4ffa9137990 100644 --- a/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/DeterministicTrivial/deterministic.test.hs @@ -1,29 +1,32 @@ -import Test.Cabal.Prelude import qualified Data.ByteString as BS +import Test.Cabal.Prelude + -- import qualified Data.ByteString.Base16 as BS16 -- import qualified Crypto.Hash.SHA256 as SHA256 import System.FilePath - ( () ) + ( () + ) - -- Note: we cannot simply use `expectBroken` or `skip` or similar - -- becuase this test fails on imports (see #8357). +-- Note: we cannot simply use `expectBroken` or `skip` or similar +-- becuase this test fails on imports (see #8357). main = cabalTest $ do - cabal "v2-sdist" ["deterministic"] - env <- getTestEnv - let dir = testCurrentDir env - knownSdist = dir "deterministic-0.tar.gz" - mySdist = dir "dist-newstyle" "sdist" "deterministic-0.tar.gz" + cabal "v2-sdist" ["deterministic"] + env <- getTestEnv + let dir = testCurrentDir env + knownSdist = dir "deterministic-0.tar.gz" + mySdist = dir "dist-newstyle" "sdist" "deterministic-0.tar.gz" + + -- This helps to understand why this test fails, if it does: + -- + -- shell "tar" ["-tzvf", knownSdist] + -- shell "tar" ["-tzvf", mySdist] + -- - -- This helps to understand why this test fails, if it does: - -- - -- shell "tar" ["-tzvf", knownSdist] - -- shell "tar" ["-tzvf", mySdist] - -- + known <- liftIO (BS.readFile knownSdist) + unknown <- liftIO (BS.readFile mySdist) - known <- liftIO (BS.readFile knownSdist) - unknown <- liftIO (BS.readFile mySdist) + skipIf "#8356" True -- bogus, just to indicate that the test is skipped + assertEqual "hashes didn't match for sdist" True True - skipIf "#8356" True -- bogus, just to indicate that the test is skipped - assertEqual "hashes didn't match for sdist" True True - -- assertEqual "hashes didn't match for sdist" (BS16.encode $ SHA256.hash known) (BS16.encode $ SHA256.hash unknown) +-- assertEqual "hashes didn't match for sdist" (BS16.encode $ SHA256.hash known) (BS16.encode $ SHA256.hash unknown) diff --git a/cabal-testsuite/PackageTests/NewSdist/Globbing/cabal.test.hs b/cabal-testsuite/PackageTests/NewSdist/Globbing/cabal.test.hs index 832177dc84f..7452bf70fd0 100644 --- a/cabal-testsuite/PackageTests/NewSdist/Globbing/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/Globbing/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cabal "v2-sdist" ["a", "--list-only"] - diff --git a/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/Main.hs b/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/Main.hs index ed19e6004cc..8e366f26a96 100644 --- a/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/Main.hs +++ b/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/Main.hs @@ -1,4 +1,4 @@ -module Main (main) where - -main :: IO () -main = putStrLn "Hello, World!" +module Main (main) where + +main :: IO () +main = putStrLn "Hello, World!" diff --git a/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs b/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs index 2db0070c4ed..bdaa790d43a 100644 --- a/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/ManyDataFiles/many-data-files.test.hs @@ -1,17 +1,17 @@ -import Test.Cabal.Prelude - -import Control.Applicative ((<$>)) -import System.Directory ( createDirectoryIfMissing ) -import qualified Data.ByteString.Char8 as BS - -main = cabalTest . withSourceCopy $ do - limit <- getOpenFilesLimit - cwd <- testCurrentDir <$> getTestEnv - - case limit of - Just n -> do - liftIO $ createDirectoryIfMissing False (cwd "data") - forM_ [1 .. n + 100] $ \i -> - liftIO $ BS.writeFile (cwd "data" ("data-file-" ++ show i) <.> "txt") (BS.pack "a data file\n") - cabal "v2-sdist" ["many-data-files"] - Nothing -> skip "no open file limit" +import Test.Cabal.Prelude + +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 as BS +import System.Directory (createDirectoryIfMissing) + +main = cabalTest . withSourceCopy $ do + limit <- getOpenFilesLimit + cwd <- testCurrentDir <$> getTestEnv + + case limit of + Just n -> do + liftIO $ createDirectoryIfMissing False (cwd "data") + forM_ [1 .. n + 100] $ \i -> + liftIO $ BS.writeFile (cwd "data" ("data-file-" ++ show i) <.> "txt") (BS.pack "a data file\n") + cabal "v2-sdist" ["many-data-files"] + Nothing -> skip "no open file limit" diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-output-dir.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-output-dir.test.hs index 97a48c56892..2305044a3a3 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-output-dir.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-output-dir.test.hs @@ -1,5 +1,6 @@ -import Test.Cabal.Prelude import System.Directory +import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv liftIO $ createDirectoryIfMissing False $ cwd "archives" diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs index 92bfd9522f4..404c64abe82 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv fails $ cabal "v2-sdist" ["all:tests"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all.test.hs index d5b8c4420d9..6b6bc10519e 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv cabal "v2-sdist" ["all"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/list-sources-output-dir.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/list-sources-output-dir.test.hs index 3f119909e0f..8c569e2f652 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/list-sources-output-dir.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/list-sources-output-dir.test.hs @@ -1,6 +1,7 @@ -import Test.Cabal.Prelude import System.Directory import System.FilePath +import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv liftIO $ createDirectoryIfMissing False $ cwd "lists" diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.test.hs index fdc3db695b2..ef7067ca26a 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-archive-to-stdout.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv fails $ cabal "v2-sdist" ["a", "b", "--output-dir", "-"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-list-sources.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-list-sources.test.hs index 2686d035980..f51716b362b 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-list-sources.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-list-sources.test.hs @@ -1,4 +1,7 @@ -import Test.Cabal.Prelude import Data.List -main = cabalTest $ withSourceCopy $ - cabal "v2-sdist" ["a", "b", "--list-only"] +import Test.Cabal.Prelude + +main = + cabalTest $ + withSourceCopy $ + cabal "v2-sdist" ["a", "b", "--list-only"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-target.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-target.test.hs index 92b50dd5b52..cd905e55e34 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-target.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/multi-target.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv cabal "v2-sdist" ["a", "b"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.test.hs index 45639a2aa23..ec68616949f 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/target-remote-package.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv fails $ cabal "v2-sdist" ["a", "base"] diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.test.hs index 0e2c15193c5..7a2a428d257 100644 --- a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/valid-and-test-suite.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withSourceCopy $ do cwd <- fmap testCurrentDir getTestEnv fails $ cabal "v2-sdist" ["a", "b", "a-tests"] diff --git a/cabal-testsuite/PackageTests/NewSdist/NullTerminated/cabal.test.hs b/cabal-testsuite/PackageTests/NewSdist/NullTerminated/cabal.test.hs index 9fd9ab2218d..9ca269cccb8 100644 --- a/cabal-testsuite/PackageTests/NewSdist/NullTerminated/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewSdist/NullTerminated/cabal.test.hs @@ -1,4 +1,6 @@ -import Test.Cabal.Prelude import Data.List -main = cabalTest $ - cabal "v2-sdist" ["--list-only", "--null"] +import Test.Cabal.Prelude + +main = + cabalTest $ + cabal "v2-sdist" ["--list-only", "--null"] diff --git a/cabal-testsuite/PackageTests/OrderFlags/Foo.hs b/cabal-testsuite/PackageTests/OrderFlags/Foo.hs index 937afe7945c..3162326a355 100644 --- a/cabal-testsuite/PackageTests/OrderFlags/Foo.hs +++ b/cabal-testsuite/PackageTests/OrderFlags/Foo.hs @@ -4,5 +4,6 @@ x :: IO Int x = return 5 f :: IO Int -f = do x - return 3 +f = do + x + return 3 diff --git a/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs b/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs index 0feccd5a426..bf706586227 100644 --- a/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs +++ b/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test that setup properly orders GHC flags passed to GHC (when -- there are multiple ghc-options fields.) main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs b/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs index 84c2a1d58c8..eb1640ee561 100644 --- a/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs +++ b/cabal-testsuite/PackageTests/Outdated/outdated-project-file.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do res <- cabal' "outdated" ["--v2-freeze-file", "--project-file", "variant.project"] assertOutputContains "base" res diff --git a/cabal-testsuite/PackageTests/Outdated/outdated.test.hs b/cabal-testsuite/PackageTests/Outdated/outdated.test.hs index 228643378ce..b9ba7438ea9 100644 --- a/cabal-testsuite/PackageTests/Outdated/outdated.test.hs +++ b/cabal-testsuite/PackageTests/Outdated/outdated.test.hs @@ -1,31 +1,37 @@ import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do - cabal' "outdated" [] >>= - (\out -> do - assertOutputContains "base" out - assertOutputContains "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" [] + >>= ( \out -> do + assertOutputContains "base" out + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out + ) - cabal' "outdated" ["--ignore=base"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" ["--ignore=base"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out + ) - cabal' "outdated" ["--ignore=base,template-haskell"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" ["--ignore=base,template-haskell"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out + ) - cabal' "outdated" ["--minor=base"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" ["--minor=base"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out + assertOutputDoesNotContain "binary" out + ) - cabal' "outdated" ["--minor=base,template-haskell"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" ["--minor=base,template-haskell"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out + ) diff --git a/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs b/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs index 35756590ea8..40fed84b837 100644 --- a/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs +++ b/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs @@ -1,23 +1,27 @@ import Test.Cabal.Prelude + main = cabalTest $ withRepo "repo" $ do forM_ ["--v2-freeze-file", "--freeze-file"] $ \arg -> do - cabal' "outdated" [arg] >>= - (\out -> do - assertOutputContains "base" out - assertOutputContains "template-haskell" out - assertOutputContains "binary" out) + cabal' "outdated" [arg] + >>= ( \out -> do + assertOutputContains "base" out + assertOutputContains "template-haskell" out + assertOutputContains "binary" out + ) - cabal' "outdated" [arg, "--ignore=base,template-haskell,binary"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputDoesNotContain "template-haskell" out - assertOutputDoesNotContain "binary" out) + cabal' "outdated" [arg, "--ignore=base,template-haskell,binary"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out + assertOutputDoesNotContain "binary" out + ) - cabal' "outdated" [arg, "--minor=base,template-haskell,binary"] >>= - (\out -> do - assertOutputDoesNotContain "base" out - assertOutputContains "template-haskell" out - assertOutputContains "binary" out) + cabal' "outdated" [arg, "--minor=base,template-haskell,binary"] + >>= ( \out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out + assertOutputContains "binary" out + ) fails $ cabal' "outdated" ["--project-file=cabal.project.missing.freeze", "--v2-freeze-file"] return () diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs index 1618a08334a..9760bea2da3 100644 --- a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs +++ b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withPackageDb $ do - withDirectory "p" $ - setup_install [] + withPackageDb $ do + withDirectory "p" $ + setup_install [] - env <- getTestEnv - let pkgDbPath = testPackageDbDir env + env <- getTestEnv + let pkgDbPath = testPackageDbDir env - withDirectory "q" $ do - res <- fails $ cabal' "v2-build" ["--package-db=clear", "--package-db=" ++ pkgDbPath] - assertOutputContains "unknown package: base" res + withDirectory "q" $ do + res <- fails $ cabal' "v2-build" ["--package-db=clear", "--package-db=" ++ pkgDbPath] + assertOutputContains "unknown package: base" res diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs index 1ddcac2f8bb..8e499f4b133 100644 --- a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs +++ b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs @@ -1,9 +1,10 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withPackageDb $ do - withDirectory "p" $ - setup_install [] + withPackageDb $ do + withDirectory "p" $ + setup_install [] - withDirectory "q" $ do - res <- fails $ cabal' "v2-build" [] - assertOutputContains "unknown package: p" res + withDirectory "q" $ do + res <- fails $ cabal' "v2-build" [] + assertOutputContains "unknown package: p" res diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs index 1cc0f54d159..d00224da58b 100644 --- a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs +++ b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withPackageDb $ do - withDirectory "p-no-package-dbs" $ do - res <- fails $ cabal' "v2-build" [] - assertOutputContains "No package databases have been specified." res + withPackageDb $ do + withDirectory "p-no-package-dbs" $ do + res <- fails $ cabal' "v2-build" [] + assertOutputContains "No package databases have been specified." res diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs index 5b5b061d90e..5f995cc2291 100644 --- a/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs +++ b/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs @@ -1,12 +1,16 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withPackageDb $ do - withDirectory "p" $ - setup_install [] + withPackageDb $ do + withDirectory "p" $ + setup_install [] - env <- getTestEnv - let pkgDbPath = testPackageDbDir env - withDirectory "q" $ - cabal "v2-build" [ "--package-db=clear" - , "--package-db=global" - , "--package-db=" ++ pkgDbPath] + env <- getTestEnv + let pkgDbPath = testPackageDbDir env + withDirectory "q" $ + cabal + "v2-build" + [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ pkgDbPath + ] diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs index 64a74facaac..0456ae5396b 100644 --- a/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs +++ b/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.test.hs @@ -1,10 +1,11 @@ import Test.Cabal.Prelude + main = cabalTest $ do - withPackageDb $ do - withDirectory "p" $ - setup_install [] + withPackageDb $ do + withDirectory "p" $ + setup_install [] - env <- getTestEnv - let pkgDbPath = testPackageDbDir env - withDirectory "q" $ - cabal "v2-build" ["--package-db=" ++ pkgDbPath] + env <- getTestEnv + let pkgDbPath = testPackageDbDir env + withDirectory "q" $ + cabal "v2-build" ["--package-db=" ++ pkgDbPath] diff --git a/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs b/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs index 90c9d5f1204..e91e15ddee2 100644 --- a/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs +++ b/cabal-testsuite/PackageTests/PackageDB/p-no-package-dbs/P.hs @@ -1,2 +1,3 @@ module P where + p = True diff --git a/cabal-testsuite/PackageTests/PackageDB/p/P.hs b/cabal-testsuite/PackageTests/PackageDB/p/P.hs index 90c9d5f1204..e91e15ddee2 100644 --- a/cabal-testsuite/PackageTests/PackageDB/p/P.hs +++ b/cabal-testsuite/PackageTests/PackageDB/p/P.hs @@ -1,2 +1,3 @@ module P where + p = True diff --git a/cabal-testsuite/PackageTests/PackageDB/q/Main.hs b/cabal-testsuite/PackageTests/PackageDB/q/Main.hs index 370e8f7fd9c..d343fc5e6f5 100644 --- a/cabal-testsuite/PackageTests/PackageDB/q/Main.hs +++ b/cabal-testsuite/PackageTests/PackageDB/q/Main.hs @@ -1,3 +1,5 @@ module Main where + import P + main = print p diff --git a/cabal-testsuite/PackageTests/PackageInfoModule/Executable/setup.test.hs b/cabal-testsuite/PackageTests/PackageInfoModule/Executable/setup.test.hs index ac477fa7567..7ba6928aed9 100644 --- a/cabal-testsuite/PackageTests/PackageInfoModule/Executable/setup.test.hs +++ b/cabal-testsuite/PackageTests/PackageInfoModule/Executable/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for executables. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/PackageInfoModule/ImportQualifiedPost/setup.test.hs b/cabal-testsuite/PackageTests/PackageInfoModule/ImportQualifiedPost/setup.test.hs index ac477fa7567..7ba6928aed9 100644 --- a/cabal-testsuite/PackageTests/PackageInfoModule/ImportQualifiedPost/setup.test.hs +++ b/cabal-testsuite/PackageTests/PackageInfoModule/ImportQualifiedPost/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for executables. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/PackageInfoModule/Library/setup.test.hs b/cabal-testsuite/PackageTests/PackageInfoModule/Library/setup.test.hs index 7c55afb42ca..932523da712 100644 --- a/cabal-testsuite/PackageTests/PackageInfoModule/Library/setup.test.hs +++ b/cabal-testsuite/PackageTests/PackageInfoModule/Library/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for libraries. main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs index 5bd5d645c38..8822e2345f3 100644 --- a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs +++ b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs @@ -4,5 +4,5 @@ import Paths_PathsModule (getBinDir) main :: IO () main = do - _ <- getBinDir - return () + _ <- getBinDir + return () diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs index 76a4db87db3..15f570499f4 100644 --- a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs +++ b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and usable when relocatable is turned on. main = setupAndCabalTest $ do diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable/Main.hs b/cabal-testsuite/PackageTests/PathsModule/Executable/Main.hs index 5bd5d645c38..8822e2345f3 100644 --- a/cabal-testsuite/PackageTests/PathsModule/Executable/Main.hs +++ b/cabal-testsuite/PackageTests/PathsModule/Executable/Main.hs @@ -4,5 +4,5 @@ import Paths_PathsModule (getBinDir) main :: IO () main = do - _ <- getBinDir - return () + _ <- getBinDir + return () diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs index ac477fa7567..7ba6928aed9 100644 --- a/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs +++ b/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for executables. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/PathsModule/ImportQualifiedPost/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/ImportQualifiedPost/setup.test.hs index ac477fa7567..7ba6928aed9 100644 --- a/cabal-testsuite/PackageTests/PathsModule/ImportQualifiedPost/setup.test.hs +++ b/cabal-testsuite/PackageTests/PathsModule/ImportQualifiedPost/setup.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for executables. main = setupAndCabalTest $ setup_build [] - diff --git a/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs index 7c55afb42ca..932523da712 100644 --- a/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs +++ b/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for libraries. main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs index 7c55afb42ca..932523da712 100644 --- a/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs +++ b/cabal-testsuite/PackageTests/PathsModule/MissingSafeHaskellMode/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test that Paths module is generated and available for libraries. main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs b/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs index 20f5a9e13a4..20dcdaeb148 100644 --- a/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs +++ b/cabal-testsuite/PackageTests/PreProcess/Basic/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Check that preprocessors (hsc2hs) are run main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs index 3e380fc981d..07799fa9ff4 100644 --- a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs +++ b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Main where import Foo @@ -12,5 +13,5 @@ bar = 0 main :: IO () main = do - putStrLn $ "hsc2hs value: " ++ show foo - putStrLn $ "ghc value: " ++ show bar + putStrLn $ "hsc2hs value: " ++ show foo + putStrLn $ "ghc value: " ++ show bar diff --git a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs index 50cd5bcb0e2..9b149d9c0ce 100644 --- a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs +++ b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptions/setup.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- Check that preprocessors (hsc2hs) are run main = setupAndCabalTest $ do - setup_build [] - r <- runExe' "my-executable" [] - assertOutputContains "hsc2hs value: 42" r - assertOutputContains "ghc value: 0" r + setup_build [] + r <- runExe' "my-executable" [] + assertOutputContains "hsc2hs value: 42" r + assertOutputContains "ghc value: 0" r diff --git a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs index 06a191c3aa8..e40a5ca1dc8 100644 --- a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs +++ b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Main where import Foo diff --git a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs index 8dfca6d7d52..38fff633e76 100644 --- a/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs +++ b/cabal-testsuite/PackageTests/PreProcess/Hsc2HsOptionsCC/setup.test.hs @@ -1,28 +1,28 @@ -import Test.Cabal.Prelude -import Distribution.Pretty (prettyShow) import Data.Maybe (isJust) +import Distribution.Pretty (prettyShow) import System.Directory (findExecutable) +import Test.Cabal.Prelude -- Check that preprocessors (hsc2hs) are run main = setupAndCabalTest $ do - -- we need "g++" - hasGxx <- liftIO $ fmap isJust $ findExecutable "g++" - skipUnless "g++" hasGxx + -- we need "g++" + hasGxx <- liftIO $ fmap isJust $ findExecutable "g++" + skipUnless "g++" hasGxx - -- Figure out how recent GHC we need - -- https://github.com/msys2/MINGW-packages/issues/3531 - skipIfWindows + -- Figure out how recent GHC we need + -- https://github.com/msys2/MINGW-packages/issues/3531 + skipIfWindows - -- we need recent enough hsc2hs - -- hsc2hs commit 9671202c11f7fe98e5b96d379532b6f691dc46dd - -- Fix when using g++ as C compiler. Patch from elaforge. Fixes ghc #7232 - p <- requireProgramM hsc2hsProgram - case programVersion p of - Nothing -> skip "Unknown hsc2hs version" - Just v | v < mkVersion [0,68] -> skip $ "hsc2hs version: " ++ prettyShow v ++ " < 0.68" - _ -> return () + -- we need recent enough hsc2hs + -- hsc2hs commit 9671202c11f7fe98e5b96d379532b6f691dc46dd + -- Fix when using g++ as C compiler. Patch from elaforge. Fixes ghc #7232 + p <- requireProgramM hsc2hsProgram + case programVersion p of + Nothing -> skip "Unknown hsc2hs version" + Just v | v < mkVersion [0, 68] -> skip $ "hsc2hs version: " ++ prettyShow v ++ " < 0.68" + _ -> return () - -- Actual test - setup_build [] - r <- runExe' "my-executable" [] - assertOutputContains "Is not C, is C++" r + -- Actual test + setup_build [] + r <- runExe' "my-executable" [] + assertOutputContains "Is not C, is C++" r diff --git a/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs b/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs index af0769f9681..fd397c5ef55 100644 --- a/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs +++ b/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Check that preprocessors that generate extra C sources are handled main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal-testsuite/PackageTests/ProfLate/cabal.test.hs b/cabal-testsuite/PackageTests/ProfLate/cabal.test.hs index ce45a2ec7b4..cb7c1b0d845 100644 --- a/cabal-testsuite/PackageTests/ProfLate/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProfLate/cabal.test.hs @@ -1,9 +1,9 @@ import Test.Cabal.Prelude + -- Test building with profiling detail "late" main = do - cabalTest $ do - skipUnlessGhcVersion ">= 9.4" - cabal' "clean" [] - res <- cabal' "build" ["-v2", "profLate", "--enable-profiling", "--profiling-detail=late"] - assertOutputContains "-fprof-late" res - + cabalTest $ do + skipUnlessGhcVersion ">= 9.4" + cabal' "clean" [] + res <- cabal' "build" ["-v2", "profLate", "--enable-profiling", "--profiling-detail=late"] + assertOutputContains "-fprof-late" res diff --git a/cabal-testsuite/PackageTests/ProfLate/setup.test.hs b/cabal-testsuite/PackageTests/ProfLate/setup.test.hs index dff600e68c3..c91aa65659a 100644 --- a/cabal-testsuite/PackageTests/ProfLate/setup.test.hs +++ b/cabal-testsuite/PackageTests/ProfLate/setup.test.hs @@ -1,8 +1,9 @@ import Test.Cabal.Prelude + -- Test building with profiling detail "late" main = do - setupAndCabalTest $ do - skipUnless "no profiling libs" =<< hasProfiledLibraries - setup_build ["--enable-profiling", "--profiling-detail=late"] - -- ["--enable-profiling", "--profiling-detail=late-toplevel"] + setupAndCabalTest $ do + skipUnless "no profiling libs" =<< hasProfiledLibraries + setup_build ["--enable-profiling", "--profiling-detail=late"] +-- ["--enable-profiling", "--profiling-detail=late-toplevel"] diff --git a/cabal-testsuite/PackageTests/ProjectDir/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectDir/cabal.test.hs index 5ac2fe9cc6a..e5dcbe3d462 100644 --- a/cabal-testsuite/PackageTests/ProjectDir/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectDir/cabal.test.hs @@ -7,17 +7,17 @@ main = cabalTest $ recordMode DoNotRecord $ do let cwd = testCurrentDir env -- Relative directory - cabal "v2-build" [ "--project-dir=proj", "all" ] + cabal "v2-build" ["--project-dir=proj", "all"] -- Absolute directory - cabal "v2-build" [ "--project-dir", (cwd "proj"), "all" ] + cabal "v2-build" ["--project-dir", (cwd "proj"), "all"] - cabal "v2-clean" [ "--project-dir=proj" ] + cabal "v2-clean" ["--project-dir=proj"] withProjectFile "nix/cabal.project" $ do - cabal "v2-build" [ "--project-dir=proj", "extra" ] + cabal "v2-build" ["--project-dir=proj", "extra"] - cabal "v2-clean" [ "--project-dir=proj" ] + cabal "v2-clean" ["--project-dir=proj"] -- App with no cabal.project - void $ cabal_raw' [ "run", "--project-dir=app", "app" ] Nothing + void $ cabal_raw' ["run", "--project-dir=app", "app"] Nothing diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs index 7565ea2cab9..5b9f53ebc97 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Main where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs index 340f6dbd34c..d248948ef66 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Lib where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs index bd2fc6c4fc9..8f99258a471 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs @@ -3,4 +3,4 @@ module QQ where import Language.Haskell.TH import Language.Haskell.TH.Quote -myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} +myq = QuasiQuoter{quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs index 31309a46f0c..b927638bba9 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test building a dynamic library/executable which uses QuasiQuotes main = setupAndCabalTest $ do - skipUnless "no shared libs" =<< hasSharedLibraries - setup_build ["--enable-shared", "--enable-executable-dynamic"] + skipUnless "no shared libs" =<< hasSharedLibraries + setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs index 7565ea2cab9..5b9f53ebc97 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Main where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs index 340f6dbd34c..d248948ef66 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Lib where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs index bd2fc6c4fc9..8f99258a471 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs @@ -3,4 +3,4 @@ module QQ where import Language.Haskell.TH import Language.Haskell.TH.Quote -myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} +myq = QuasiQuoter{quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs index a3b24ad95ed..0fe151a88ce 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs @@ -1,7 +1,10 @@ import Test.Cabal.Prelude + -- Test building a profiled library/executable which uses QuasiQuotes -- (setup has to build the non-profiled version first) main = setupAndCabalTest $ do - skipUnless "no profiling libs" =<< hasProfiledLibraries - setup_build ["--enable-library-profiling", - "--enable-profiling"] + skipUnless "no profiling libs" =<< hasProfiledLibraries + setup_build + [ "--enable-library-profiling" + , "--enable-profiling" + ] diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs index 7565ea2cab9..5b9f53ebc97 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Main where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs index 340f6dbd34c..d248948ef66 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} + module Lib where import QQ diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs index bd2fc6c4fc9..8f99258a471 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs @@ -3,4 +3,4 @@ module QQ where import Language.Haskell.TH import Language.Haskell.TH.Quote -myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} +myq = QuasiQuoter{quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs index df61a665bca..5ff18108149 100644 --- a/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs +++ b/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test building a vanilla library/executable which uses QuasiQuotes main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/ReexportedModules/p/Private.hs b/cabal-testsuite/PackageTests/ReexportedModules/p/Private.hs index 055075bd9a0..d0d8644b541 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/p/Private.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/p/Private.hs @@ -1,2 +1,3 @@ module Private where + modname = "Private" diff --git a/cabal-testsuite/PackageTests/ReexportedModules/p/Public.hs b/cabal-testsuite/PackageTests/ReexportedModules/p/Public.hs index 97cfda0a0b8..40846ce2342 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/p/Public.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/p/Public.hs @@ -1,2 +1,3 @@ module Public where + modname = "Public" diff --git a/cabal-testsuite/PackageTests/ReexportedModules/q/A.hs b/cabal-testsuite/PackageTests/ReexportedModules/q/A.hs index d68dacafbb3..99502dbafe0 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/q/A.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/q/A.hs @@ -1,7 +1,8 @@ module A where -import DataMap + import Data.Graph -import Set import Data.Tree +import DataMap import Public import Republic +import Set diff --git a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs index 232ca3b1395..4be159687f6 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs @@ -1,9 +1,10 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 7.9" - withPackageDb $ do - withDirectory "containers-dupe" $ - setup_install [] - withDirectory "p" $ do - r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-ambiguous"] - assertOutputContains "Data.Map" r + skipUnlessGhcVersion ">= 7.9" + withPackageDb $ do + withDirectory "containers-dupe" $ + setup_install [] + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-ambiguous"] + assertOutputContains "Data.Map" r diff --git a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs index eb4d30f55e0..e43a32b01d1 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 7.9" - withDirectory "p" $ do - r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-missing"] - assertOutputContains "Missing" r + skipUnlessGhcVersion ">= 7.9" + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-missing"] + assertOutputContains "Missing" r diff --git a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs index 4c46fe76646..1b2d2562936 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 7.9" - withDirectory "p" $ do - r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-other"] - assertOutputContains "Private" r + skipUnlessGhcVersion ">= 7.9" + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-other"] + assertOutputContains "Private" r diff --git a/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs b/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs index c3ae77e43f6..05a9a18e63e 100644 --- a/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs +++ b/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + -- Test that reexported modules build correctly main = setupAndCabalTest $ do - skipUnlessGhcVersion ">= 7.9" - withPackageDb $ do - withDirectory "p" $ setup_install ["--cabal-file", "p.cabal"] - withDirectory "q" $ setup_build [] + skipUnlessGhcVersion ">= 7.9" + withPackageDb $ do + withDirectory "p" $ setup_install ["--cabal-file", "p.cabal"] + withDirectory "q" $ setup_build [] diff --git a/cabal-testsuite/PackageTests/Regression/HadrianT634/setup.test.hs b/cabal-testsuite/PackageTests/Regression/HadrianT634/setup.test.hs index 0cf02afb4c4..d72f2966c9c 100644 --- a/cabal-testsuite/PackageTests/Regression/HadrianT634/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/HadrianT634/setup.test.hs @@ -1,4 +1,7 @@ import Test.Cabal.Prelude import Test.Cabal.Script -main = setupTest $ - void $ setup'' "pkg" "configure" ["--cabal-file", "pkg/a.cabal"] + +main = + setupTest $ + void $ + setup'' "pkg" "configure" ["--cabal-file", "pkg/a.cabal"] diff --git a/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs b/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs +++ b/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs index 91d9a8a94d9..42b9a1cad06 100644 --- a/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - setup "configure" ["--enable-tests"] - setup "test" [] + setup "configure" ["--enable-tests"] + setup "test" [] diff --git a/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs index c32686accff..ccea93f58a4 100644 --- a/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs @@ -1,10 +1,11 @@ import Test.Cabal.Prelude + -- Test that we don't pick up include-dirs from libraries -- we didn't actually depend on. main = setupAndCabalTest $ do - withPackageDb $ do - withDirectory "p" $ setup_install [] - withDirectory "q" $ do - setup "configure" [] - assertOutputContains "T2971test.h" - =<< fails (setup' "build" []) + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ do + setup "configure" [] + assertOutputContains "T2971test.h" + =<< fails (setup' "build" []) diff --git a/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs index 6c1741b3da2..1b8f517cb03 100644 --- a/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test that we pick up include dirs from internal library main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs index 810a4202b3a..5bcc13a18bc 100644 --- a/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs @@ -1,14 +1,15 @@ -import Test.Cabal.Prelude import Control.Monad.IO.Class +import Test.Cabal.Prelude + -- Test that executable recompilation works -- https://github.com/haskell/setup/issues/3294 main = setupAndCabalTest $ do - withSourceCopy . withDelay $ do - writeSourceFile "Main.hs" "main = putStrLn \"aaa\"" - setup "configure" [] - setup "build" [] - runExe' "T3294" [] >>= assertOutputContains "aaa" - delay - writeSourceFile "Main.hs" "main = putStrLn \"bbb\"" - setup "build" [] - runExe' "T3294" [] >>= assertOutputContains "bbb" + withSourceCopy . withDelay $ do + writeSourceFile "Main.hs" "main = putStrLn \"aaa\"" + setup "configure" [] + setup "build" [] + runExe' "T3294" [] >>= assertOutputContains "aaa" + delay + writeSourceFile "Main.hs" "main = putStrLn \"bbb\"" + setup "build" [] + runExe' "T3294" [] >>= assertOutputContains "bbb" diff --git a/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs index 8fbe9cb352b..5c03a9171d7 100644 --- a/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test that other-extensions of disabled component do not -- effect configure step. main = setupAndCabalTest $ setup "configure" ["--disable-tests"] diff --git a/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs index 76f47038b95..fee96543739 100644 --- a/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs @@ -1,15 +1,16 @@ import Test.Cabal.Prelude + main = cabalTest $ - -- This repository contains a Cabal-1.18.0.0 option, which would - -- normally would satisfy the repository, except for v2-build's - -- extra constraint that setup Cabal must be 1.20. If we don't - -- have a choice like this available, the unsatisfied constraint - -- won't be reported. - -- - -- Due to #415, the lower bound may be even higher based on GHC - -- version - withRepo "repo" $ do - -- Don't record because output wobbles based on installed database. - recordMode DoNotRecord $ do - fails (cabal' "v2-build" []) >>= - assertOutputContains "Setup.hs requires >=" + -- This repository contains a Cabal-1.18.0.0 option, which would + -- normally would satisfy the repository, except for v2-build's + -- extra constraint that setup Cabal must be 1.20. If we don't + -- have a choice like this available, the unsatisfied constraint + -- won't be reported. + -- + -- Due to #415, the lower bound may be even higher based on GHC + -- version + withRepo "repo" $ do + -- Don't record because output wobbles based on installed database. + recordMode DoNotRecord $ do + fails (cabal' "v2-build" []) + >>= assertOutputContains "Setup.hs requires >=" diff --git a/cabal-testsuite/PackageTests/Regression/T4025/A.hs b/cabal-testsuite/PackageTests/Regression/T4025/A.hs index ecf2c1f4d7a..00c336301b6 100644 --- a/cabal-testsuite/PackageTests/Regression/T4025/A.hs +++ b/cabal-testsuite/PackageTests/Regression/T4025/A.hs @@ -1,4 +1,5 @@ module A where + {-# NOINLINE a #-} a :: Int a = 23 diff --git a/cabal-testsuite/PackageTests/Regression/T4025/exe/Main.hs b/cabal-testsuite/PackageTests/Regression/T4025/exe/Main.hs index f3fe84d228c..58b31f1c612 100644 --- a/cabal-testsuite/PackageTests/Regression/T4025/exe/Main.hs +++ b/cabal-testsuite/PackageTests/Regression/T4025/exe/Main.hs @@ -1,2 +1,3 @@ import A + main = print a diff --git a/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs index 0ec5d068147..ec0857893d1 100644 --- a/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- Test that we don't accidentally add the inplace directory to -- an executable RPATH. Don't test on Windows, which doesn't -- support RPATH. @@ -6,7 +7,8 @@ main = setupAndCabalTest $ do skipIfWindows osx <- isOSX ghc <- isGhcVersion ">= 8.10.7" - expectBrokenIf (osx && ghc) 7610 $ do -- see also issue #7988 + expectBrokenIf (osx && ghc) 7610 $ do + -- see also issue #7988 setup "configure" ["--enable-executable-dynamic"] setup "build" [] -- This should fail as it we should NOT be able to find the diff --git a/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs b/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs index c0621e5551c..37e9c1bbaa0 100644 --- a/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs @@ -12,7 +12,9 @@ main = cabalTest $ do -- Constraining all uses of 'time' fails because the installed 'time' -- doesn't fit the constraint. r <- fails $ cabal' "v2-build" ["time", "--constraint=any.time==99999", "--dry-run"] - assertRegex "Expected cabal to reject the setup dependency on the installed time" - ("rejecting: time:setup.time-[0-9.]*/installed-[^[:space:]]* " - ++ "\\(constraint from command line flag requires ==99999\\)") - r + assertRegex + "Expected cabal to reject the setup dependency on the installed time" + ( "rejecting: time:setup.time-[0-9.]*/installed-[^[:space:]]* " + ++ "\\(constraint from command line flag requires ==99999\\)" + ) + r diff --git a/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs index f7943be335f..8b173b96bc8 100644 --- a/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs @@ -1,12 +1,13 @@ import Test.Cabal.Prelude + main = cabalTest $ - withSourceCopy . withDelay $ do - writeSourceFile ("p/P.hs") "module P where\np = \"AAA\"" - cabal "v2-build" ["p","q"] - delay - writeSourceFile ("p/P.hs") "module P where\np = \"BBB\"" - cabal "v2-build" ["p"] - cabal "v2-build" ["q"] - withPlan $ - runPlanExe' "q" "qexe" [] - >>= assertOutputContains "BBB" + withSourceCopy . withDelay $ do + writeSourceFile ("p/P.hs") "module P where\np = \"AAA\"" + cabal "v2-build" ["p", "q"] + delay + writeSourceFile ("p/P.hs") "module P where\np = \"BBB\"" + cabal "v2-build" ["p"] + cabal "v2-build" ["q"] + withPlan $ + runPlanExe' "q" "qexe" [] + >>= assertOutputContains "BBB" diff --git a/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs b/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs index f63ccafefb3..696a1a37fce 100644 --- a/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs +++ b/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs @@ -1,2 +1,3 @@ import P + main = putStrLn p diff --git a/cabal-testsuite/PackageTests/Regression/T4270/Test.hs b/cabal-testsuite/PackageTests/Regression/T4270/Test.hs index 24dbc04dca3..a95fb329203 100644 --- a/cabal-testsuite/PackageTests/Regression/T4270/Test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4270/Test.hs @@ -7,7 +7,8 @@ import Distribution.TestSuite tests :: IO [Test] tests = return [Test bar] where - bar = TestInstance + bar = + TestInstance { run = return $ Finished run , name = "test" , tags = [] diff --git a/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs index cf3d7afbdfb..0549431bcbc 100644 --- a/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs @@ -1,10 +1,11 @@ import Test.Cabal.Prelude + -- Test if detailed-0.9 builds correctly and runs -- when linked dynamically -- See https://github.com/haskell/cabal/issues/4270 main = setupAndCabalTest $ do - skipUnless "no shared libs" =<< hasSharedLibraries - skipUnless "no shared Cabal" =<< hasCabalShared + skipUnless "no shared libs" =<< hasSharedLibraries + skipUnless "no shared Cabal" =<< hasCabalShared skipUnless "no Cabal for GHC" =<< hasCabalForGhc ghc <- isGhcVersion "== 8.0.2" osx <- isOSX diff --git a/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs index a6eb9844785..79aa9c1372a 100644 --- a/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4291/setup.test.hs @@ -10,7 +10,8 @@ main = setupAndCabalTest $ withPackageDb $ do let pkgroot = takeDirectory $ testPackageDbDir env prefix = testTmpDir env "prefix" assertBool "we need a prefix that is not under pkgroot for this test" $ - not $ pkgroot `isPrefixOf` prefix + not $ + pkgroot `isPrefixOf` prefix withDirectory "dependee" $ setup_install ["--enable-relocatable", "--prefix", prefix] withDirectory "depender" $ diff --git a/cabal-testsuite/PackageTests/Regression/T4449/Setup.hs b/cabal-testsuite/PackageTests/Regression/T4449/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-testsuite/PackageTests/Regression/T4449/Setup.hs +++ b/cabal-testsuite/PackageTests/Regression/T4449/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs index 835ade35fb6..650fb76450e 100644 --- a/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4449/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = cabalTest $ do - skipUnlessGhcVersion ">= 7.10" - setup "configure" [] - setup "build" [] + skipUnlessGhcVersion ">= 7.10" + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/Regression/T4720/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T4720/cabal.test.hs index 97581a452d2..48a434fe477 100644 --- a/cabal-testsuite/PackageTests/Regression/T4720/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4720/cabal.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + main = cabalTest $ do - cabal "v2-build" ["test"] + cabal "v2-build" ["test"] diff --git a/cabal-testsuite/PackageTests/Regression/T4986/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T4986/cabal.test.hs index 8f7fe8fdfa1..ef8d6b428b9 100644 --- a/cabal-testsuite/PackageTests/Regression/T4986/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T4986/cabal.test.hs @@ -1,4 +1,6 @@ import Test.Cabal.Prelude -main = cabalTest $ + +main = + cabalTest $ withSourceCopy $ - cabal "v2-configure" [] + cabal "v2-configure" [] diff --git a/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs index 2455a187eb8..06adeb8a1d5 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5213/cabal.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = cabalTest $ cabal "new-test" [] diff --git a/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs index 2455a187eb8..06adeb8a1d5 100644 --- a/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5213ExeCoverage/cabal.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = cabalTest $ cabal "new-test" [] diff --git a/cabal-testsuite/PackageTests/Regression/T5309/app/Main.hs b/cabal-testsuite/PackageTests/Regression/T5309/app/Main.hs index 076ddb8062d..e2bdc68d370 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/app/Main.hs +++ b/cabal-testsuite/PackageTests/Regression/T5309/app/Main.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.TCM.Memoized - main :: IO () main = generateMemoizedTransitionCostMatrix 5 (const (const 1)) `seq` return () diff --git a/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs index a81a75197f3..11902370886 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] - cabal "v2-test" ["all"] + cabal "v2-test" ["all"] cabal "v2-bench" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T5309/lib/Bio/Character/Exportable/Class.hs b/cabal-testsuite/PackageTests/Regression/T5309/lib/Bio/Character/Exportable/Class.hs index bb3271ae035..dc6c9b3441f 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/lib/Bio/Character/Exportable/Class.hs +++ b/cabal-testsuite/PackageTests/Regression/T5309/lib/Bio/Character/Exportable/Class.hs @@ -1,4 +1,16 @@ ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE FunctionalDependencies #-} +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} + -- | -- Module : Bio.Character.Exportable.Class -- Copyright : (c) 2015-2015 Ward Wheeler @@ -9,48 +21,37 @@ -- Portability : portable -- -- Class for needed operations of coded sequences and characters --- --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-} - module Bio.Character.Exportable.Class where - import Foreign.C.Types - -- | -- Represents a sequence of fixed width characters packed into a bitwise form -- consumable by lower level functions. class Exportable c where + toExportableBuffer :: c -> ExportableCharacterSequence + fromExportableBuffer :: ExportableCharacterSequence -> c - toExportableBuffer :: c -> ExportableCharacterSequence - fromExportableBuffer :: ExportableCharacterSequence -> c - - toExportableElements :: c -> Maybe ExportableCharacterElements - fromExportableElements :: ExportableCharacterElements -> c - + toExportableElements :: c -> Maybe ExportableCharacterElements + fromExportableElements :: ExportableCharacterElements -> c -- | -- A structure used for FFI calls. -- -- 'bufferChunks' contains the bit-packed representation of the character sequence. -data ExportableCharacterSequence - = ExportableCharacterSequence - { exportedElementCountSequence :: Int - , exportedElementWidthSequence :: Int - , exportedBufferChunks :: [CULong] - } deriving (Eq, Show) - +data ExportableCharacterSequence = ExportableCharacterSequence + { exportedElementCountSequence :: Int + , exportedElementWidthSequence :: Int + , exportedBufferChunks :: [CULong] + } + deriving (Eq, Show) -- | -- A structure used for FFI calls-- -- 'characterElements' contains the integral value for each character element. -data ExportableCharacterElements - = ExportableCharacterElements - { exportedElementCountElements :: Int - , exportedElementWidthElements :: Int - , exportedCharacterElements :: [CUInt] - } deriving (Eq, Show) +data ExportableCharacterElements = ExportableCharacterElements + { exportedElementCountElements :: Int + , exportedElementWidthElements :: Int + , exportedCharacterElements :: [CUInt] + } + deriving (Eq, Show) diff --git a/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized.hs b/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized.hs index fbe69a52dfe..6c646e241ab 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized.hs +++ b/cabal-testsuite/PackageTests/Regression/T5309/lib/Data/TCM/Memoized.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Data.TCM.Memoized -- Copyright : (c) 2015-2015 Ward Wheeler @@ -7,9 +10,6 @@ -- Maintainer : wheeler@amnh.org -- Stability : provisional -- Portability : portable --- ------------------------------------------------------------------------------ - module Data.TCM.Memoized ( FFI.MemoizedCostMatrix , generateMemoizedTransitionCostMatrix @@ -18,7 +18,6 @@ module Data.TCM.Memoized import qualified Data.TCM.Memoized.FFI as FFI - -- | -- /O(n^2)/ where @n@ is the alphabet size. -- @@ -33,8 +32,10 @@ import qualified Data.TCM.Memoized.FFI as FFI -- the collection of unambiguous, singleton symbol sets. The lazy, memoization is -- a requisite for efficient computation on any non-trivial alphabet size. generateMemoizedTransitionCostMatrix - :: Word -- ^ Alphabet size - -> (Word -> Word -> Word) -- ^ Generating function + :: Word + -- ^ Alphabet size + -> (Word -> Word -> Word) + -- ^ Generating function -> FFI.MemoizedCostMatrix generateMemoizedTransitionCostMatrix = FFI.getMemoizedCostMatrix diff --git a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs index 6fd409c2704..71dc0d2e250 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v1-install" [] + +main = + cabalTest $ + cabal "v1-install" [] diff --git a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs index f5d95cc9eaf..b8a0c80d62e 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv let fn = tmpdir "empty-data-dir-0.list" diff --git a/cabal-testsuite/PackageTests/Regression/T5386/Foo.hs b/cabal-testsuite/PackageTests/Regression/T5386/Foo.hs index d46fb533a4a..8a5f9cf2013 100644 --- a/cabal-testsuite/PackageTests/Regression/T5386/Foo.hs +++ b/cabal-testsuite/PackageTests/Regression/T5386/Foo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Foo where foo = FOO diff --git a/cabal-testsuite/PackageTests/Regression/T5386/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5386/cabal.test.hs index 565a3ce3474..bd839026053 100644 --- a/cabal-testsuite/PackageTests/Regression/T5386/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5386/cabal.test.hs @@ -1,5 +1,8 @@ import Test.Cabal.Prelude + -- See #4332, dep solving output is not deterministic -main = cabalTest . recordMode DoNotRecord $ withSourceCopyDir "9" $ - -- Note: we bundle the configure script so no need to autoreconf while building - cabal "v2-build" ["all"] +main = + cabalTest . recordMode DoNotRecord $ + withSourceCopyDir "9" $ + -- Note: we bundle the configure script so no need to autoreconf while building + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T5409/Main.hs b/cabal-testsuite/PackageTests/Regression/T5409/Main.hs index a94baedbb4a..4a79a797b1e 100644 --- a/cabal-testsuite/PackageTests/Regression/T5409/Main.hs +++ b/cabal-testsuite/PackageTests/Regression/T5409/Main.hs @@ -8,4 +8,4 @@ main = do buildToolExeVersion :: Int buildToolExeVersion = - BUILD_TOOL_VERSION + BUILD_TOOL_VERSION diff --git a/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-1/main/Main.hs b/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-1/main/Main.hs index b7756ae3365..b02a6e58660 100644 --- a/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-1/main/Main.hs +++ b/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-1/main/Main.hs @@ -4,8 +4,8 @@ import BuildToolLibrary (buildToolLibraryVersion) import System.Environment main = do - (_:source:target:_) <- getArgs + (_ : source : target : _) <- getArgs writeFile target . unlines . map replaceVersion . lines =<< readFile source replaceVersion " BUILD_TOOL_VERSION" = " " ++ show buildToolLibraryVersion -replaceVersion line = line +replaceVersion line = line diff --git a/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-2/main/Main.hs b/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-2/main/Main.hs index b7756ae3365..b02a6e58660 100644 --- a/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-2/main/Main.hs +++ b/cabal-testsuite/PackageTests/Regression/T5409/repo/build-tool-pkg-2/main/Main.hs @@ -4,8 +4,8 @@ import BuildToolLibrary (buildToolLibraryVersion) import System.Environment main = do - (_:source:target:_) <- getArgs + (_ : source : target : _) <- getArgs writeFile target . unlines . map replaceVersion . lines =<< readFile source replaceVersion " BUILD_TOOL_VERSION" = " " ++ show buildToolLibraryVersion -replaceVersion line = line +replaceVersion line = line diff --git a/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs b/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs index 13215e65c6d..3336571f844 100644 --- a/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5409/use-different-versions-of-dependency-for-library-and-build-tool.test.hs @@ -14,10 +14,12 @@ main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do skipUnless "not v2-build compatible boot Cabal" =<< hasNewBuildCompatBootCabal withRepo "repo" $ do - r1 <- recordMode DoNotRecord $ - cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["pkg:my-exe"] + r1 <- + recordMode DoNotRecord $ + cabalG' ["--store-dir=" ++ storeDir] "v2-build" ["pkg:my-exe"] - let msg = concat + let msg = + concat [ "In order, the following will be built:" , " - build-tool-pkg-1 (lib) (requires build)" , " - build-tool-pkg-2 (lib) (requires build)" @@ -29,4 +31,5 @@ main = withShorterPathForNewBuildStore $ \storeDir -> withPlan $ do r2 <- runPlanExe' "pkg" "my-exe" [] assertOutputContains - "build-tool library version: 1, build-tool exe version: 2" r2 + "build-tool library version: 1, build-tool exe version: 2" + r2 diff --git a/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs index 27edba49486..22248c57066 100644 --- a/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do -- -Wmissing-export-lists is new in 8.4. skipUnlessGhcVersion ">= 8.3" diff --git a/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs index 410a0eba1f1..1dd943e873e 100644 --- a/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs @@ -20,26 +20,27 @@ -- as failed compilation or wrong exe output, which I do check. import Test.Cabal.Prelude + main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ withSourceCopy . withDelay $ do - writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"AAA\"" - recordMode DoNotRecord $ - cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] - withPlan $ - runPlanExe' "issue5782" "E" [] - >>= assertOutputContains "AAA" - delay - writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"BBB\"" - recordMode DoNotRecord $ - cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] - withPlan $ - runPlanExe' "issue5782" "E" [] - >>= assertOutputContains "BBB" - writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"CCC\"" - delay -- different spot to try another scenario - recordMode DoNotRecord $ - cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] - withPlan $ - runPlanExe' "issue5782" "E" [] - >>= assertOutputContains "CCC" + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"AAA\"" + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "AAA" + delay + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"BBB\"" + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "BBB" + writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"CCC\"" + delay -- different spot to try another scenario + recordMode DoNotRecord $ + cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"] + withPlan $ + runPlanExe' "issue5782" "E" [] + >>= assertOutputContains "CCC" diff --git a/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs index aeb2587e70c..0d879ca864f 100644 --- a/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - withPackageDb $ do - setup "configure" [] - setup "build" ["myprog"] - setup "copy" ["myprog"] + withPackageDb $ do + setup "configure" [] + setup "build" ["myprog"] + setup "copy" ["myprog"] diff --git a/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs index 1adfcadf453..8a3a90cf650 100644 --- a/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v2-build" ["all"] + +main = + cabalTest $ + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T6853/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6853/cabal.test.hs index 1adfcadf453..8a3a90cf650 100644 --- a/cabal-testsuite/PackageTests/Regression/T6853/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6853/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v2-build" ["all"] + +main = + cabalTest $ + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs index 233f4a2a3d1..db0b6489656 100644 --- a/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6906/cabal.test.hs @@ -1,12 +1,12 @@ import Test.Cabal.Prelude main = cabalTest $ do - win <- isWindows - ghcsWithMaxPathIssue <- isGhcVersion "< 8.6.5" - expectBrokenIf (win && ghcsWithMaxPathIssue) 6271 $ do - res <- recordMode DoNotRecord $ cabalG' ["--config=cabal.config"] "v2-install" ["-v3"] - assertOutputContains "creating file with the inputs used to compute the package hash:" res - assertOutputContains "extra-lib-dirs: bar" res - assertOutputDoesNotContain "extra-lib-dirs: bar bar" res - assertOutputContains "extra-include-dirs: foo" res - assertOutputDoesNotContain "extra-include-dirs: foo foo" res + win <- isWindows + ghcsWithMaxPathIssue <- isGhcVersion "< 8.6.5" + expectBrokenIf (win && ghcsWithMaxPathIssue) 6271 $ do + res <- recordMode DoNotRecord $ cabalG' ["--config=cabal.config"] "v2-install" ["-v3"] + assertOutputContains "creating file with the inputs used to compute the package hash:" res + assertOutputContains "extra-lib-dirs: bar" res + assertOutputDoesNotContain "extra-lib-dirs: bar bar" res + assertOutputContains "extra-include-dirs: foo" res + assertOutputDoesNotContain "extra-include-dirs: foo foo" res diff --git a/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs index 915337859f5..6b0077cd6c1 100644 --- a/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6961/DepExternal/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v2-build" ["all", "--dry-run", "--enable-tests"] + +main = + cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs index 6b4ad601b07..ffde5be6280 100644 --- a/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6961/DepInternal/cabal.test.hs @@ -1,5 +1,8 @@ import Test.Cabal.Prelude -main = cabalTest $ - -- we try to depend on private component from outside, - -- so this should fail. - fails $ cabal "v2-build" ["all", "--dry-run", "--enable-tests"] + +main = + cabalTest $ + -- we try to depend on private component from outside, + -- so this should fail. + fails $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs index 915337859f5..6b0077cd6c1 100644 --- a/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6961/Exe/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v2-build" ["all", "--dry-run", "--enable-tests"] + +main = + cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs index 915337859f5..6b0077cd6c1 100644 --- a/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T6961/Test/cabal.test.hs @@ -1,3 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ - cabal "v2-build" ["all", "--dry-run", "--enable-tests"] + +main = + cabalTest $ + cabal "v2-build" ["all", "--dry-run", "--enable-tests"] diff --git a/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs index 6a83874e866..5ed5e00cfee 100644 --- a/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T7234/Fail/cabal.test.hs @@ -1,5 +1,8 @@ import Test.Cabal.Prelude -main = cabalTest $ - -- this should fail, - -- none of GHC have extension declared in other-extensions - fails $ cabal "v2-build" ["all"] + +main = + cabalTest $ + -- this should fail, + -- none of GHC have extension declared in other-extensions + fails $ + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs index caaeb22728d..0032276763b 100644 --- a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.test.hs @@ -1,4 +1,6 @@ import Test.Cabal.Prelude -main = cabalTest $ - -- this should not fail, just warn. - cabal "v2-build" ["all"] + +main = + cabalTest $ + -- this should not fail, just warn. + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/Regression/T8507/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T8507/cabal.test.hs index 58266256b47..793d15ecd04 100644 --- a/cabal-testsuite/PackageTests/Regression/T8507/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T8507/cabal.test.hs @@ -3,4 +3,3 @@ import Test.Cabal.Prelude -- Issue #8507: trailing space in `default-language` should not make -- `cabal build` complain. main = cabalTest $ cabal "v2-build" ["all"] - diff --git a/cabal-testsuite/PackageTests/ReplBuildDepends/cabal.test.hs b/cabal-testsuite/PackageTests/ReplBuildDepends/cabal.test.hs index e5b63af3dae..d9429bd7063 100644 --- a/cabal-testsuite/PackageTests/ReplBuildDepends/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ReplBuildDepends/cabal.test.hs @@ -8,12 +8,13 @@ main = do -- See https://github.com/haskell/cabal/issues/6859 testWithByteString "allow-older" ["--allow-older"] where - testWithByteString label extraArgs = cabalTest' label $ do - cabal' "clean" [] - res <- cabalWithStdin - "repl" - ("-v2" : "--build-depends" : "bytestring" : extraArgs) - "import qualified Data.ByteString as BS" - assertOutputContains "Ok, one module loaded." res - -- Ensure we can load ‘bytestring’ - assertOutputDoesNotContain "Could not load" res + testWithByteString label extraArgs = cabalTest' label $ do + cabal' "clean" [] + res <- + cabalWithStdin + "repl" + ("-v2" : "--build-depends" : "bytestring" : extraArgs) + "import qualified Data.ByteString as BS" + assertOutputContains "Ok, one module loaded." res + -- Ensure we can load ‘bytestring’ + assertOutputDoesNotContain "Could not load" res diff --git a/cabal-testsuite/PackageTests/ReplCSources/cabal.test.hs b/cabal-testsuite/PackageTests/ReplCSources/cabal.test.hs index ca7502d5a04..bb928163a26 100644 --- a/cabal-testsuite/PackageTests/ReplCSources/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ReplCSources/cabal.test.hs @@ -1,9 +1,9 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal' "clean" [] - res <- cabalWithStdin "repl" ["-v2"] "foo" - -- Make sure we don't get this ghci error - -- *Lib> ghc: ^^ Could not load '_foo', dependency unresolved. See top entry above. - assertOutputDoesNotContain "Could not load" res - assertOutputContains "Building C Sources..." res + cabal' "clean" [] + res <- cabalWithStdin "repl" ["-v2"] "foo" + -- Make sure we don't get this ghci error + -- \*Lib> ghc: ^^ Could not load '_foo', dependency unresolved. See top entry above. + assertOutputDoesNotContain "Could not load" res + assertOutputContains "Building C Sources..." res diff --git a/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs b/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs index 6c72166ed5f..3a1b1183279 100644 --- a/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs @@ -26,13 +26,15 @@ main = do assertOutputContains "did you mean one of:" res cabalTest' "multiple-repl-options-multiple-flags" $ do cabal' "clean" [] - res <- cabalWithStdin "v2-repl" [ - "--repl-options=-fforce-recomp -fwrite-interface", - "--repl-options=-fdefer-type-errors -fdefer-typed-holes" - ] ":set" + res <- + cabalWithStdin + "v2-repl" + [ "--repl-options=-fforce-recomp -fwrite-interface" + , "--repl-options=-fdefer-type-errors -fdefer-typed-holes" + ] + ":set" assertOutputContains "Ok, two modules loaded." res assertOutputContains " -fwrite-interface" res assertOutputContains " -fforce-recomp" res assertOutputContains " -fdefer-typed-holes" res assertOutputContains " -fdefer-type-errors" res - diff --git a/cabal-testsuite/PackageTests/RequireExplicit/FlagInProject/cabal.test.hs b/cabal-testsuite/PackageTests/RequireExplicit/FlagInProject/cabal.test.hs index 4a75ff3bc44..6f9ec8b7c61 100644 --- a/cabal-testsuite/PackageTests/RequireExplicit/FlagInProject/cabal.test.hs +++ b/cabal-testsuite/PackageTests/RequireExplicit/FlagInProject/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- See #4332, dep solving output is not deterministic main = cabalTest . recordMode DoNotRecord $ withRepo "../repo" $ do -- other-lib is a dependency, but it's not listed in cabal.project diff --git a/cabal-testsuite/PackageTests/RequireExplicit/MultiPkg/cabal.test.hs b/cabal-testsuite/PackageTests/RequireExplicit/MultiPkg/cabal.test.hs index 487a4a400a2..45a0965f5f9 100644 --- a/cabal-testsuite/PackageTests/RequireExplicit/MultiPkg/cabal.test.hs +++ b/cabal-testsuite/PackageTests/RequireExplicit/MultiPkg/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + -- See #4332, dep solving output is not deterministic main = cabalTest . recordMode DoNotRecord $ withRepo "../repo" $ do -- other-lib is a dependency of b, but it's not listed in cabal.project diff --git a/cabal-testsuite/PackageTests/RtsOptsClean/setup.test.hs b/cabal-testsuite/PackageTests/RtsOptsClean/setup.test.hs index 7c85bd662b3..b3db02ac8bd 100644 --- a/cabal-testsuite/PackageTests/RtsOptsClean/setup.test.hs +++ b/cabal-testsuite/PackageTests/RtsOptsClean/setup.test.hs @@ -2,5 +2,5 @@ import Test.Cabal.Prelude -- Test that setup shows all the 'autogen-modules' warnings. main = setupAndCabalTest $ do - setup' "configure" [] >>= - assertOutputDoesNotContain "Warning: Instead of 'ghc-options: -I0' use 'include-dirs: 0'" + setup' "configure" [] + >>= assertOutputDoesNotContain "Warning: Instead of 'ghc-options: -I0' use 'include-dirs: 0'" diff --git a/cabal-testsuite/PackageTests/SDist/ListSources/list-sources.test.hs b/cabal-testsuite/PackageTests/SDist/ListSources/list-sources.test.hs index c3cf82c2b1b..28fbe09032c 100644 --- a/cabal-testsuite/PackageTests/SDist/ListSources/list-sources.test.hs +++ b/cabal-testsuite/PackageTests/SDist/ListSources/list-sources.test.hs @@ -1,5 +1,6 @@ import System.FilePath (normalise) import Test.Cabal.Prelude + main = setupTest $ do tmpdir <- fmap testTmpDir getTestEnv let fn = tmpdir "sources" diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs index c0ff953560b..120c470ce56 100644 --- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv res <- fails $ cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir] diff --git a/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs index 2fa53d6a63a..b82008229be 100644 --- a/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SDist/T7028/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir, "t7028"] diff --git a/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs index 87598963710..8690dca9960 100644 --- a/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SDist/T7698/cabal.test.hs @@ -1,4 +1,5 @@ import Test.Cabal.Prelude + main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv cabal "v2-sdist" ["--list-only", "--output-directory", tmpdir, "all"] diff --git a/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs b/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs index f88f6249197..675daebf45a 100644 --- a/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs +++ b/cabal-testsuite/PackageTests/SPDX/cabal-old-build.test.hs @@ -1,7 +1,8 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ withPackageDb $ do - setup_install [] - recordMode DoNotRecord $ do - ghc84 <- isGhcVersion ">= 8.4" - let lic = if ghc84 then "BSD-3-Clause" else "BSD3" - ghcPkg' "field" ["my", "license"] >>= assertOutputContains lic + setup_install [] + recordMode DoNotRecord $ do + ghc84 <- isGhcVersion ">= 8.4" + let lic = if ghc84 then "BSD-3-Clause" else "BSD3" + ghcPkg' "field" ["my", "license"] >>= assertOutputContains lic diff --git a/cabal-testsuite/PackageTests/SPDX/cabal.test.hs b/cabal-testsuite/PackageTests/SPDX/cabal.test.hs index a714b5910ae..387771903db 100644 --- a/cabal-testsuite/PackageTests/SPDX/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SPDX/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - recordMode DoNotRecord $ do - -- TODO: Hack; see also CustomDep/cabal.test.hs - withEnvFilter (/= "HOME") $ do - cabal "v2-build" ["all"] + recordMode DoNotRecord $ do + -- TODO: Hack; see also CustomDep/cabal.test.hs + withEnvFilter (/= "HOME") $ do + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs index 8fdc04e7a2a..282939238e6 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs @@ -1,27 +1,36 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo + +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Prelude main = cabalTest $ do runShowBuildInfo ["all", "--enable-tests"] withPlan $ do - assertComponent "A" (exe "A") + assertComponent + "A" + (exe "A") defCompAssertion { sourceFiles = ["Main.hs"] , sourceDirs = ["src"] } - assertComponent "A" mainLib + assertComponent + "A" + mainLib defCompAssertion { modules = ["A"] , sourceDirs = ["src"] } - assertComponent "B" mainLib + assertComponent + "B" + mainLib defCompAssertion { modules = ["B"] , sourceDirs = ["lib"] } - assertComponent "A" (test "A-tests") + assertComponent + "A" + (test "A-tests") defCompAssertion { sourceFiles = ["Test.hs"] , sourceDirs = ["src"] diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs index a27bf2d8167..a1b3f7a663b 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe.test.hs @@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo + +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Prelude main = cabalTest $ do runShowBuildInfo ["exe:A"] withPlan $ do - assertComponent "A" (exe "A") + assertComponent + "A" + (exe "A") defCompAssertion - { sourceFiles = ["Main.hs"] - , sourceDirs = ["src"] - -- does not list lib as a target - , compilerArgsPred = all (/= "A-0.1.0.0-inplace") - } + { sourceFiles = ["Main.hs"] + , sourceDirs = ["src"] + , -- does not list lib as a target + compilerArgsPred = all (/= "A-0.1.0.0-inplace") + } diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs index f2f0c4302fc..6cf6c24982a 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/remove-outdated.test.hs @@ -1,19 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo -import Test.Cabal.Plan -import Control.Monad.Trans.Reader + +import Control.Monad.Trans.Reader +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Plan +import Test.Cabal.Prelude main = cabalTest $ do runShowBuildInfo ["exe:A"] withPlan $ do - assertComponent "A" (exe "A") + assertComponent + "A" + (exe "A") defCompAssertion - { sourceFiles = ["Main.hs"] - , sourceDirs = ["src"] - -- does not list lib as a target - , compilerArgsPred = all (/= "A-0.1.0.0-inplace") - } + { sourceFiles = ["Main.hs"] + , sourceDirs = ["src"] + , -- does not list lib as a target + compilerArgsPred = all (/= "A-0.1.0.0-inplace") + } cabal' "v2-build" ["exe:A", "--disable-build-info"] withPlan $ do diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs index fc1fba234d5..fb3d53d12f0 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/compile-fail.test.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo -import Test.Cabal.Plan -import Control.Monad.Trans.Reader + +import Control.Monad.Trans.Reader +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Plan +import Test.Cabal.Prelude main = cabalTest $ do -- Leaf component fails to compile, should still dump @@ -10,14 +11,18 @@ main = cabalTest $ do fails $ runShowBuildInfo ["test:CompileFail-test"] withPlan $ do -- Lib has to be built, thus info is dumped - assertComponent "CompileFail" mainLib + assertComponent + "CompileFail" + mainLib defCompAssertion { modules = ["MyLib"] , sourceDirs = ["src"] } -- Build Info is still dumped, although compilation failed - assertComponent "CompileFail" (test "CompileFail-test") + assertComponent + "CompileFail" + (test "CompileFail-test") defCompAssertion { sourceFiles = ["Main.hs"] , sourceDirs = ["test"] @@ -26,7 +31,9 @@ main = cabalTest $ do fails $ runShowBuildInfo ["exe:CompileFail-exe"] withPlan $ do -- Internal Lib has to be built, thus info is dumped - assertComponent "CompileFail" (lib "failing") + assertComponent + "CompileFail" + (lib "failing") defCompAssertion { modules = ["MyLib2"] , sourceDirs = ["src"] diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs index 9b620c62fcd..5995be111e6 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/src/MyLib2.hs @@ -3,4 +3,5 @@ module MyLib2 (someFunc2) where someFunc2 :: IO () -- Intentional typo, should fail to compile someFunc2 = putStrn "someFunc" + -- ^^------- missing 'L' diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs index bae4112fa97..99070ac7f43 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/CompileFail/test/Main.hs @@ -3,4 +3,5 @@ module Main (main) where main :: IO () -- Intentional typo, should fail to compile main = putStrn "Test suite not yet implemented." + -- ^^------- missing 'L' diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs index b4bdc16f0cd..11e58623854 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/single.test.hs @@ -1,44 +1,75 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo + +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Prelude main = cabalTest $ do -- the With GHC-9.2+ output contains -this-unit-id skipUnlessGhcVersion ">= 9.2" withRepo "repo" $ do - runShowBuildInfo ["exe:Complex"] >> withPlan (do - recordBuildInfo "Complex" (exe "Complex") - assertComponent "Complex" (exe "Complex") defCompAssertion - { modules = ["Other", "Paths_Complex"] - , sourceFiles = ["Main.lhs"] - , sourceDirs = ["app"] - }) + runShowBuildInfo ["exe:Complex"] + >> withPlan + ( do + recordBuildInfo "Complex" (exe "Complex") + assertComponent + "Complex" + (exe "Complex") + defCompAssertion + { modules = ["Other", "Paths_Complex"] + , sourceFiles = ["Main.lhs"] + , sourceDirs = ["app"] + } + ) - runShowBuildInfo ["lib:Complex"] >> withPlan (do - recordBuildInfo "Complex" mainLib - assertComponent "Complex" mainLib defCompAssertion - { modules = ["A", "B", "C", "D", "Paths_Complex"] - , sourceDirs = ["src", "doesnt-exist"] - }) + runShowBuildInfo ["lib:Complex"] + >> withPlan + ( do + recordBuildInfo "Complex" mainLib + assertComponent + "Complex" + mainLib + defCompAssertion + { modules = ["A", "B", "C", "D", "Paths_Complex"] + , sourceDirs = ["src", "doesnt-exist"] + } + ) - runShowBuildInfo ["benchmark:complex-benchmarks"] >> withPlan (do - recordBuildInfo "Complex" (bench "complex-benchmarks") - assertComponent "Complex" (bench "complex-benchmarks") defCompAssertion - { modules = ["Paths_Complex"] - , sourceFiles = ["Main.hs"] - , sourceDirs = ["benchmark"] - }) + runShowBuildInfo ["benchmark:complex-benchmarks"] + >> withPlan + ( do + recordBuildInfo "Complex" (bench "complex-benchmarks") + assertComponent + "Complex" + (bench "complex-benchmarks") + defCompAssertion + { modules = ["Paths_Complex"] + , sourceFiles = ["Main.hs"] + , sourceDirs = ["benchmark"] + } + ) - runShowBuildInfo ["test:func-test"] >> withPlan (do - recordBuildInfo "Complex" (test "func-test") - assertComponent "Complex" (test "func-test") defCompAssertion - { sourceFiles = ["FuncMain.hs"] - , sourceDirs = ["test"] - }) + runShowBuildInfo ["test:func-test"] + >> withPlan + ( do + recordBuildInfo "Complex" (test "func-test") + assertComponent + "Complex" + (test "func-test") + defCompAssertion + { sourceFiles = ["FuncMain.hs"] + , sourceDirs = ["test"] + } + ) - runShowBuildInfo ["test:unit-test"] >> withPlan (do - recordBuildInfo "Complex" (test "unit-test") - assertComponent "Complex" (test "unit-test") defCompAssertion - { sourceFiles = ["UnitMain.hs"] - , sourceDirs = ["test"] - }) + runShowBuildInfo ["test:unit-test"] + >> withPlan + ( do + recordBuildInfo "Complex" (test "unit-test") + assertComponent + "Complex" + (test "unit-test") + defCompAssertion + { sourceFiles = ["UnitMain.hs"] + , sourceDirs = ["test"] + } + ) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs index a1825767ed7..de80b857752 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/Setup.hs @@ -1,12 +1,15 @@ -- Setup.hs taken from 'cabal-testsuite/Setup.hs' {-# LANGUAGE Haskell2010 #-} + module Main (main) where import Distribution.Simple main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - putStrLn "Custom Setup.hs has been invoked!" - buildHook simpleUserHooks pkg lbi hooks flags - } +main = + defaultMainWithHooks + simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + putStrLn "Custom Setup.hs has been invoked!" + buildHook simpleUserHooks pkg lbi hooks flags + } diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs index f8c413c7c5b..182a0338347 100644 --- a/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Custom/custom.test.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Cabal.Prelude -import Test.Cabal.DecodeShowBuildInfo -import Control.Monad.Trans.Reader + +import Control.Monad.Trans.Reader +import Test.Cabal.DecodeShowBuildInfo +import Test.Cabal.Prelude main = setupTest $ do -- No cabal test because per-component is broken with it @@ -14,15 +15,18 @@ main = setupTest $ do assertCommonBuildInfo buildInfo let [libBI, exeBI] = components buildInfo - assertComponentPure libBI defCompAssertion - { modules = ["MyLib"] - , compType = "lib" - , sourceDirs = ["src"] - } - - assertComponentPure exeBI defCompAssertion - { sourceFiles = ["Main.hs"] - , compType = "exe" - , sourceDirs = ["app"] - } + assertComponentPure + libBI + defCompAssertion + { modules = ["MyLib"] + , compType = "lib" + , sourceDirs = ["src"] + } + assertComponentPure + exeBI + defCompAssertion + { sourceFiles = ["Main.hs"] + , compType = "exe" + , sourceDirs = ["app"] + } diff --git a/cabal-testsuite/PackageTests/SimpleDefault/cabal.test.hs b/cabal-testsuite/PackageTests/SimpleDefault/cabal.test.hs index a714b5910ae..387771903db 100644 --- a/cabal-testsuite/PackageTests/SimpleDefault/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SimpleDefault/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + main = cabalTest $ do - recordMode DoNotRecord $ do - -- TODO: Hack; see also CustomDep/cabal.test.hs - withEnvFilter (/= "HOME") $ do - cabal "v2-build" ["all"] + recordMode DoNotRecord $ do + -- TODO: Hack; see also CustomDep/cabal.test.hs + withEnvFilter (/= "HOME") $ do + cabal "v2-build" ["all"] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Exe.hs b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Exe.hs index 9013c1d6684..5dfb9b561fa 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Exe.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Main where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Lib.hs b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Lib.hs index 738088dd172..f00725de151 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Lib.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Lib where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs index 17b54d5e9f6..88ae5bad6f1 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/TH.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} + module TH where import Language.Haskell.TH (ExpQ) splice :: ExpQ -splice = [| () |] +splice = [|()|] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs index e98abf9eaca..bd7cbc1926f 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude + -- Test building a dynamic library/executable which uses Template -- Haskell main = setupAndCabalTest $ do - skipUnless "no shared libs" =<< hasSharedLibraries - setup_build ["--enable-shared", "--enable-executable-dynamic"] + skipUnless "no shared libs" =<< hasSharedLibraries + setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Exe.hs b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Exe.hs index 9013c1d6684..5dfb9b561fa 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Exe.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Main where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Lib.hs b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Lib.hs index 738088dd172..f00725de151 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Lib.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Lib where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs index 17b54d5e9f6..88ae5bad6f1 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/TH.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} + module TH where import Language.Haskell.TH (ExpQ) splice :: ExpQ -splice = [| () |] +splice = [|()|] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs index 0e508579958..c3db66fb2be 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs @@ -1,7 +1,10 @@ import Test.Cabal.Prelude + -- Test building a profiled library/executable which uses Template Haskell -- (setup has to build the non-profiled version first) main = setupAndCabalTest $ do - skipUnless "no profiling libs" =<< hasProfiledLibraries - setup_build ["--enable-library-profiling", - "--enable-profiling"] + skipUnless "no profiling libs" =<< hasProfiledLibraries + setup_build + [ "--enable-library-profiling" + , "--enable-profiling" + ] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Exe.hs b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Exe.hs index 9013c1d6684..5dfb9b561fa 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Exe.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Exe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Main where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Lib.hs b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Lib.hs index 738088dd172..f00725de151 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Lib.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} + module Lib where import TH diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs index 17b54d5e9f6..88ae5bad6f1 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/TH.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} + module TH where import Language.Haskell.TH (ExpQ) splice :: ExpQ -splice = [| () |] +splice = [|()|] diff --git a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs index d70262ea69c..2c90ece14f4 100644 --- a/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs +++ b/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs @@ -1,3 +1,4 @@ import Test.Cabal.Prelude + -- Test building a vanilla library/executable which uses Template Haskell main = setupAndCabalTest $ setup_build [] diff --git a/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs b/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs index 94d4db92de8..30149c3c10e 100644 --- a/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs +++ b/cabal-testsuite/PackageTests/TestCodeGenerator/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-test" [] + cabal "v2-test" [] diff --git a/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs b/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs index 5fadfd6c04b..44342f37439 100644 --- a/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs +++ b/cabal-testsuite/PackageTests/TestCodeGenerator/test-code-gen/app/Main.hs @@ -1,18 +1,19 @@ module Main where -import System.FilePath + import System.Environment +import System.FilePath main :: IO () main = do - (tgt:rest) <- getArgs + (tgt : rest) <- getArgs let (srcDirs, ghcArgs) = splitArgs rest let isGood = srcDirs == ["."] && "-outputdir" `elem` ghcArgs if isGood - then writeFile (tgt "Main.hs") $ "module Main where main = pure ()" - else writeFile (tgt "Main.hs") $ "module Main where main = error \"failure\"" + then writeFile (tgt "Main.hs") $ "module Main where main = pure ()" + else writeFile (tgt "Main.hs") $ "module Main where main = error \"failure\"" splitArgs = go [] where - go r ("--":xs) = (reverse r, xs) - go r (x:xs) = go (x:r) xs + go r ("--" : xs) = (reverse r, xs) + go r (x : xs) = go (x : r) xs go r [] = (reverse r, []) diff --git a/cabal-testsuite/PackageTests/TestNameCollision/child/Child.hs b/cabal-testsuite/PackageTests/TestNameCollision/child/Child.hs index c068dcf8b74..02ea621b757 100644 --- a/cabal-testsuite/PackageTests/TestNameCollision/child/Child.hs +++ b/cabal-testsuite/PackageTests/TestNameCollision/child/Child.hs @@ -1,2 +1,3 @@ module Child where + import Parent diff --git a/cabal-testsuite/PackageTests/TestNameCollision/child/tests/Test.hs b/cabal-testsuite/PackageTests/TestNameCollision/child/tests/Test.hs index f2325e79982..de4b5a8cbc4 100644 --- a/cabal-testsuite/PackageTests/TestNameCollision/child/tests/Test.hs +++ b/cabal-testsuite/PackageTests/TestNameCollision/child/tests/Test.hs @@ -1,13 +1,17 @@ module Test where -import Distribution.TestSuite import Child +import Distribution.TestSuite tests :: IO [Test] -tests = return $ [Test $ TestInstance +tests = + return $ + [ Test $ + TestInstance { run = return (Finished Pass) , name = "test" , tags = [] , options = [] - , setOption = \_ _-> Left "No Options" - }] + , setOption = \_ _ -> Left "No Options" + } + ] diff --git a/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs b/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs index 19d2fc90468..c63b896e6af 100644 --- a/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs +++ b/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs @@ -1,11 +1,12 @@ import Test.Cabal.Prelude + -- Test that if test suite has a name which conflicts with a package -- which is in the database, we can still use the test case (they -- should NOT shadow). main = setupAndCabalTest $ do - skipUnless "cabal for ghc" =<< hasCabalForGhc -- use of library test suite - withPackageDb $ do - withDirectory "parent" $ setup_install [] - withDirectory "child" $ do - setup_build ["--enable-tests"] - setup "test" [] + skipUnless "cabal for ghc" =<< hasCabalForGhc -- use of library test suite + withPackageDb $ do + withDirectory "parent" $ setup_install [] + withDirectory "child" $ do + setup_build ["--enable-tests"] + setup "test" [] diff --git a/cabal-testsuite/PackageTests/TestOptions/setup.test.hs b/cabal-testsuite/PackageTests/TestOptions/setup.test.hs index 9b77749e398..a743dac74f9 100644 --- a/cabal-testsuite/PackageTests/TestOptions/setup.test.hs +++ b/cabal-testsuite/PackageTests/TestOptions/setup.test.hs @@ -1,9 +1,12 @@ import Test.Cabal.Prelude + -- Test --test-option(s) flags on ./Setup test main = setupAndCabalTest $ do - setup_build ["--enable-tests"] - setup "test" ["--test-options=1 2 3"] - setup "test" [ "--test-option=1" - , "--test-option=2" - , "--test-option=3" - ] + setup_build ["--enable-tests"] + setup "test" ["--test-options=1 2 3"] + setup + "test" + [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] diff --git a/cabal-testsuite/PackageTests/TestOptions/test-TestOptions.hs b/cabal-testsuite/PackageTests/TestOptions/test-TestOptions.hs index 7c21bff136c..b89e40e3c64 100644 --- a/cabal-testsuite/PackageTests/TestOptions/test-TestOptions.hs +++ b/cabal-testsuite/PackageTests/TestOptions/test-TestOptions.hs @@ -1,11 +1,11 @@ module Main where -import System.Environment ( getArgs ) -import System.Exit ( exitFailure, exitSuccess ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = do - args <- getArgs - if args == ["1", "2", "3"] - then exitSuccess - else putStrLn ("Got: " ++ show args) >> exitFailure + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal-testsuite/PackageTests/TestStanza/setup.test.hs b/cabal-testsuite/PackageTests/TestStanza/setup.test.hs index 1f33596d86c..2eb71c9bbea 100644 --- a/cabal-testsuite/PackageTests/TestStanza/setup.test.hs +++ b/cabal-testsuite/PackageTests/TestStanza/setup.test.hs @@ -1,27 +1,31 @@ import Test.Cabal.Prelude -import Distribution.Version -import Distribution.Simple.LocalBuildInfo +import Control.Monad.IO.Class import Distribution.Package import Distribution.PackageDescription -import Distribution.Types.UnqualComponentName -import Control.Monad.IO.Class import Distribution.Simple.Configure +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Version main = setupAndCabalTest $ do - assertOutputDoesNotContain "unknown section type" - =<< setup' "configure" ["--enable-tests"] - lbi <- getLocalBuildInfoM - let gotTestSuite = head $ testSuites (localPkgDescr lbi) - assertEqual "testName" (mkUnqualComponentName "dummy") - (testName gotTestSuite) - assertEqual "testInterface" (TestSuiteExeV10 (mkVersion [1,0]) "dummy.hs") - (testInterface gotTestSuite) - -- NB: Not testing targetBuildDepends (testBuildInfo gotTestSuite) - -- as dependency varies with cabal-install - assertEqual - "testBuildInfo/hsSourceDirs" - [sameDirectory] - (hsSourceDirs (testBuildInfo gotTestSuite)) - return () + assertOutputDoesNotContain "unknown section type" + =<< setup' "configure" ["--enable-tests"] + lbi <- getLocalBuildInfoM + let gotTestSuite = head $ testSuites (localPkgDescr lbi) + assertEqual + "testName" + (mkUnqualComponentName "dummy") + (testName gotTestSuite) + assertEqual + "testInterface" + (TestSuiteExeV10 (mkVersion [1, 0]) "dummy.hs") + (testInterface gotTestSuite) + -- NB: Not testing targetBuildDepends (testBuildInfo gotTestSuite) + -- as dependency varies with cabal-install + assertEqual + "testBuildInfo/hsSourceDirs" + [sameDirectory] + (hsSourceDirs (testBuildInfo gotTestSuite)) + return () diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs index 14f12247548..5a7be567f09 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs @@ -9,34 +9,34 @@ import qualified Distribution.Verbosity as Verbosity import Test.Cabal.Prelude main = cabalTest $ do - skipIf "osx" =<< isOSX -- TODO: re-enable this once the macOS CI - -- issues are resolved, see discussion in #4902. + skipIf "osx" =<< isOSX -- TODO: re-enable this once the macOS CI + -- issues are resolved, see discussion in #4902. + hasShared <- hasSharedLibraries + hasProfiled <- hasProfiledLibraries + hpcOk <- correctHpcVersion - hasShared <- hasSharedLibraries - hasProfiled <- hasProfiledLibraries - hpcOk <- correctHpcVersion - - forM_ (choose4 [True, False]) $ \(libProf, exeProf, exeDyn, shared) -> - do + forM_ (choose4 [True, False]) $ \(libProf, exeProf, exeDyn, shared) -> + do + let + opts = + catMaybes + [ enable libProf "library-profiling" + , enable exeProf "profiling" + , enable exeDyn "executable-dynamic" + , enable shared "shared" + ] + where + enable cond flag + | cond = Just $ "--enable-" ++ flag + | otherwise = Nothing + args = "test-Short" : "--enable-coverage" : opts + recordMode DoNotRecord $ do let - opts = catMaybes - [ enable libProf "library-profiling" - , enable exeProf "profiling" - , enable exeDyn "executable-dynamic" - , enable shared "shared" - ] - where - enable cond flag - | cond = Just $ "--enable-" ++ flag - | otherwise = Nothing - args = "test-Short" : "--enable-coverage" : opts - recordMode DoNotRecord $ do - let - skip = - not hpcOk - || (not hasShared && (exeDyn || shared)) - || (not hasProfiled && (libProf || exeProf)) - unless skip $ cabal "v2-test" args + skip = + not hpcOk + || (not hasShared && (exeDyn || shared)) + || (not hasProfiled && (libProf || exeProf)) + unless skip $ cabal "v2-test" args where choose4 :: [a] -> [(a, a, a, a)] choose4 xs = liftM4 (,,,) xs xs xs xs @@ -44,11 +44,14 @@ main = cabalTest $ do -- | Checks for a suitable HPC version for testing. correctHpcVersion :: TestM Bool correctHpcVersion = do - let verbosity = Verbosity.normal - verRange = orLaterVersion (mkVersion [0,7]) - progDB <- testProgramDb `fmap` ask - liftIO $ (requireProgramVersion verbosity hpcProgram verRange progDB - >> return True) `catchIO` (\_ -> return False) + let verbosity = Verbosity.normal + verRange = orLaterVersion (mkVersion [0, 7]) + progDB <- testProgramDb `fmap` ask + liftIO $ + ( requireProgramVersion verbosity hpcProgram verRange progDB + >> return True + ) + `catchIO` (\_ -> return False) where -- Distribution.Compat.Exception is hidden. catchIO :: IO a -> (E.IOException -> IO a) -> IO a diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs index 94d4db92de8..30149c3c10e 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs @@ -1,4 +1,4 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-test" [] + cabal "v2-test" [] diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs index 99140253d55..918934cea91 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs @@ -1,16 +1,17 @@ -import Test.Cabal.Prelude import Distribution.Simple.Hpc +import Test.Cabal.Prelude -- Ensures that even if a .tix file happens to be left around -- markup isn't generated. main = setupAndCabalTest $ do - dist_dir <- fmap testDistDir getTestEnv - let tixFile = tixFilePath dist_dir Vanilla "test-Short" - withEnv [("HPCTIXFILE", Just tixFile)] $ do - setup_build - [ "--enable-tests" - , "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] - setup "test" ["test-Short", "--show-details=direct"] - shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" "hpc_index.html" + dist_dir <- fmap testDistDir getTestEnv + let tixFile = tixFilePath dist_dir Vanilla "test-Short" + withEnv [("HPCTIXFILE", Just tixFile)] $ do + setup_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" + ] + setup "test" ["test-Short", "--show-details=direct"] + shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" "hpc_index.html" diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs index 073af976d56..fc596605af6 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs @@ -1,5 +1,5 @@ -import Test.Cabal.Prelude import Distribution.Simple.Hpc +import Test.Cabal.Prelude -- When -fhpc is manually provided, but --enable-coverage is not, -- the desired behavior is that we pass on -fhpc to GHC, but do NOT @@ -12,16 +12,17 @@ import Distribution.Simple.Hpc -- at all.) -- main = setupAndCabalTest $ do - -- Source copy is necessary as GHC defaults to dumping tix - -- file in the CWD, and we do NOT clean it up after the fact. - withSourceCopy $ do - dist_dir <- fmap testDistDir getTestEnv - setup_build - [ "--enable-tests" - , "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] - setup "test" ["test-Short", "--show-details=direct"] - lbi <- getLocalBuildInfoM - let way = guessWay lbi - shouldNotExist $ tixFilePath dist_dir way "test-Short" + -- Source copy is necessary as GHC defaults to dumping tix + -- file in the CWD, and we do NOT clean it up after the fact. + withSourceCopy $ do + dist_dir <- fmap testDistDir getTestEnv + setup_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" + ] + setup "test" ["test-Short", "--show-details=direct"] + lbi <- getLocalBuildInfoM + let way = guessWay lbi + shouldNotExist $ tixFilePath dist_dir way "test-Short" diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs index 11d28d8d7cb..0b23734ddac 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs @@ -1,12 +1,13 @@ module Main where +import Control.Monad import Foo import System.Exit -import Control.Monad main :: IO () -main | fooTest [] = do - -- Make sure that the output buffer is drained - replicateM 10000 $ putStrLn "The quick brown fox jumps over the lazy dog" - exitSuccess - | otherwise = exitFailure +main + | fooTest [] = do + -- Make sure that the output buffer is drained + replicateM 10000 $ putStrLn "The quick brown fox jumps over the lazy dog" + exitSuccess + | otherwise = exitFailure diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs index ce578114cd1..ceb8e47b9af 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs @@ -1,11 +1,12 @@ module Main where +import Control.Monad import Foo import System.Exit -import Control.Monad main :: IO () -main | fooTest [] = do - replicateM 5 $ putStrLn "The quick brown fox jumps over the lazy dog" - exitSuccess - | otherwise = exitFailure +main + | fooTest [] = do + replicateM 5 $ putStrLn "The quick brown fox jumps over the lazy dog" + exitSuccess + | otherwise = exitFailure diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/Lib.hs b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/Lib.hs index e2c3615f4ca..3356a1e54c1 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/Lib.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/Lib.hs @@ -2,10 +2,12 @@ module Lib where import Distribution.TestSuite -nullt x = Test $ TestInstance - { run = return $ Finished (Fail "no reason") - , name = "test " ++ show x - , tags = [] - , options = [] - , setOption = \_ _-> Left "No Options" - } +nullt x = + Test $ + TestInstance + { run = return $ Finished (Fail "no reason") + , name = "test " ++ show x + , tags = [] + , options = [] + , setOption = \_ _ -> Left "No Options" + } diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs index 69529404d97..d21b67bface 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + main = setupAndCabalTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc - setup_build ["--enable-tests"] - fails $ setup "test" [] + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + setup_build ["--enable-tests"] + fails $ setup "test" [] diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs index 1a50e4d67e4..eced90d5c84 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude + -- Test if detailed-0.9 builds correctly main = setupAndCabalTest $ do - skipUnless "no Cabal for GHC" =<< hasCabalForGhc - setup_build ["--enable-tests"] + skipUnless "no Cabal for GHC" =<< hasCabalForGhc + setup_build ["--enable-tests"] diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs index 5d7db101ed9..7ebfbf25b41 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs @@ -5,4 +5,4 @@ import Distribution.TestSuite import Lib tests :: IO [Test] -tests = return [nullt x | x <- [1 .. 1000]] +tests = return [nullt x | x <- [1 .. 1000]] diff --git a/cabal-testsuite/PackageTests/UniqueIPID/P1/M.hs b/cabal-testsuite/PackageTests/UniqueIPID/P1/M.hs index 33b222fbb90..b3c7beb9898 100644 --- a/cabal-testsuite/PackageTests/UniqueIPID/P1/M.hs +++ b/cabal-testsuite/PackageTests/UniqueIPID/P1/M.hs @@ -1,3 +1,3 @@ -module M(m) where +module M (m) where m = print "1" diff --git a/cabal-testsuite/PackageTests/UniqueIPID/P2/M.hs b/cabal-testsuite/PackageTests/UniqueIPID/P2/M.hs index 05d451cda9b..d0758669f23 100644 --- a/cabal-testsuite/PackageTests/UniqueIPID/P2/M.hs +++ b/cabal-testsuite/PackageTests/UniqueIPID/P2/M.hs @@ -1,3 +1,3 @@ -module M(m) where +module M (m) where m = print "2" diff --git a/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs b/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs index d084e8c1989..f7e3a6d1bed 100644 --- a/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs +++ b/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs @@ -1,16 +1,19 @@ -import Test.Cabal.Prelude import Data.List +import Test.Cabal.Prelude + -- Test that setup computes different IPIDs when dependencies change main = setupAndCabalTest $ do - withPackageDb $ do - withDirectory "P1" $ setup "configure" ["--disable-deterministic"] - withDirectory "P2" $ setup "configure" ["--disable-deterministic"] - withDirectory "P1" $ setup "build" [] - withDirectory "P1" $ setup "build" [] -- rebuild should work - recordMode DoNotRecord $ do - r1 <- withDirectory "P1" $ setup' "register" ["--print-ipid", "--inplace"] - withDirectory "P2" $ setup "build" [] - r2 <- withDirectory "P2" $ setup' "register" ["--print-ipid", "--inplace"] - let exIPID s = takeWhile (/= '\n') $ - head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s) - assertNotEqual "ipid match" (exIPID $ resultOutput r1) (exIPID $ resultOutput r2) + withPackageDb $ do + withDirectory "P1" $ setup "configure" ["--disable-deterministic"] + withDirectory "P2" $ setup "configure" ["--disable-deterministic"] + withDirectory "P1" $ setup "build" [] + withDirectory "P1" $ setup "build" [] -- rebuild should work + recordMode DoNotRecord $ do + r1 <- withDirectory "P1" $ setup' "register" ["--print-ipid", "--inplace"] + withDirectory "P2" $ setup "build" [] + r2 <- withDirectory "P2" $ setup' "register" ["--print-ipid", "--inplace"] + let exIPID s = + takeWhile (/= '\n') $ + head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ + (tails s) + assertNotEqual "ipid match" (exIPID $ resultOutput r1) (exIPID $ resultOutput r2) diff --git a/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs b/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs index 300bcc59ea5..e231b25683e 100644 --- a/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs +++ b/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs @@ -1,23 +1,19 @@ import Test.Cabal.Prelude -main = cabalTest $ do - workdir <- fmap testWorkDir getTestEnv - let conf = workdir "cabal-config" - cabalG ["--config-file", conf] "user-config" ["init"] - shouldExist conf - fails $ cabalG ["--config-file", workdir "cabal-config"] "user-config" ["init"] - cabalG ["--config-file", conf] "user-config" ["-f", "init"] - shouldExist conf - let conf2 = workdir "cabal-config2" - withEnv [("CABAL_CONFIG", Just conf2)] $ do - cabal "user-config" ["init"] - shouldExist conf2 - cabalG ["--config-file", conf] "user-config" ["update", "-f", "-a", "extra-prog-path: foo", "-a", "extra-prog-path: bar"] - assertFileDoesContain conf "foo,bar" - cabalG ["--config-file", conf] "user-config" ["update", "-f", "-a", "extra-prog-path: foo, bar"] - assertFileDoesContain conf "foo,bar" - -- regression test for #6268 (password-command parsing) - cabalG ["--config-file", conf] - "user-config" ["update", "-f", "-a", "password-command: sh -c \"echo secret\""] - -- non-quoted tokens do get quoted when writing, but this is expected - assertFileDoesContain conf "password-command: \"sh\" \"-c\" \"echo secret\"" +main = cabalTest $ do + workdir <- fmap testWorkDir getTestEnv + let conf = workdir "cabal-config" + cabalG ["--config-file", conf] "user-config" ["init"] + shouldExist conf + fails $ cabalG ["--config-file", workdir "cabal-config"] "user-config" ["init"] + cabalG ["--config-file", conf] "user-config" ["-f", "init"] + shouldExist conf + let conf2 = workdir "cabal-config2" + withEnv [("CABAL_CONFIG", Just conf2)] $ do + cabal "user-config" ["init"] + shouldExist conf2 + cabalG ["--config-file", conf] "user-config" ["update", "-f", "-a", "extra-prog-path: foo", "-a", "extra-prog-path: bar"] + assertFileDoesContain conf "foo,bar" + cabalG ["--config-file", conf] "user-config" ["update", "-f", "-a", "extra-prog-path: foo, bar"] + assertFileDoesContain conf "foo,bar" +>>>>>>> d1b1ef563 (Add more formatting rules) diff --git a/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs b/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs index d4747aceb92..ca5d88b98a8 100644 --- a/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs +++ b/cabal-testsuite/PackageTests/postCheckoutCommand/cabal.test.hs @@ -1,8 +1,8 @@ import Test.Cabal.Prelude main = cabalTest $ do - skipIfWindows - withProjectFile "cabal.positive.project" $ do - cabal "v2-build" ["-v0"] - withProjectFile "cabal.negative.project" $ do - fails $ cabal "v2-build" ["-v0"] + skipIfWindows + withProjectFile "cabal.positive.project" $ do + cabal "v2-build" ["-v0"] + withProjectFile "cabal.negative.project" $ do + fails $ cabal "v2-build" ["-v0"] diff --git a/cabal-testsuite/Setup.hs b/cabal-testsuite/Setup.hs index 2b212906a60..165c0970e93 100644 --- a/cabal-testsuite/Setup.hs +++ b/cabal-testsuite/Setup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Haskell2010 #-} + module Main (main) where import Distribution.Backpack @@ -27,8 +28,9 @@ generateScriptEnvModule :: LocalBuildInfo -> Verbosity -> IO () generateScriptEnvModule lbi verbosity = do lbiPackageDbStack <- mapM canonicalizePackageDB (withPackageDB lbi) - createDirectoryIfMissing True moduledir - rewriteFileEx verbosity (moduledir "ScriptEnv0.hs") $ unlines + createDirectoryIfMissing True moduledir + rewriteFileEx verbosity (moduledir "ScriptEnv0.hs") $ + unlines [ "module Test.Cabal.ScriptEnv0 where" , "" , "import Distribution.Simple" @@ -64,8 +66,8 @@ generateScriptEnvModule lbi verbosity = do -- | Convert package database into absolute path, so that -- if we change working directories in a subprocess we get the correct database. canonicalizePackageDB :: PackageDB -> IO PackageDB -canonicalizePackageDB (SpecificPackageDB path) - = SpecificPackageDB `fmap` canonicalizePath path +canonicalizePackageDB (SpecificPackageDB path) = + SpecificPackageDB `fmap` canonicalizePath path canonicalizePackageDB x = return x -- | Compute the set of @-package-id@ flags which would be passed when @@ -73,7 +75,8 @@ canonicalizePackageDB x = return x -- non-Backpack. cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] cabalTestsPackages lbi = - case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of - [clbi] -> -- [ (unUnitId $ unDefUnitId duid,rn) | (DefiniteUnitId duid, rn) <- componentIncludes clbi ] - componentIncludes clbi - _ -> error "cabalTestsPackages" + case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of + [clbi] -> + -- [ (unUnitId $ unDefUnitId duid,rn) | (DefiniteUnitId duid, rn) <- componentIncludes clbi ] + componentIncludes clbi + _ -> error "cabalTestsPackages" diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index 2ea070bff07..49c03b4c8ea 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -1,31 +1,30 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} -import Test.Cabal.Workdir +import Test.Cabal.Monad import Test.Cabal.Script import Test.Cabal.Server -import Test.Cabal.Monad import Test.Cabal.TestCode +import Test.Cabal.Workdir -import Distribution.Verbosity (normal, verbose, Verbosity) -import Distribution.Simple.Utils (getDirectoryContentsRecursive) +import Distribution.Simple.Utils (getDirectoryContentsRecursive) +import Distribution.Verbosity (Verbosity, normal, verbose) -import Options.Applicative -import Control.Concurrent.MVar import Control.Concurrent import Control.Concurrent.Async import Control.Exception import Control.Monad -import GHC.Conc (numCapabilities) import Data.List -import Text.Printf +import GHC.Conc (numCapabilities) +import Options.Applicative import qualified System.Clock as Clock -import System.IO -import System.FilePath import System.Exit +import System.FilePath +import System.IO import System.Process (callProcess, showCommandForUser) +import Text.Printf #if !MIN_VERSION_base(4,12,0) import Data.Monoid ((<>)) @@ -35,202 +34,228 @@ import Data.Monoid (mempty) #endif -- | Record for arguments that can be passed to @cabal-tests@ executable. -data MainArgs = MainArgs { - mainArgThreads :: Int, - mainArgTestPaths :: [String], - mainArgHideSuccesses :: Bool, - mainArgVerbose :: Bool, - mainArgQuiet :: Bool, - mainArgDistDir :: Maybe FilePath, - mainCommonArgs :: CommonArgs - } +data MainArgs = MainArgs + { mainArgThreads :: Int + , mainArgTestPaths :: [String] + , mainArgHideSuccesses :: Bool + , mainArgVerbose :: Bool + , mainArgQuiet :: Bool + , mainArgDistDir :: Maybe FilePath + , mainCommonArgs :: CommonArgs + } -- | optparse-applicative parser for 'MainArgs' mainArgParser :: Parser MainArgs -mainArgParser = MainArgs - <$> option auto - ( help "Number of threads to run" - <> short 'j' - <> showDefault - <> value numCapabilities - <> metavar "INT") +mainArgParser = + MainArgs + <$> option + auto + ( help "Number of threads to run" + <> short 'j' + <> showDefault + <> value numCapabilities + <> metavar "INT" + ) <*> many (argument str (metavar "FILE")) <*> switch - ( long "hide-successes" - <> help "Do not print test cases as they are being run" - ) + ( long "hide-successes" + <> help "Do not print test cases as they are being run" + ) <*> switch - ( long "verbose" - <> short 'v' - <> help "Be verbose" - ) + ( long "verbose" + <> short 'v' + <> help "Be verbose" + ) <*> switch - ( long "quiet" - <> short 'q' - <> help "Only output stderr on failure" - ) - <*> optional (option str - ( help "Dist directory we were built with" - <> long "builddir" - <> metavar "DIR")) + ( long "quiet" + <> short 'q' + <> help "Only output stderr on failure" + ) + <*> optional + ( option + str + ( help "Dist directory we were built with" + <> long "builddir" + <> metavar "DIR" + ) + ) <*> commonArgParser main :: IO () main = do - -- By default, stderr is not buffered. This isn't really necessary - -- for us, and it causes problems on Windows, see: - -- https://github.com/appveyor/ci/issues/1364 - hSetBuffering stderr LineBuffering - - -- Parse arguments. N.B. 'helper' adds the option `--help`. - args <- execParser $ info (mainArgParser <**> helper) mempty - let verbosity = if mainArgVerbose args then verbose else normal + -- By default, stderr is not buffered. This isn't really necessary + -- for us, and it causes problems on Windows, see: + -- https://github.com/appveyor/ci/issues/1364 + hSetBuffering stderr LineBuffering - -- To run our test scripts, we need to be able to run Haskell code - -- linked against the Cabal library under test. The most efficient - -- way to get this information is by querying the *host* build - -- system about the information. - -- - -- Fortunately, because we are using a Custom setup, our Setup - -- script is bootstrapped against the Cabal library we're testing - -- against, so can use our dependency on Cabal to read out the build - -- info *for this package*. - -- - -- NB: Currently assumes that per-component build is NOT turned on - -- for Custom. - dist_dir <- case mainArgDistDir args of - Just dist_dir -> return dist_dir - Nothing -> guessDistDir - when (verbosity >= verbose) $ - hPutStrLn stderr $ "Using dist dir: " ++ dist_dir - -- Get ready to go! - senv <- mkScriptEnv verbosity + -- Parse arguments. N.B. 'helper' adds the option `--help`. + args <- execParser $ info (mainArgParser <**> helper) mempty + let verbosity = if mainArgVerbose args then verbose else normal - let runTest :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result) - -> FilePath - -> IO result - runTest runner path - = runner Nothing [] path $ - ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args) + -- To run our test scripts, we need to be able to run Haskell code + -- linked against the Cabal library under test. The most efficient + -- way to get this information is by querying the *host* build + -- system about the information. + -- + -- Fortunately, because we are using a Custom setup, our Setup + -- script is bootstrapped against the Cabal library we're testing + -- against, so can use our dependency on Cabal to read out the build + -- info *for this package*. + -- + -- NB: Currently assumes that per-component build is NOT turned on + -- for Custom. + dist_dir <- case mainArgDistDir args of + Just dist_dir -> return dist_dir + Nothing -> guessDistDir + when (verbosity >= verbose) $ + hPutStrLn stderr $ + "Using dist dir: " ++ dist_dir + -- Get ready to go! + senv <- mkScriptEnv verbosity - case mainArgTestPaths args of - [path] -> do - -- Simple runner - (real_path, real_args) <- runTest (runnerCommand senv) path - hPutStrLn stderr $ showCommandForUser real_path real_args - callProcess real_path real_args - hPutStrLn stderr "OK" - user_paths -> do - -- Read out tests from filesystem - hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args) + let runTest + :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result) + -> FilePath + -> IO result + runTest runner path = + runner Nothing [] path $ + ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args) - test_scripts <- if null user_paths - then findTests - else return user_paths - -- NB: getDirectoryContentsRecursive is lazy IO, but it - -- doesn't handle directories disappearing gracefully. Fix - -- this! - (single_tests, multi_tests) <- evaluate (partitionTests test_scripts) - let all_tests = multi_tests ++ single_tests - margin = maximum (map length all_tests) + 2 - hPutStrLn stderr $ "tests to run: " ++ show (length all_tests) + case mainArgTestPaths args of + [path] -> do + -- Simple runner + (real_path, real_args) <- runTest (runnerCommand senv) path + hPutStrLn stderr $ showCommandForUser real_path real_args + callProcess real_path real_args + hPutStrLn stderr "OK" + user_paths -> do + -- Read out tests from filesystem + hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args) - -- TODO: Get parallelization out of multitests by querying - -- them for their modes and then making a separate worker - -- for each. But for now, just run them earlier to avoid - -- them straggling at the end - work_queue <- newMVar all_tests - unexpected_fails_var <- newMVar [] - unexpected_passes_var <- newMVar [] - skipped_var <- newMVar [] + test_scripts <- + if null user_paths + then findTests + else return user_paths + -- NB: getDirectoryContentsRecursive is lazy IO, but it + -- doesn't handle directories disappearing gracefully. Fix + -- this! + (single_tests, multi_tests) <- evaluate (partitionTests test_scripts) + let all_tests = multi_tests ++ single_tests + margin = maximum (map length all_tests) + 2 + hPutStrLn stderr $ "tests to run: " ++ show (length all_tests) - chan <- newChan - let logAll msg = writeChan chan (ServerLogMsg AllServers msg) - logEnd = writeChan chan ServerLogEnd - -- NB: don't use withAsync as we do NOT want to cancel this - -- on an exception - async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan) + -- TODO: Get parallelization out of multitests by querying + -- them for their modes and then making a separate worker + -- for each. But for now, just run them earlier to avoid + -- them straggling at the end + work_queue <- newMVar all_tests + unexpected_fails_var <- newMVar [] + unexpected_passes_var <- newMVar [] + skipped_var <- newMVar [] - -- Make sure we pump out all the logs before quitting - (\m -> finally m (logEnd >> wait async_logger)) $ do + chan <- newChan + let logAll msg = writeChan chan (ServerLogMsg AllServers msg) + logEnd = writeChan chan ServerLogEnd + -- NB: don't use withAsync as we do NOT want to cancel this + -- on an exception + async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan) - -- NB: Need to use withAsync so that if the main thread dies - -- (due to ctrl-c) we tear down all of the worker threads. - let go server = do - let split [] = return ([], Nothing) - split (y:ys) = return (ys, Just y) - logMeta msg = writeChan chan - $ ServerLogMsg - (ServerMeta (serverProcessId server)) - msg - mb_work <- modifyMVar work_queue split - case mb_work of - Nothing -> return () - Just path -> do - when (verbosity >= verbose) $ - logMeta $ "Running " ++ path - start <- getTime - r <- runTest (runOnServer server) path - end <- getTime - let time = end - start - code = serverResultTestCode r + -- Make sure we pump out all the logs before quitting + (\m -> finally m (logEnd >> wait async_logger)) $ do + -- NB: Need to use withAsync so that if the main thread dies + -- (due to ctrl-c) we tear down all of the worker threads. + let go server = do + let split [] = return ([], Nothing) + split (y : ys) = return (ys, Just y) + logMeta msg = + writeChan chan $ + ServerLogMsg + (ServerMeta (serverProcessId server)) + msg + mb_work <- modifyMVar work_queue split + case mb_work of + Nothing -> return () + Just path -> do + when (verbosity >= verbose) $ + logMeta $ + "Running " ++ path + start <- getTime + r <- runTest (runOnServer server) path + end <- getTime + let time = end - start + code = serverResultTestCode r - unless (mainArgHideSuccesses args && code == TestCodeOk) $ do - logMeta $ - path ++ replicate (margin - length path) ' ' ++ displayTestCode code ++ - if time >= 0.01 - then printf " (%.2fs)" time - else "" + unless (mainArgHideSuccesses args && code == TestCodeOk) $ do + logMeta $ + path + ++ replicate (margin - length path) ' ' + ++ displayTestCode code + ++ if time >= 0.01 + then printf " (%.2fs)" time + else "" - when (code == TestCodeFail) $ do - let description - | mainArgQuiet args = serverResultStderr r - | otherwise = - "$ " ++ serverResultCommand r ++ "\n" ++ - "stdout:\n" ++ serverResultStdout r ++ "\n" ++ - "stderr:\n" ++ serverResultStderr r ++ "\n" - logMeta $ - description - ++ "*** unexpected failure for " ++ path ++ "\n\n" - modifyMVar_ unexpected_fails_var $ \paths -> - return (path:paths) + when (code == TestCodeFail) $ do + let description + | mainArgQuiet args = serverResultStderr r + | otherwise = + "$ " + ++ serverResultCommand r + ++ "\n" + ++ "stdout:\n" + ++ serverResultStdout r + ++ "\n" + ++ "stderr:\n" + ++ serverResultStderr r + ++ "\n" + logMeta $ + description + ++ "*** unexpected failure for " + ++ path + ++ "\n\n" + modifyMVar_ unexpected_fails_var $ \paths -> + return (path : paths) - when (code == TestCodeUnexpectedOk) $ - modifyMVar_ unexpected_passes_var $ \paths -> - return (path:paths) + when (code == TestCodeUnexpectedOk) $ + modifyMVar_ unexpected_passes_var $ \paths -> + return (path : paths) - when (isTestCodeSkip code) $ - modifyMVar_ skipped_var $ \paths -> - return (path:paths) + when (isTestCodeSkip code) $ + modifyMVar_ skipped_var $ \paths -> + return (path : paths) - go server + go server - -- Start as many threads as requested by -j to spawn - -- GHCi servers and start running tests off of the - -- run queue. - replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go) + -- Start as many threads as requested by -j to spawn + -- GHCi servers and start running tests off of the + -- run queue. + replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go) - unexpected_fails <- takeMVar unexpected_fails_var - unexpected_passes <- takeMVar unexpected_passes_var - skipped <- takeMVar skipped_var + unexpected_fails <- takeMVar unexpected_fails_var + unexpected_passes <- takeMVar unexpected_passes_var + skipped <- takeMVar skipped_var - -- print summary - let sl = show . length - testSummary = - sl all_tests ++ " tests, " ++ sl skipped ++ " skipped, " - ++ sl unexpected_passes ++ " unexpected passes, " - ++ sl unexpected_fails ++ " unexpected fails." - logAll testSummary + -- print summary + let sl = show . length + testSummary = + sl all_tests + ++ " tests, " + ++ sl skipped + ++ " skipped, " + ++ sl unexpected_passes + ++ " unexpected passes, " + ++ sl unexpected_fails + ++ " unexpected fails." + logAll testSummary - -- print failed or unexpected ok - if null (unexpected_fails ++ unexpected_passes) - then logAll "OK" - else do - unless (null unexpected_passes) . logAll $ - "UNEXPECTED OK: " ++ intercalate " " unexpected_passes - unless (null unexpected_fails) . logAll $ - "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails - exitFailure + -- print failed or unexpected ok + if null (unexpected_fails ++ unexpected_passes) + then logAll "OK" + else do + unless (null unexpected_passes) . logAll $ + "UNEXPECTED OK: " ++ intercalate " " unexpected_passes + unless (null unexpected_fails) . logAll $ + "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails + exitFailure findTests :: IO [FilePath] findTests = getDirectoryContentsRecursive "." @@ -239,51 +264,52 @@ partitionTests :: [FilePath] -> ([FilePath], [FilePath]) partitionTests = go [] [] where go ts ms [] = (ts, ms) - go ts ms (f:fs) = - -- NB: Keep this synchronized with isTestFile - case takeExtensions f of - ".test.hs" -> go (f:ts) ms fs - ".multitest.hs" -> go ts (f:ms) fs - _ -> go ts ms fs + go ts ms (f : fs) = + -- NB: Keep this synchronized with isTestFile + case takeExtensions f of + ".test.hs" -> go (f : ts) ms fs + ".multitest.hs" -> go ts (f : ms) fs + _ -> go ts ms fs outputThread :: Verbosity -> Chan ServerLogMsg -> Handle -> IO () outputThread verbosity chan log_handle = go "" where go prev_hdr = do - v <- readChan chan - case v of - ServerLogEnd -> return () - ServerLogMsg t msg -> do - let ls = lines msg - pre s c - | verbosity >= verbose - -- Didn't use printf as GHC 7.4 - -- doesn't understand % 7s. - = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " " - | otherwise = "" - hdr = case t of - AllServers -> "" - ServerMeta s -> pre s ' ' - ServerIn s -> pre s '<' - ServerOut s -> pre s '>' - ServerErr s -> pre s '!' - ws = replicate (length hdr) ' ' - mb_hdr l | hdr == prev_hdr = ws ++ l - | otherwise = hdr ++ l - ls' = case ls of - [] -> [] - r:rs -> - mb_hdr r : map (ws ++) rs - logmsg = unlines ls' - hPutStr stderr logmsg - hPutStr log_handle logmsg - go hdr + v <- readChan chan + case v of + ServerLogEnd -> return () + ServerLogMsg t msg -> do + let ls = lines msg + pre s c + | verbosity >= verbose = + -- Didn't use printf as GHC 7.4 + -- doesn't understand % 7s. + replicate (7 - length s) ' ' ++ s ++ " " ++ c : " " + | otherwise = "" + hdr = case t of + AllServers -> "" + ServerMeta s -> pre s ' ' + ServerIn s -> pre s '<' + ServerOut s -> pre s '>' + ServerErr s -> pre s '!' + ws = replicate (length hdr) ' ' + mb_hdr l + | hdr == prev_hdr = ws ++ l + | otherwise = hdr ++ l + ls' = case ls of + [] -> [] + r : rs -> + mb_hdr r : map (ws ++) rs + logmsg = unlines ls' + hPutStr stderr logmsg + hPutStr log_handle logmsg + go hdr -- Cribbed from tasty type Time = Double getTime :: IO Time getTime = do - t <- Clock.getTime Clock.Monotonic - let ns = realToFrac $ Clock.toNanoSecs t - return $ ns / 10 ^ (9 :: Int) + t <- Clock.getTime Clock.Monotonic + let ns = realToFrac $ Clock.toNanoSecs t + return $ ns / 10 ^ (9 :: Int) diff --git a/cabal-testsuite/src/Test/Cabal/CheckArMetadata.hs b/cabal-testsuite/src/Test/Cabal/CheckArMetadata.hs index 9361d9d3dc9..fa6f259fadb 100644 --- a/cabal-testsuite/src/Test/Cabal/CheckArMetadata.hs +++ b/cabal-testsuite/src/Test/Cabal/CheckArMetadata.hs @@ -1,4 +1,7 @@ ---------------------------------------------------------------------------- +---------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Test.Cabal.CheckArMetadata -- Created : 8 July 2017 @@ -7,10 +10,6 @@ -- One of the crucial properties of .a files is that they must be -- deterministic - i.e. they must not include creation date as their -- contents to facilitate deterministic builds. ----------------------------------------------------------------------------- - -{-# LANGUAGE OverloadedStrings #-} - module Test.Cabal.CheckArMetadata (checkMetadata) where import Test.Cabal.Prelude @@ -20,22 +19,28 @@ import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) import System.IO -import Distribution.Package (getHSLibraryName) +import Distribution.Package (getHSLibraryName) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, localUnitId) -- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata checkMetadata :: LocalBuildInfo -> FilePath -> IO () -checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> +checkMetadata lbi dir = withBinaryFile path ReadMode $ \h -> hFileSize h >>= checkArchive h where path = dir "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a" - checkError msg = assertFailure ( - "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ - " in " ++ path) >> undefined + checkError msg = + assertFailure + ( "PackageTests.DeterministicAr.checkMetadata: " + ++ msg + ++ " in " + ++ path + ) + >> undefined archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat + metadata = + BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes @@ -46,36 +51,39 @@ checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details checkArchive :: Handle -> Integer -> IO () checkArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ checkError "Bad global header" - checkHeader (toInteger $ BS.length archLF) - + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ checkError "Bad global header" + checkHeader (toInteger $ BS.length archLF) where checkHeader :: Integer -> IO () checkHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> checkError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - checkError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . checkError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - unless (metadata == BS.take 32 (BS.drop 16 header)) - . checkError . atOffset $ "Metadata has changed" + EQ -> return () + GT -> checkError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + checkError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . checkError . atOffset $ + "Bad magic " ++ show magic ++ " in header" - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> checkError (atOffset "Bad file size in header") + unless (metadata == BS.take 32 (BS.drop 16 header)) + . checkError + . atOffset + $ "Metadata has changed" - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - checkHeader nextHeader + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> checkError (atOffset "Bad file size in header") + let nextHeader = + offset + + toInteger headerSize + + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + checkHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset diff --git a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs index 02c1cb7e733..cbd3ac05929 100644 --- a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs +++ b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs @@ -1,27 +1,28 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + module Test.Cabal.DecodeShowBuildInfo where -import Test.Cabal.Prelude -import Test.Cabal.Plan -import Distribution.Compat.Stack -import Distribution.Text (display) -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.UnqualComponentName -import Distribution.Package -import Distribution.Pretty (prettyShow) -import Control.Monad.Trans.Reader -import Data.Aeson -import GHC.Generics -import System.Exit +import Control.Monad.Trans.Reader +import Data.Aeson +import Distribution.Compat.Stack +import Distribution.Package +import Distribution.Pretty (prettyShow) +import Distribution.Text (display) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName +import GHC.Generics +import System.Exit +import Test.Cabal.Plan +import Test.Cabal.Prelude -- | Execute 'cabal build --enable-build-info'. -- -- Results can be read via 'withPlan', 'buildInfoFile' and 'decodeBuildInfoFile'. runShowBuildInfo :: [String] -> TestM () -runShowBuildInfo args = cabal "build" ("--enable-build-info":args) +runShowBuildInfo args = cabal "build" ("--enable-build-info" : args) -- | Read 'build-info.json' for a given package and component -- from disk and record the content. Helpful for defining test-cases @@ -51,13 +52,15 @@ data BuildInfo = BuildInfo { cabalLibVersion :: String , compiler :: CompilerInfo , components :: [ComponentInfo] - } deriving (Generic, Show) + } + deriving (Generic, Show) data CompilerInfo = CompilerInfo { flavour :: String , compilerId :: String , path :: String - } deriving (Generic, Show) + } + deriving (Generic, Show) data ComponentInfo = ComponentInfo { componentType :: String @@ -68,22 +71,23 @@ data ComponentInfo = ComponentInfo , componentSrcFiles :: [FilePath] , componentHsSrcDirs :: [FilePath] , componentSrcDir :: FilePath - } deriving (Generic, Show) + } + deriving (Generic, Show) instance ToJSON BuildInfo where toEncoding = genericToEncoding defaultOptions instance FromJSON BuildInfo where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = camelTo2 '-'} instance ToJSON CompilerInfo where toEncoding = genericToEncoding defaultOptions instance FromJSON CompilerInfo where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = camelTo2 '-'} instance ToJSON ComponentInfo where toEncoding = genericToEncoding defaultOptions instance FromJSON ComponentInfo where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 10 . camelTo2 '-' } + parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = drop 10 . camelTo2 '-'} -- ----------------------------------------------------------- -- Assertion Helpers to define succinct test cases @@ -105,14 +109,15 @@ data ComponentAssertion = ComponentAssertion } defCompAssertion :: ComponentAssertion -defCompAssertion = ComponentAssertion - { unitIdPred = not . null - , compilerArgsPred = not . null - , modules = [] - , sourceFiles = [] - , sourceDirs = [] - , compType = "" - } +defCompAssertion = + ComponentAssertion + { unitIdPred = not . null + , compilerArgsPred = not . null + , modules = [] + , sourceFiles = [] + , sourceDirs = [] + , compType = "" + } -- | Assert common build information, such as compiler location, compiler version -- and cabal library version. @@ -128,8 +133,8 @@ assertCommonBuildInfo buildInfo = do assertComponentPure :: WithCallStack (ComponentInfo -> ComponentAssertion -> TestM ()) assertComponentPure component ComponentAssertion{..} = do assertEqual "Component type" compType (componentType component) - assertBool "Component Unit Id" (unitIdPred $ componentUnitId component) - assertBool "Component compiler args" (compilerArgsPred $ componentCompilerArgs component) + assertBool "Component Unit Id" (unitIdPred $ componentUnitId component) + assertBool "Component compiler args" (compilerArgsPred $ componentCompilerArgs component) assertEqual "Component modules" modules (componentModules component) assertEqual "Component source files" sourceFiles (componentSrcFiles component) assertEqual "Component source directories" sourceDirs (componentHsSrcDirs component) @@ -148,11 +153,11 @@ assertComponent pkgName cname assert = do assertCommonBuildInfo buildInfo let component = findComponentInfo buildInfo - let assertWithCompType = assert { compType = compTypeStr cname } + let assertWithCompType = assert{compType = compTypeStr cname} assertComponentPure component assertWithCompType where compTypeStr :: ComponentName -> String - compTypeStr (CLibName _) = "lib" + compTypeStr (CLibName _) = "lib" compTypeStr (CFLibName _) = "flib" compTypeStr (CExeName _) = "exe" compTypeStr (CTestName _) = "test" @@ -162,10 +167,17 @@ assertComponent pkgName cname assert = do findComponentInfo buildInfo = case filter (\c -> prettyShow cname == componentName c) (components buildInfo) of [x] -> x - [] -> error $ "findComponentInfo: component " ++ prettyShow cname ++ " does not" - ++ " exist in build info-file" - _ -> error $ "findComponentInfo: found multiple copies of component " ++ prettyShow cname - ++ " in build info plan" + [] -> + error $ + "findComponentInfo: component " + ++ prettyShow cname + ++ " does not" + ++ " exist in build info-file" + _ -> + error $ + "findComponentInfo: found multiple copies of component " + ++ prettyShow cname + ++ " in build info plan" -- | Helper function to create an executable component name. exe :: String -> ComponentName diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 93207511ea3..96f842b4d80 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -2,72 +2,86 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | The test monad -module Test.Cabal.Monad ( - -- * High-level runners - setupAndCabalTest, - setupTest, - cabalTest, - cabalTest', +module Test.Cabal.Monad + ( -- * High-level runners + setupAndCabalTest + , setupTest + , cabalTest + , cabalTest' + -- * The monad - TestM, - runTestM, + , TestM + , runTestM + -- * Helper functions - programPathM, - requireProgramM, - isAvailableProgram, - hackageRepoToolProgram, - gitProgram, - cabalProgram, - diffProgram, - python3Program, + , programPathM + , requireProgramM + , isAvailableProgram + , hackageRepoToolProgram + , gitProgram + , cabalProgram + , diffProgram + , python3Program + -- * The test environment - TestEnv(..), - getTestEnv, + , TestEnv (..) + , getTestEnv + -- * Recording mode - RecordMode(..), - testRecordMode, + , RecordMode (..) + , testRecordMode + -- * Derived values from 'TestEnv' - testCurrentDir, - testWorkDir, - testPrefixDir, - testDistDir, - testPackageDbDir, - testRepoDir, - testKeysDir, - testSourceCopyDir, - testCabalDir, - testUserCabalConfigFile, - testActualFile, + , testCurrentDir + , testWorkDir + , testPrefixDir + , testDistDir + , testPackageDbDir + , testRepoDir + , testKeysDir + , testSourceCopyDir + , testCabalDir + , testUserCabalConfigFile + , testActualFile + -- * Skipping tests - skip, - skipIf, - skipUnless, + , skip + , skipIf + , skipUnless + -- * Known broken tests - expectedBroken, - unexpectedSuccess, - -- whenHasSharedLibraries, + , expectedBroken + , unexpectedSuccess + -- whenHasSharedLibraries, + -- * Arguments (TODO: move me) - CommonArgs(..), - renderCommonArgs, - commonArgParser, + , CommonArgs (..) + , renderCommonArgs + , commonArgParser + -- * Version Constants - cabalVersionLibrary, -) where + , cabalVersionLibrary + ) where -import Test.Cabal.Script -import Test.Cabal.Plan import Test.Cabal.OutputNormalizer +import Test.Cabal.Plan +import Test.Cabal.Script import Test.Cabal.TestCode import Distribution.Simple.Compiler - ( PackageDBStack, PackageDB(..), compilerFlavor - , Compiler, compilerVersion ) -import Distribution.System -import Distribution.Simple.Program.Db -import Distribution.Simple.Program + ( Compiler + , PackageDB (..) + , PackageDBStack + , compilerFlavor + , compilerVersion + ) import Distribution.Simple.Configure - ( configCompilerEx ) + ( configCompilerEx + ) +import Distribution.Simple.Program +import Distribution.Simple.Program.Db import qualified Distribution.Simple.Utils as U (cabalVersion) +import Distribution.System import Distribution.Text import Distribution.Verbosity @@ -76,13 +90,14 @@ import Distribution.Version #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -import Data.Monoid (mempty) +import Control.Applicative import qualified Control.Exception as E import Control.Monad -import Control.Monad.Trans.Reader import Control.Monad.IO.Class +import Control.Monad.Trans.Reader import Data.Maybe -import Control.Applicative +import Data.Monoid (mempty) +import Options.Applicative import System.Directory import System.Exit import System.FilePath @@ -90,74 +105,89 @@ import System.IO import System.IO.Error (isDoesNotExistError) import System.IO.Temp (withSystemTempDirectory) import System.Process hiding (env) -import Options.Applicative -data CommonArgs = CommonArgs { - argCabalInstallPath :: Maybe FilePath, - argGhcPath :: Maybe FilePath, - argHackageRepoToolPath :: Maybe FilePath, - argHaddockPath :: Maybe FilePath, - argAccept :: Bool, - argSkipSetupTests :: Bool - } +data CommonArgs = CommonArgs + { argCabalInstallPath :: Maybe FilePath + , argGhcPath :: Maybe FilePath + , argHackageRepoToolPath :: Maybe FilePath + , argHaddockPath :: Maybe FilePath + , argAccept :: Bool + , argSkipSetupTests :: Bool + } commonArgParser :: Parser CommonArgs -commonArgParser = CommonArgs - <$> optional (option str - ( help "Path to cabal-install executable to test. If omitted, tests involving cabal-install are skipped!" - <> long "with-cabal" - <> metavar "PATH" - )) - <*> optional (option str - ( help "GHC to ask Cabal to use via --with-ghc flag" - <> short 'w' - <> long "with-ghc" - <> metavar "PATH" - )) - <*> optional (option str - ( help "Path to hackage-repo-tool to use for repository manipulation" - <> long "with-hackage-repo-tool" - <> metavar "PATH" - )) - <*> optional (option str - ( help "Path to haddock to use for --with-haddock flag" - <> long "with-haddock" - <> metavar "PATH" - )) +commonArgParser = + CommonArgs + <$> optional + ( option + str + ( help "Path to cabal-install executable to test. If omitted, tests involving cabal-install are skipped!" + <> long "with-cabal" + <> metavar "PATH" + ) + ) + <*> optional + ( option + str + ( help "GHC to ask Cabal to use via --with-ghc flag" + <> short 'w' + <> long "with-ghc" + <> metavar "PATH" + ) + ) + <*> optional + ( option + str + ( help "Path to hackage-repo-tool to use for repository manipulation" + <> long "with-hackage-repo-tool" + <> metavar "PATH" + ) + ) + <*> optional + ( option + str + ( help "Path to haddock to use for --with-haddock flag" + <> long "with-haddock" + <> metavar "PATH" + ) + ) <*> switch - ( long "accept" - <> help "Accept output" - ) + ( long "accept" + <> help "Accept output" + ) <*> switch (long "skip-setup-tests" <> help "Skip setup tests") renderCommonArgs :: CommonArgs -> [String] renderCommonArgs args = - maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++ - maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) ++ - maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args) ++ - maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++ - (if argAccept args then ["--accept"] else []) ++ - (if argSkipSetupTests args then ["--skip-setup-tests"] else []) - -data TestArgs = TestArgs { - testArgDistDir :: FilePath, - testArgScriptPath :: FilePath, - testCommonArgs :: CommonArgs - } + maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) + ++ maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) + ++ maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args) + ++ maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) + ++ (if argAccept args then ["--accept"] else []) + ++ (if argSkipSetupTests args then ["--skip-setup-tests"] else []) + +data TestArgs = TestArgs + { testArgDistDir :: FilePath + , testArgScriptPath :: FilePath + , testCommonArgs :: CommonArgs + } testArgParser :: Parser TestArgs -testArgParser = TestArgs - <$> option str - ( help "Build directory of cabal-testsuite" - <> long "builddir" - <> metavar "DIR") - <*> argument str ( metavar "FILE") +testArgParser = + TestArgs + <$> option + str + ( help "Build directory of cabal-testsuite" + <> long "builddir" + <> metavar "DIR" + ) + <*> argument str (metavar "FILE") <*> commonArgParser skip :: String -> TestM () skip reason = liftIO $ do - putStrLn ("SKIP " ++ reason) - E.throwIO (TestCodeSkip reason) + putStrLn ("SKIP " ++ reason) + E.throwIO (TestCodeSkip reason) skipIf :: String -> Bool -> TestM () skipIf reason b = when b (skip reason) @@ -167,40 +197,41 @@ skipUnless reason b = unless b (skip reason) expectedBroken :: TestM () expectedBroken = liftIO $ do - putStrLn "EXPECTED FAIL" - E.throwIO TestCodeKnownFail + putStrLn "EXPECTED FAIL" + E.throwIO TestCodeKnownFail unexpectedSuccess :: TestM () unexpectedSuccess = liftIO $ do - putStrLn "UNEXPECTED OK" - E.throwIO TestCodeUnexpectedOk + putStrLn "UNEXPECTED OK" + E.throwIO TestCodeUnexpectedOk trySkip :: IO a -> IO (Either String a) -trySkip m = fmap Right m `E.catch` \e -> case e of +trySkip m = + fmap Right m `E.catch` \e -> case e of TestCodeSkip msg -> return (Left msg) - _ -> E.throwIO e + _ -> E.throwIO e setupAndCabalTest :: TestM () -> IO () setupAndCabalTest m = do - r1 <- trySkip (setupTest m) - r2 <- trySkip (cabalTest' "cabal" m) - case (r1, r2) of - (Left msg1, Left msg2) -> E.throwIO (TestCodeSkip (msg1 ++ "; " ++ msg2)) - _ -> return () + r1 <- trySkip (setupTest m) + r2 <- trySkip (cabalTest' "cabal" m) + case (r1, r2) of + (Left msg1, Left msg2) -> E.throwIO (TestCodeSkip (msg1 ++ "; " ++ msg2)) + _ -> return () setupTest :: TestM () -> IO () setupTest m = runTestM "" $ do - env <- getTestEnv - skipIf "setup test" (testSkipSetupTests env) - m + env <- getTestEnv + skipIf "setup test" (testSkipSetupTests env) + m cabalTest :: TestM () -> IO () cabalTest = cabalTest' "" cabalTest' :: String -> TestM () -> IO () cabalTest' mode m = runTestM mode $ do - skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram - withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m + skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram + withReaderT (\nenv -> nenv{testCabalInstallAsSetup = True}) m type TestM = ReaderT TestEnv IO @@ -211,10 +242,11 @@ hackageRepoToolProgram :: Program hackageRepoToolProgram = simpleProgram "hackage-repo-tool" cabalProgram :: Program -cabalProgram = (simpleProgram "cabal") { - -- Do NOT search for executable named cabal, it's probably - -- not the one you were intending to test - programFindLocation = \_ _ -> return Nothing +cabalProgram = + (simpleProgram "cabal") + { -- Do NOT search for executable named cabal, it's probably + -- not the one you were intending to test + programFindLocation = \_ _ -> return Nothing } diffProgram :: Program @@ -226,322 +258,338 @@ python3Program = simpleProgram "python3" -- | Run a test in the test monad according to program's arguments. runTestM :: String -> TestM a -> IO a runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do - args <- execParser (info testArgParser Data.Monoid.mempty) - let dist_dir = testArgDistDir args - (script_dir0, script_filename) = splitFileName (testArgScriptPath args) - script_base = dropExtensions script_filename - -- Canonicalize this so that it is stable across working directory changes - script_dir <- canonicalizePath script_dir0 - let verbosity = normal -- TODO: configurable - senv <- mkScriptEnv verbosity - -- Add test suite specific programs - let program_db0 = - addKnownPrograms - ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram, python3Program] ++ builtinPrograms) - (runnerProgramDb senv) - -- Reconfigure according to user flags - let cargs = testCommonArgs args - - -- Reconfigure GHC - (comp, platform, program_db2) <- case argGhcPath cargs of - Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0) - Just ghc_path -> do - -- All the things that get updated paths from - -- configCompilerEx. The point is to make sure - -- we reconfigure these when we need them. - let program_db1 = unconfigureProgram "ghc" - . unconfigureProgram "ghc-pkg" - . unconfigureProgram "hsc2hs" - . unconfigureProgram "haddock" - . unconfigureProgram "hpc" - . unconfigureProgram "runghc" - . unconfigureProgram "gcc" - . unconfigureProgram "ld" - . unconfigureProgram "ar" - . unconfigureProgram "strip" - $ program_db0 - -- TODO: this actually leaves a pile of things unconfigured. - -- Optimal strategy for us is to lazily configure them, so - -- we don't pay for things we don't need. A bit difficult - -- to do in the current design. - configCompilerEx - (Just (compilerFlavor (runnerCompiler senv))) - (Just ghc_path) - Nothing - program_db1 - verbosity - - program_db3 <- - reconfigurePrograms verbosity - ([("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] ++ - [("hackage-repo-tool", p) - | p <- maybeToList (argHackageRepoToolPath cargs)] ++ - [("haddock", p) | p <- maybeToList (argHaddockPath cargs)]) - [] -- --prog-options not supported ATM - program_db2 - -- configCompilerEx only marks some programs as known, so to pick - -- them up we must configure them - program_db <- configureAllKnownPrograms verbosity program_db3 - - let ghcAndRunnedGhcAreTheSame :: Bool - ghcAndRunnedGhcAreTheSame = fromMaybe False $ do - ghc_program <- lookupProgram ghcProgram program_db - runner_ghc_program <- lookupProgram ghcProgram (runnerProgramDb senv) - return $ programPath ghc_program == programPath runner_ghc_program - - let db_stack = - case argGhcPath (testCommonArgs args) of - Nothing -> runnerPackageDbStack senv -- NB: canonicalized - -- Can't use the build package db stack since they - -- are all for the wrong versions! TODO: Make - -- this configurable - -- - -- Oleg: if runner ghc and provided ghc are the same, - -- use runnerPackageDbStack. See 'hasCabalForGhc' check. - Just _ - | ghcAndRunnedGhcAreTheSame -> runnerPackageDbStack senv - | otherwise -> [GlobalPackageDB] - env = TestEnv { - testSourceDir = script_dir, - testTmpDir = tmp_dir, - testSubName = script_base, - testMode = mode, - testProgramDb = program_db, - testPlatform = platform, - testCompiler = comp, - testPackageDBStack = db_stack, - testVerbosity = verbosity, - testMtimeChangeDelay = Nothing, - testScriptEnv = senv, - testSetupPath = dist_dir "build" "setup" "setup", - testSkipSetupTests = argSkipSetupTests (testCommonArgs args), - testHaveCabalShared = runnerWithSharedLib senv, - testEnvironment = - -- Try to avoid Unicode output - [ ("LC_ALL", Just "C") - -- Hermetic builds (knot-tied) - , ("HOME", Just (testHomeDir env)) - -- Set CABAL_DIR in addition to HOME, since HOME has no - -- effect on Windows. - , ("CABAL_DIR", Just (testCabalDir env)) - , ("CABAL_CONFIG", Just $ testCabalDir env "config") - ], - testShouldFail = False, - testRelativeCurrentDir = ".", - testHavePackageDb = False, - testHaveRepo = False, - testHaveSourceCopy = False, - testCabalInstallAsSetup = False, - testCabalProjectFile = "cabal.project", - testPlan = Nothing, - testRecordDefaultMode = DoNotRecord, - testRecordUserMode = Nothing, - testSourceCopyRelativeDir = "source" - } - let go = do cleanup - r <- m - check_expect (argAccept (testCommonArgs args)) - return r - runReaderT go env + args <- execParser (info testArgParser Data.Monoid.mempty) + let dist_dir = testArgDistDir args + (script_dir0, script_filename) = splitFileName (testArgScriptPath args) + script_base = dropExtensions script_filename + -- Canonicalize this so that it is stable across working directory changes + script_dir <- canonicalizePath script_dir0 + let verbosity = normal -- TODO: configurable + senv <- mkScriptEnv verbosity + -- Add test suite specific programs + let program_db0 = + addKnownPrograms + ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram, python3Program] ++ builtinPrograms) + (runnerProgramDb senv) + -- Reconfigure according to user flags + let cargs = testCommonArgs args + + -- Reconfigure GHC + (comp, platform, program_db2) <- case argGhcPath cargs of + Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0) + Just ghc_path -> do + -- All the things that get updated paths from + -- configCompilerEx. The point is to make sure + -- we reconfigure these when we need them. + let program_db1 = + unconfigureProgram "ghc" + . unconfigureProgram "ghc-pkg" + . unconfigureProgram "hsc2hs" + . unconfigureProgram "haddock" + . unconfigureProgram "hpc" + . unconfigureProgram "runghc" + . unconfigureProgram "gcc" + . unconfigureProgram "ld" + . unconfigureProgram "ar" + . unconfigureProgram "strip" + $ program_db0 + -- TODO: this actually leaves a pile of things unconfigured. + -- Optimal strategy for us is to lazily configure them, so + -- we don't pay for things we don't need. A bit difficult + -- to do in the current design. + configCompilerEx + (Just (compilerFlavor (runnerCompiler senv))) + (Just ghc_path) + Nothing + program_db1 + verbosity + + program_db3 <- + reconfigurePrograms + verbosity + ( [("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] + ++ [ ("hackage-repo-tool", p) + | p <- maybeToList (argHackageRepoToolPath cargs) + ] + ++ [("haddock", p) | p <- maybeToList (argHaddockPath cargs)] + ) + [] -- --prog-options not supported ATM + program_db2 + -- configCompilerEx only marks some programs as known, so to pick + -- them up we must configure them + program_db <- configureAllKnownPrograms verbosity program_db3 + + let ghcAndRunnedGhcAreTheSame :: Bool + ghcAndRunnedGhcAreTheSame = fromMaybe False $ do + ghc_program <- lookupProgram ghcProgram program_db + runner_ghc_program <- lookupProgram ghcProgram (runnerProgramDb senv) + return $ programPath ghc_program == programPath runner_ghc_program + + let db_stack = + case argGhcPath (testCommonArgs args) of + Nothing -> runnerPackageDbStack senv -- NB: canonicalized + -- Can't use the build package db stack since they + -- are all for the wrong versions! TODO: Make + -- this configurable + -- + -- Oleg: if runner ghc and provided ghc are the same, + -- use runnerPackageDbStack. See 'hasCabalForGhc' check. + Just _ + | ghcAndRunnedGhcAreTheSame -> runnerPackageDbStack senv + | otherwise -> [GlobalPackageDB] + env = + TestEnv + { testSourceDir = script_dir + , testTmpDir = tmp_dir + , testSubName = script_base + , testMode = mode + , testProgramDb = program_db + , testPlatform = platform + , testCompiler = comp + , testPackageDBStack = db_stack + , testVerbosity = verbosity + , testMtimeChangeDelay = Nothing + , testScriptEnv = senv + , testSetupPath = dist_dir "build" "setup" "setup" + , testSkipSetupTests = argSkipSetupTests (testCommonArgs args) + , testHaveCabalShared = runnerWithSharedLib senv + , testEnvironment = + -- Try to avoid Unicode output + [ ("LC_ALL", Just "C") + , -- Hermetic builds (knot-tied) + ("HOME", Just (testHomeDir env)) + , -- Set CABAL_DIR in addition to HOME, since HOME has no + -- effect on Windows. + ("CABAL_DIR", Just (testCabalDir env)) + , ("CABAL_CONFIG", Just $ testCabalDir env "config") + ] + , testShouldFail = False + , testRelativeCurrentDir = "." + , testHavePackageDb = False + , testHaveRepo = False + , testHaveSourceCopy = False + , testCabalInstallAsSetup = False + , testCabalProjectFile = "cabal.project" + , testPlan = Nothing + , testRecordDefaultMode = DoNotRecord + , testRecordUserMode = Nothing + , testSourceCopyRelativeDir = "source" + } + let go = do + cleanup + r <- m + check_expect (argAccept (testCommonArgs args)) + return r + runReaderT go env where cleanup = do - env <- getTestEnv - onlyIfExists . removeDirectoryRecursive $ testWorkDir env - -- NB: it's important to initialize this ourselves, as - -- the default configuration hardcodes Hackage, which we do - -- NOT want to assume for these tests (no test should - -- hit Hackage.) - liftIO $ createDirectoryIfMissing True (testCabalDir env) - ghc_path <- programPathM ghcProgram - liftIO $ writeFile (testUserCabalConfigFile env) - $ unlines [ "with-compiler: " ++ ghc_path ] + env <- getTestEnv + onlyIfExists . removeDirectoryRecursive $ testWorkDir env + -- NB: it's important to initialize this ourselves, as + -- the default configuration hardcodes Hackage, which we do + -- NOT want to assume for these tests (no test should + -- hit Hackage.) + liftIO $ createDirectoryIfMissing True (testCabalDir env) + ghc_path <- programPathM ghcProgram + liftIO $ + writeFile (testUserCabalConfigFile env) $ + unlines ["with-compiler: " ++ ghc_path] check_expect accept = do - env <- getTestEnv - actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) - expect <- liftIO $ readFileOrEmpty (testExpectFile env) - norm_env <- mkNormalizerEnv - let actual = normalizeOutput norm_env actual_raw - when (words actual /= words expect) $ do - -- First try whitespace insensitive diff - let actual_fp = testNormalizedActualFile env - expect_fp = testNormalizedExpectFile env - liftIO $ writeFile actual_fp actual - liftIO $ writeFile expect_fp expect - liftIO $ putStrLn "Actual output differs from expected:" - b <- diff ["-uw"] expect_fp actual_fp - unless b . void $ diff ["-u"] expect_fp actual_fp - if accept - then do liftIO $ putStrLn "Accepting new output." - liftIO $ writeFileNoCR (testExpectFile env) actual - else liftIO $ exitWith (ExitFailure 1) + env <- getTestEnv + actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) + expect <- liftIO $ readFileOrEmpty (testExpectFile env) + norm_env <- mkNormalizerEnv + let actual = normalizeOutput norm_env actual_raw + when (words actual /= words expect) $ do + -- First try whitespace insensitive diff + let actual_fp = testNormalizedActualFile env + expect_fp = testNormalizedExpectFile env + liftIO $ writeFile actual_fp actual + liftIO $ writeFile expect_fp expect + liftIO $ putStrLn "Actual output differs from expected:" + b <- diff ["-uw"] expect_fp actual_fp + unless b . void $ diff ["-u"] expect_fp actual_fp + if accept + then do + liftIO $ putStrLn "Accepting new output." + liftIO $ writeFileNoCR (testExpectFile env) actual + else liftIO $ exitWith (ExitFailure 1) readFileOrEmpty :: FilePath -> IO String -readFileOrEmpty f = readFile f `E.catch` \e -> - if isDoesNotExistError e - then return "" - else E.throwIO e +readFileOrEmpty f = + readFile f `E.catch` \e -> + if isDoesNotExistError e + then return "" + else E.throwIO e -- | Runs 'diff' with some arguments on two files, outputting the -- diff to stderr, and returning true if the two files differ diff :: [String] -> FilePath -> FilePath -> TestM Bool diff args path1 path2 = do - diff_path <- programPathM diffProgram - (_,_,_,h) <- liftIO $ - createProcess (proc diff_path (args ++ [path1, path2])) { - std_out = UseHandle stderr - } - r <- liftIO $ waitForProcess h - return (r /= ExitSuccess) + diff_path <- programPathM diffProgram + (_, _, _, h) <- + liftIO $ + createProcess + (proc diff_path (args ++ [path1, path2])) + { std_out = UseHandle stderr + } + r <- liftIO $ waitForProcess h + return (r /= ExitSuccess) -- | Write a file with no CRs, always. writeFileNoCR :: FilePath -> String -> IO () writeFileNoCR f s = - withFile f WriteMode $ \h -> do - hSetNewlineMode h noNewlineTranslation - hPutStr h s + withFile f WriteMode $ \h -> do + hSetNewlineMode h noNewlineTranslation + hPutStr h s mkNormalizerEnv :: TestM NormalizerEnv mkNormalizerEnv = do - env <- getTestEnv - ghc_pkg_program <- requireProgramM ghcPkgProgram - -- Arguably we should use Cabal's APIs but I am too lazy - -- to remember what it is - list_out <- liftIO $ readProcess (programPath ghc_pkg_program) - ["list", "--global", "--simple-output"] "" - tmpDir <- liftIO $ getTemporaryDirectory - - return NormalizerEnv { - normalizerRoot - = addTrailingPathSeparator (testSourceDir env), - normalizerTmpDir - = addTrailingPathSeparator (testTmpDir env), - normalizerGblTmpDir - = addTrailingPathSeparator tmpDir, - normalizerGhcVersion - = compilerVersion (testCompiler env), - normalizerKnownPackages - = mapMaybe simpleParse (words list_out), - normalizerPlatform - = testPlatform env, - normalizerCabalVersion - = cabalVersionLibrary - } - where + env <- getTestEnv + ghc_pkg_program <- requireProgramM ghcPkgProgram + -- Arguably we should use Cabal's APIs but I am too lazy + -- to remember what it is + list_out <- + liftIO $ + readProcess + (programPath ghc_pkg_program) + ["list", "--global", "--simple-output"] + "" + tmpDir <- liftIO $ getTemporaryDirectory + + return + NormalizerEnv + { normalizerRoot = + addTrailingPathSeparator (testSourceDir env) + , normalizerTmpDir = + addTrailingPathSeparator (testTmpDir env) + , normalizerGblTmpDir = + addTrailingPathSeparator tmpDir + , normalizerGhcVersion = + compilerVersion (testCompiler env) + , normalizerKnownPackages = + mapMaybe simpleParse (words list_out) + , normalizerPlatform = + testPlatform env + , normalizerCabalVersion = + cabalVersionLibrary + } + where cabalVersionLibrary :: Version cabalVersionLibrary = U.cabalVersion requireProgramM :: Program -> TestM ConfiguredProgram requireProgramM program = do - env <- getTestEnv - (configured_program, _) <- liftIO $ - requireProgram (testVerbosity env) program (testProgramDb env) - return configured_program + env <- getTestEnv + (configured_program, _) <- + liftIO $ + requireProgram (testVerbosity env) program (testProgramDb env) + return configured_program programPathM :: Program -> TestM FilePath programPathM program = do - fmap programPath (requireProgramM program) + fmap programPath (requireProgramM program) isAvailableProgram :: Program -> TestM Bool isAvailableProgram program = do - env <- getTestEnv - case lookupProgram program (testProgramDb env) of + env <- getTestEnv + case lookupProgram program (testProgramDb env) of + Just _ -> return True + Nothing -> do + -- It might not have been configured. Try to configure. + progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env) + case lookupProgram program progdb of Just _ -> return True - Nothing -> do - -- It might not have been configured. Try to configure. - progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env) - case lookupProgram program progdb of - Just _ -> return True - Nothing -> return False + Nothing -> return False -- | Run an IO action, and suppress a "does not exist" error. onlyIfExists :: MonadIO m => IO () -> m () onlyIfExists m = - liftIO $ E.catch m $ \(e :: IOError) -> - unless (isDoesNotExistError e) $ E.throwIO e + liftIO $ E.catch m $ \(e :: IOError) -> + unless (isDoesNotExistError e) $ E.throwIO e data TestEnv = TestEnv - -- UNCHANGING: - - { - -- | Path to the test directory, as specified by path to test - -- script. - testSourceDir :: FilePath - -- | Somewhere to stow temporary files needed by the test. - , testTmpDir :: FilePath - -- | Test sub-name, used to qualify dist/database directory to avoid - -- conflicts. - , testSubName :: String - -- | Test mode, further qualifies multiple invocations of the - -- same test source code. - , testMode :: String - -- | Program database to use when we want ghc, ghc-pkg, etc. - , testProgramDb :: ProgramDb - -- | Compiler we are running tests for - , testCompiler :: Compiler - -- | Platform we are running tests on - , testPlatform :: Platform - -- | Package database stack (actually this changes lol) - , testPackageDBStack :: PackageDBStack - -- | How verbose to be - , testVerbosity :: Verbosity - -- | How long we should 'threadDelay' to make sure the file timestamp is - -- updated correctly for recompilation tests. Nothing if we haven't - -- calibrated yet. - , testMtimeChangeDelay :: Maybe Int - -- | Script environment for runghc - , testScriptEnv :: ScriptEnv - -- | Setup script path - , testSetupPath :: FilePath - -- | Skip Setup tests? - , testSkipSetupTests :: Bool - -- | Do we have shared libraries for the Cabal-under-tests? - -- This is used for example to determine whether we can build - -- detailed-0.9 tests dynamically, since they link against Cabal-under-test. - , testHaveCabalShared :: Bool - - -- CHANGING: - - -- | Environment override - , testEnvironment :: [(String, Maybe String)] - -- | When true, we invert the meaning of command execution failure - , testShouldFail :: Bool - -- | The current working directory, relative to 'testSourceDir' - , testRelativeCurrentDir :: FilePath - -- | Says if we've initialized the per-test package DB - , testHavePackageDb :: Bool - -- | Says if we've setup a repository - , testHaveRepo :: Bool - -- | Says if we've copied the source to a hermetic directory - , testHaveSourceCopy :: Bool - -- | Says if we're testing cabal-install as setup - , testCabalInstallAsSetup :: Bool - -- | Says what cabal.project file to use (probed) - , testCabalProjectFile :: FilePath - -- | Cached record of the plan metadata from a new-build - -- invocation; controlled by 'withPlan'. - , testPlan :: Maybe Plan - -- | If user mode is not set, this is the record mode we default to. - , testRecordDefaultMode :: RecordMode - -- | User explicitly set record mode. Not implemented ATM. - , testRecordUserMode :: Maybe RecordMode - -- | Name of the subdirectory we copied the test's sources to, - -- relative to 'testSourceDir' - , testSourceCopyRelativeDir :: FilePath - } - deriving Show + -- UNCHANGING: + + { testSourceDir :: FilePath + -- ^ Path to the test directory, as specified by path to test + -- script. + , testTmpDir :: FilePath + -- ^ Somewhere to stow temporary files needed by the test. + , testSubName :: String + -- ^ Test sub-name, used to qualify dist/database directory to avoid + -- conflicts. + , testMode :: String + -- ^ Test mode, further qualifies multiple invocations of the + -- same test source code. + , testProgramDb :: ProgramDb + -- ^ Program database to use when we want ghc, ghc-pkg, etc. + , testCompiler :: Compiler + -- ^ Compiler we are running tests for + , testPlatform :: Platform + -- ^ Platform we are running tests on + , testPackageDBStack :: PackageDBStack + -- ^ Package database stack (actually this changes lol) + , testVerbosity :: Verbosity + -- ^ How verbose to be + , testMtimeChangeDelay :: Maybe Int + -- ^ How long we should 'threadDelay' to make sure the file timestamp is + -- updated correctly for recompilation tests. Nothing if we haven't + -- calibrated yet. + , testScriptEnv :: ScriptEnv + -- ^ Script environment for runghc + , testSetupPath :: FilePath + -- ^ Setup script path + , testSkipSetupTests :: Bool + -- ^ Skip Setup tests? + , testHaveCabalShared :: Bool + -- ^ Do we have shared libraries for the Cabal-under-tests? + -- This is used for example to determine whether we can build + -- detailed-0.9 tests dynamically, since they link against Cabal-under-test. + , -- CHANGING: + + testEnvironment :: [(String, Maybe String)] + -- ^ Environment override + , testShouldFail :: Bool + -- ^ When true, we invert the meaning of command execution failure + , testRelativeCurrentDir :: FilePath + -- ^ The current working directory, relative to 'testSourceDir' + , testHavePackageDb :: Bool + -- ^ Says if we've initialized the per-test package DB + , testHaveRepo :: Bool + -- ^ Says if we've setup a repository + , testHaveSourceCopy :: Bool + -- ^ Says if we've copied the source to a hermetic directory + , testCabalInstallAsSetup :: Bool + -- ^ Says if we're testing cabal-install as setup + , testCabalProjectFile :: FilePath + -- ^ Says what cabal.project file to use (probed) + , testPlan :: Maybe Plan + -- ^ Cached record of the plan metadata from a new-build + -- invocation; controlled by 'withPlan'. + , testRecordDefaultMode :: RecordMode + -- ^ If user mode is not set, this is the record mode we default to. + , testRecordUserMode :: Maybe RecordMode + -- ^ User explicitly set record mode. Not implemented ATM. + , testSourceCopyRelativeDir :: FilePath + -- ^ Name of the subdirectory we copied the test's sources to, + -- relative to 'testSourceDir' + } + deriving (Show) testRecordMode :: TestEnv -> RecordMode testRecordMode env = fromMaybe (testRecordDefaultMode env) (testRecordUserMode env) data RecordMode = DoNotRecord | RecordMarked | RecordAll - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) getTestEnv :: TestM TestEnv getTestEnv = ask ------------------------------------------------------------------------ + -- * Directories -- | The absolute path to the root of the package directory; it's @@ -549,9 +597,11 @@ getTestEnv = ask -- calls to be. testCurrentDir :: TestEnv -> FilePath testCurrentDir env = - (if testHaveSourceCopy env - then testSourceCopyDir env - else testSourceDir env) testRelativeCurrentDir env + ( if testHaveSourceCopy env + then testSourceCopyDir env + else testSourceDir env + ) + testRelativeCurrentDir env testName :: TestEnv -> String testName env = testSubName env <.> testMode env @@ -561,7 +611,7 @@ testName env = testSubName env <.> testMode env -- subtests.) To clean, you ONLY need to delete this directory. testWorkDir :: TestEnv -> FilePath testWorkDir env = - testSourceDir env (testName env <.> "dist") + testSourceDir env (testName env <.> "dist") -- | The absolute prefix where installs go. testPrefixDir :: TestEnv -> FilePath diff --git a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs index a977dc7e305..ec2888b57fc 100644 --- a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs +++ b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs @@ -1,85 +1,96 @@ -module Test.Cabal.OutputNormalizer ( - NormalizerEnv (..), - normalizeOutput, - ) where +module Test.Cabal.OutputNormalizer + ( NormalizerEnv (..) + , normalizeOutput + ) where import Data.Monoid (Endo (..)) -import Distribution.Version -import Distribution.Text -import Distribution.Pretty import Distribution.Package +import Distribution.Pretty import Distribution.System +import Distribution.Text +import Distribution.Version +import Data.Array ((!)) import Text.Regex.Base import Text.Regex.TDFA -import Data.Array ((!)) import qualified Data.Foldable as F normalizeOutput :: NormalizerEnv -> String -> String normalizeOutput nenv = - -- Munge away .exe suffix on filenames (Windows) - resub "([A-Za-z0-9.-]+)\\.exe" "\\1" + -- Munge away .exe suffix on filenames (Windows) + resub "([A-Za-z0-9.-]+)\\.exe" "\\1" -- Normalize backslashes to forward slashes to normalize -- file paths - . map (\c -> if c == '\\' then '/' else c) + . map (\c -> if c == '\\' then '/' else c) -- Install path frequently has architecture specific elements, so -- nub it out - . resub "Installing (.+) in .+" "Installing \\1 in " + . resub "Installing (.+) in .+" "Installing \\1 in " -- Things that look like libraries - . resub "libHS[A-Za-z0-9.-]+\\.(so|dll|a|dynlib)" "" + . resub "libHS[A-Za-z0-9.-]+\\.(so|dll|a|dynlib)" "" -- look for PackageHash directories - . resub "/(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}/" - "/-/" + . resub + "/(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}/" + "/-/" -- This is dumb but I don't feel like pulling in another dep for -- string search-replace. Make sure we do this before backslash -- normalization! - . resub (posixRegexEscape (normalizerGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" -- note, after TMPDIR - . resub (posixRegexEscape (normalizerRoot nenv)) "/" - . resub (posixRegexEscape (normalizerTmpDir nenv)) "/" - . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv))) + . resub (posixRegexEscape (normalizerGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" -- note, after TMPDIR + . resub (posixRegexEscape (normalizerRoot nenv)) "/" + . resub (posixRegexEscape (normalizerTmpDir nenv)) "/" + . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv))) -- Look for 0.1/installed-0d6uzW7Ubh1Fb4TB5oeQ3G -- These installed packages will vary depending on GHC version -- Apply this before packageIdRegex, otherwise this regex doesn't match. - . resub "[0-9]+(\\.[0-9]+)*/installed-[A-Za-z0-9.+]+" - "/installed-" + . resub + "[0-9]+(\\.[0-9]+)*/installed-[A-Za-z0-9.+]+" + "/installed-" -- incoming directories in the store - . resub "/incoming/new-[0-9]+" - "/incoming/new-" + . resub + "/incoming/new-[0-9]+" + "/incoming/new-" -- Normalize architecture - . resub (posixRegexEscape (display (normalizerPlatform nenv))) "" - . normalizeBuildInfoJson + . resub (posixRegexEscape (display (normalizerPlatform nenv))) "" + . normalizeBuildInfoJson -- Some GHC versions are chattier than others - . resub "^ignoring \\(possibly broken\\) abi-depends field for packages" "" + . resub "^ignoring \\(possibly broken\\) abi-depends field for packages" "" -- Normalize the current GHC version. Apply this BEFORE packageIdRegex, -- which will pick up the install ghc library (which doesn't have the -- date glob). - . (if normalizerGhcVersion nenv /= nullVersion - then resub (posixRegexEscape (display (normalizerGhcVersion nenv)) - -- Also glob the date, for nightly GHC builds - ++ "(\\.[0-9]+)?") - "" - else id) - -- hackage-security locks occur non-deterministically - . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" "" + . ( if normalizerGhcVersion nenv /= nullVersion + then + resub + ( posixRegexEscape (display (normalizerGhcVersion nenv)) + -- Also glob the date, for nightly GHC builds + ++ "(\\.[0-9]+)?" + ) + "" + else id + ) + -- hackage-security locks occur non-deterministically + . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" "" where packageIdRegex pid = - resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") - (prettyShow (packageName pid) ++ "-") + resub + (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") + (prettyShow (packageName pid) ++ "-") -- 'build-info.json' contains a plethora of host system specific information. -- -- This must happen before the root-dir normalisation. normalizeBuildInfoJson = - -- Remove ghc path from show-build-info output - resub ("\"path\":\"[^\"]*\"}") - "\"path\":\"\"}" + -- Remove ghc path from show-build-info output + resub + ("\"path\":\"[^\"]*\"}") + "\"path\":\"\"}" -- Remove cabal version output from show-build-info output - . resub ("{\"cabal-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") - "{\"cabal-version\":\"\"" - . resub ("{\"cabal-lib-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") - "{\"cabal-lib-version\":\"\"" + . resub + ("{\"cabal-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") + "{\"cabal-version\":\"\"" + . resub + ("{\"cabal-lib-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") + "{\"cabal-lib-version\":\"\"" -- Remove the package id for stuff such as: -- > "-package-id","base-4.14.0.0-" -- and replace it with: @@ -91,18 +102,19 @@ normalizeOutput nenv = -- -- This makes it impossible to have a stable package id, thus remove it completely. -- Check manually in your test-cases if the package-id needs to be verified. - . resub ("\"-package-id\",\"([^\"]*)\"") - "\"-package-id\",\"\"" + . resub + ("\"-package-id\",\"([^\"]*)\"") + "\"-package-id\",\"\"" data NormalizerEnv = NormalizerEnv - { normalizerRoot :: FilePath - , normalizerTmpDir :: FilePath - , normalizerGblTmpDir :: FilePath - , normalizerGhcVersion :: Version - , normalizerKnownPackages :: [PackageId] - , normalizerPlatform :: Platform - , normalizerCabalVersion :: Version - } + { normalizerRoot :: FilePath + , normalizerTmpDir :: FilePath + , normalizerGblTmpDir :: FilePath + , normalizerGhcVersion :: Version + , normalizerKnownPackages :: [PackageId] + , normalizerPlatform :: Platform + , normalizerCabalVersion :: Version + } posixSpecialChars :: [Char] posixSpecialChars = ".^$*+?()[{\\|" @@ -116,35 +128,40 @@ posixRegexEscape = concatMap (\c -> if c `elem` posixSpecialChars then ['\\', c] resub :: String {- search -} -> String {- replace -} -> String {- input -} -> String resub _ _ "" = "" resub regexp repl inp = - let compile _i str [] = \ _m -> (str ++) + let compile _i str [] = \_m -> (str ++) compile i str (("\\", (off, len)) : rest) = let i' = off + len pre = take (off - i) str str' = drop (i' - i) str - in if null str' then \ _m -> (pre ++) . ('\\' :) - else \ m -> (pre ++) . ('\\' :) . compile i' str' rest m + in if null str' + then \_m -> (pre ++) . ('\\' :) + else \m -> (pre ++) . ('\\' :) . compile i' str' rest m compile i str ((xstr, (off, len)) : rest) = let i' = off + len pre = take (off - i) str str' = drop (i' - i) str x = read xstr - in if null str' then \ m -> (pre++) . (fst (m ! x) ++) - else \ m -> (pre ++) . (fst (m ! x) ++) . compile i' str' rest m + in if null str' + then \m -> (pre ++) . (fst (m ! x) ++) + else \m -> (pre ++) . (fst (m ! x) ++) . compile i' str' rest m compiled :: MatchText String -> String -> String - compiled = compile 0 repl findrefs where - -- bre matches a backslash then capture either a backslash or some digits - bre = mkRegex "\\\\(\\\\|[0-9]+)" - findrefs = map (\m -> (fst (m ! 1), snd (m ! 0))) (matchAllText bre repl) + compiled = compile 0 repl findrefs + where + -- bre matches a backslash then capture either a backslash or some digits + bre = mkRegex "\\\\(\\\\|[0-9]+)" + findrefs = map (\m -> (fst (m ! 1), snd (m ! 0))) (matchAllText bre repl) go _i str [] = str go i str (m : ms) = let (_, (off, len)) = m ! 0 i' = off + len pre = take (off - i) str str' = drop (i' - i) str - in if null str' then pre ++ compiled m "" - else pre ++ compiled m (go i' str' ms) - in go 0 inp (matchAllText (mkRegex regexp) inp) + in if null str' + then pre ++ compiled m "" + else pre ++ compiled m (go i' str' ms) + in go 0 inp (matchAllText (mkRegex regexp) inp) mkRegex :: String -> Regex mkRegex s = makeRegexOpts opt defaultExecOpt s - where opt = defaultCompOpt { newSyntax = True, multiline = True } + where + opt = defaultCompOpt{newSyntax = True, multiline = True} diff --git a/cabal-testsuite/src/Test/Cabal/Plan.hs b/cabal-testsuite/src/Test/Cabal/Plan.hs index 274f11f83a6..ed609d86490 100644 --- a/cabal-testsuite/src/Test/Cabal/Plan.hs +++ b/cabal-testsuite/src/Test/Cabal/Plan.hs @@ -1,140 +1,169 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Utilities for understanding @plan.json@. -module Test.Cabal.Plan ( - Plan, - DistDirOrBinFile(..), - planDistDir, - buildInfoFile, -) where +module Test.Cabal.Plan + ( Plan + , DistDirOrBinFile (..) + , planDistDir + , buildInfoFile + ) where +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as Text +import Distribution.Package import Distribution.Parsec (simpleParsec) import Distribution.Pretty (prettyShow) import Distribution.Types.ComponentName -import Distribution.Package -import qualified Data.Text as Text -import Data.Aeson -import Data.Aeson.Types -import Control.Monad -- TODO: index this -data Plan = Plan { planInstallPlan :: [InstallItem] } - deriving Show +data Plan = Plan {planInstallPlan :: [InstallItem]} + deriving (Show) data InstallItem - = APreExisting - | AConfiguredGlobal ConfiguredGlobal - | AConfiguredInplace ConfiguredInplace - deriving Show + = APreExisting + | AConfiguredGlobal ConfiguredGlobal + | AConfiguredInplace ConfiguredInplace + deriving (Show) -- local or inplace package data ConfiguredInplace = ConfiguredInplace - { configuredInplaceDistDir :: FilePath - , configuredInplaceBuildInfo :: Maybe FilePath - , configuredInplacePackageName :: PackageName - , configuredInplaceComponentName :: Maybe ComponentName } - deriving Show + { configuredInplaceDistDir :: FilePath + , configuredInplaceBuildInfo :: Maybe FilePath + , configuredInplacePackageName :: PackageName + , configuredInplaceComponentName :: Maybe ComponentName + } + deriving (Show) data ConfiguredGlobal = ConfiguredGlobal - { configuredGlobalBinFile :: Maybe FilePath - , configuredGlobalPackageName :: PackageName - , configuredGlobalComponentName :: Maybe ComponentName } - deriving Show + { configuredGlobalBinFile :: Maybe FilePath + , configuredGlobalPackageName :: PackageName + , configuredGlobalComponentName :: Maybe ComponentName + } + deriving (Show) instance FromJSON Plan where - parseJSON (Object v) = fmap Plan (v .: "install-plan") - parseJSON invalid = typeMismatch "Plan" invalid + parseJSON (Object v) = fmap Plan (v .: "install-plan") + parseJSON invalid = typeMismatch "Plan" invalid instance FromJSON InstallItem where - parseJSON obj@(Object v) = do - t <- v .: "type" - case t :: String of - "pre-existing" -> return APreExisting - "configured" -> do - s <- v .: "style" - case s :: String of - "global" -> AConfiguredGlobal `fmap` parseJSON obj - "inplace" -> AConfiguredInplace `fmap` parseJSON obj - "local" -> AConfiguredInplace `fmap` parseJSON obj - _ -> fail $ "unrecognized value of 'style' field: " ++ s - _ -> fail "unrecognized value of 'type' field" - parseJSON invalid = typeMismatch "InstallItem" invalid + parseJSON obj@(Object v) = do + t <- v .: "type" + case t :: String of + "pre-existing" -> return APreExisting + "configured" -> do + s <- v .: "style" + case s :: String of + "global" -> AConfiguredGlobal `fmap` parseJSON obj + "inplace" -> AConfiguredInplace `fmap` parseJSON obj + "local" -> AConfiguredInplace `fmap` parseJSON obj + _ -> fail $ "unrecognized value of 'style' field: " ++ s + _ -> fail "unrecognized value of 'type' field" + parseJSON invalid = typeMismatch "InstallItem" invalid instance FromJSON ConfiguredInplace where - parseJSON (Object v) = do - dist_dir <- v .: "dist-dir" - build_info <- v .:? "build-info" - pkg_name <- v .: "pkg-name" - component_name <- v .:? "component-name" - return (ConfiguredInplace dist_dir build_info pkg_name component_name) - parseJSON invalid = typeMismatch "ConfiguredInplace" invalid + parseJSON (Object v) = do + dist_dir <- v .: "dist-dir" + build_info <- v .:? "build-info" + pkg_name <- v .: "pkg-name" + component_name <- v .:? "component-name" + return (ConfiguredInplace dist_dir build_info pkg_name component_name) + parseJSON invalid = typeMismatch "ConfiguredInplace" invalid instance FromJSON ConfiguredGlobal where - parseJSON (Object v) = do - bin_file <- v .:? "bin-file" - pkg_name <- v .: "pkg-name" - component_name <- v .:? "component-name" - return (ConfiguredGlobal bin_file pkg_name component_name) - parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid + parseJSON (Object v) = do + bin_file <- v .:? "bin-file" + pkg_name <- v .: "pkg-name" + component_name <- v .:? "component-name" + return (ConfiguredGlobal bin_file pkg_name component_name) + parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid instance FromJSON PackageName where - parseJSON (String t) = return (mkPackageName (Text.unpack t)) - parseJSON invalid = typeMismatch "PackageName" invalid + parseJSON (String t) = return (mkPackageName (Text.unpack t)) + parseJSON invalid = typeMismatch "PackageName" invalid instance FromJSON ComponentName where - parseJSON (String t) = - case simpleParsec s of - Nothing -> fail ("could not parse component-name: " ++ s) - Just r -> return r - where s = Text.unpack t - parseJSON invalid = typeMismatch "ComponentName" invalid + parseJSON (String t) = + case simpleParsec s of + Nothing -> fail ("could not parse component-name: " ++ s) + Just r -> return r + where + s = Text.unpack t + parseJSON invalid = typeMismatch "ComponentName" invalid data DistDirOrBinFile = DistDir FilePath | BinFile FilePath planDistDir :: Plan -> PackageName -> ComponentName -> DistDirOrBinFile planDistDir plan pkg_name cname = - case concatMap p (planInstallPlan plan) of - [x] -> x - [] -> error $ "planDistDir: component " ++ prettyShow cname - ++ " of package " ++ prettyShow pkg_name ++ " either does not" - ++ " exist in the install plan or does not have a dist-dir nor bin-file" - _ -> error $ "planDistDir: found multiple copies of component " ++ prettyShow cname - ++ " of package " ++ prettyShow pkg_name ++ " in install plan" + case concatMap p (planInstallPlan plan) of + [x] -> x + [] -> + error $ + "planDistDir: component " + ++ prettyShow cname + ++ " of package " + ++ prettyShow pkg_name + ++ " either does not" + ++ " exist in the install plan or does not have a dist-dir nor bin-file" + _ -> + error $ + "planDistDir: found multiple copies of component " + ++ prettyShow cname + ++ " of package " + ++ prettyShow pkg_name + ++ " in install plan" where - p APreExisting = [] + p APreExisting = [] p (AConfiguredGlobal conf) = do - guard (configuredGlobalPackageName conf == pkg_name) - guard $ case configuredGlobalComponentName conf of - Nothing -> True - Just cname' -> cname == cname' - case configuredGlobalBinFile conf of - Nothing -> [] - Just bin_file -> return $ BinFile bin_file + guard (configuredGlobalPackageName conf == pkg_name) + guard $ case configuredGlobalComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + case configuredGlobalBinFile conf of + Nothing -> [] + Just bin_file -> return $ BinFile bin_file p (AConfiguredInplace conf) = do - guard (configuredInplacePackageName conf == pkg_name) - guard $ case configuredInplaceComponentName conf of - Nothing -> True - Just cname' -> cname == cname' - return $ DistDir $ configuredInplaceDistDir conf + guard (configuredInplacePackageName conf == pkg_name) + guard $ case configuredInplaceComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + return $ DistDir $ configuredInplaceDistDir conf buildInfoFile :: Plan -> PackageName -> ComponentName -> FilePath buildInfoFile plan pkg_name cname = - case concatMap p (planInstallPlan plan) of - [Just x] -> x - [Nothing] -> error $ "buildInfoFile: component " ++ prettyShow cname - ++ " of package " ++ prettyShow pkg_name ++ " does not" - ++ " have a build info-file" - [] -> error $ "buildInfoFile: component " ++ prettyShow cname - ++ " of package " ++ prettyShow pkg_name ++ " either does not" - ++ " exist in the install plan or build info-file" - _ -> error $ "buildInfoFile: found multiple copies of component " ++ prettyShow cname - ++ " of package " ++ prettyShow pkg_name ++ " in install plan" + case concatMap p (planInstallPlan plan) of + [Just x] -> x + [Nothing] -> + error $ + "buildInfoFile: component " + ++ prettyShow cname + ++ " of package " + ++ prettyShow pkg_name + ++ " does not" + ++ " have a build info-file" + [] -> + error $ + "buildInfoFile: component " + ++ prettyShow cname + ++ " of package " + ++ prettyShow pkg_name + ++ " either does not" + ++ " exist in the install plan or build info-file" + _ -> + error $ + "buildInfoFile: found multiple copies of component " + ++ prettyShow cname + ++ " of package " + ++ prettyShow pkg_name + ++ " in install plan" where - p APreExisting = [] + p APreExisting = [] p (AConfiguredGlobal _) = [] p (AConfiguredInplace conf) = do - guard (configuredInplacePackageName conf == pkg_name) - guard $ case configuredInplaceComponentName conf of - Nothing -> True - Just cname' -> cname == cname' - return $ configuredInplaceBuildInfo conf + guard (configuredInplacePackageName conf == pkg_name) + guard $ case configuredInplaceComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + return $ configuredInplaceBuildInfo conf diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 081dd935eeb..28adc3ad7ae 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -1,70 +1,71 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Generally useful definitions that we expect most test scripts -- to use. -module Test.Cabal.Prelude ( - module Test.Cabal.Prelude, - module Test.Cabal.Monad, - module Test.Cabal.Run, - module System.FilePath, - module Control.Monad, - module Control.Monad.IO.Class, - module Distribution.Version, - module Distribution.Simple.Program, -) where +module Test.Cabal.Prelude + ( module Test.Cabal.Prelude + , module Test.Cabal.Monad + , module Test.Cabal.Run + , module System.FilePath + , module Control.Monad + , module Control.Monad.IO.Class + , module Distribution.Version + , module Distribution.Simple.Program + ) where -import Test.Cabal.Script -import Test.Cabal.Run import Test.Cabal.Monad import Test.Cabal.Plan +import Test.Cabal.Run +import Test.Cabal.Script import Distribution.Compat.Time (calibrateMtimeChangeDelay) -import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec (eitherParsec) +import Distribution.Simple.Compiler (PackageDB (..), PackageDBStack) +import Distribution.Simple.Configure + ( getPersistBuildConfig + ) import Distribution.Simple.PackageDescription (readGenericPackageDescription) -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db import Distribution.Simple.Program -import Distribution.System (OS(Windows,Linux,OSX), Arch(JavaScript), buildOS, buildArch) import Distribution.Simple.Utils - ( withFileContents, withTempDirectory, tryFindPackageDesc ) -import Distribution.Simple.Configure - ( getPersistBuildConfig ) -import Distribution.Version -import Distribution.Package -import Distribution.Parsec (eitherParsec) -import Distribution.Types.UnqualComponentName + ( tryFindPackageDesc + , withFileContents + , withTempDirectory + ) +import Distribution.System (Arch (JavaScript), OS (Linux, OSX, Windows), buildArch, buildOS) import Distribution.Types.LocalBuildInfo -import Distribution.PackageDescription import Distribution.Verbosity (normal) +import Distribution.Version import Distribution.Compat.Stack import Text.Regex.TDFA ((=~)) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (waitCatch, withAsync) -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as BSL -import Control.Monad (unless, when, void, forM_, liftM2, liftM4) -import Control.Monad.Trans.Reader (withReaderT, runReaderT) +import Control.Monad (forM_, liftM2, liftM4, unless, void, when) import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Reader (runReaderT, withReaderT) +import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Aeson as JSON import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as C -import Data.List (isInfixOf, stripPrefix, isPrefixOf, intercalate) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import Data.List (intercalate, isInfixOf, isPrefixOf, stripPrefix) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Maybe (mapMaybe, fromMaybe) -import System.Exit (ExitCode (..)) -import System.FilePath ((), takeExtensions, takeDrive, takeDirectory, normalise, splitPath, joinPath, splitFileName, (<.>), dropTrailingPathSeparator) -import Control.Concurrent (threadDelay) -import qualified Data.Char as Char -import System.Directory (getTemporaryDirectory, getCurrentDirectory, canonicalizePath, copyFile, copyFile, doesDirectoryExist, doesFileExist, createDirectoryIfMissing, getDirectoryContents, listDirectory) -import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) +import Data.Maybe (fromMaybe, mapMaybe) import Network.Wait (waitTcpVerbose) +import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents, getTemporaryDirectory, listDirectory) +import System.Exit (ExitCode (..)) +import System.FilePath (dropTrailingPathSeparator, joinPath, normalise, splitFileName, splitPath, takeDirectory, takeDrive, takeExtensions, (<.>), ()) #ifndef mingw32_HOST_OS import Control.Monad.Catch ( bracket_ ) @@ -74,49 +75,56 @@ import System.Posix.Resource #endif ------------------------------------------------------------------------ + -- * Utilities runM :: FilePath -> [String] -> Maybe String -> TestM Result runM path args input = do - env <- getTestEnv - r <- liftIO $ run (testVerbosity env) - (Just (testCurrentDir env)) - (testEnvironment env) - path - args - input - recordLog r - requireSuccess r + env <- getTestEnv + r <- + liftIO $ + run + (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + path + args + input + recordLog r + requireSuccess r runProgramM :: Program -> [String] -> Maybe String -> TestM Result runProgramM prog args input = do - configured_prog <- requireProgramM prog - -- TODO: Consider also using other information from - -- ConfiguredProgram, e.g., env and args - runM (programPath configured_prog) args input + configured_prog <- requireProgramM prog + -- TODO: Consider also using other information from + -- ConfiguredProgram, e.g., env and args + runM (programPath configured_prog) args input getLocalBuildInfoM :: TestM LocalBuildInfo getLocalBuildInfoM = do - env <- getTestEnv - liftIO $ getPersistBuildConfig (testDistDir env) + env <- getTestEnv + liftIO $ getPersistBuildConfig (testDistDir env) ------------------------------------------------------------------------ + -- * Changing parameters withDirectory :: FilePath -> TestM a -> TestM a -withDirectory f = withReaderT - (\env -> env { testRelativeCurrentDir = testRelativeCurrentDir env f }) +withDirectory f = + withReaderT + (\env -> env{testRelativeCurrentDir = testRelativeCurrentDir env f}) -- We append to the environment list, as per 'getEffectiveEnvironment' -- which prefers the latest override. withEnv :: [(String, Maybe String)] -> TestM a -> TestM a -withEnv e = withReaderT (\env -> env { testEnvironment = testEnvironment env ++ e }) +withEnv e = withReaderT (\env -> env{testEnvironment = testEnvironment env ++ e}) -- HACK please don't use me withEnvFilter :: (String -> Bool) -> TestM a -> TestM a -withEnvFilter p = withReaderT (\env -> env { testEnvironment = filter (p . fst) (testEnvironment env) }) +withEnvFilter p = withReaderT (\env -> env{testEnvironment = filter (p . fst) (testEnvironment env)}) ------------------------------------------------------------------------ + -- * Running Setup marked_verbose :: String @@ -137,37 +145,40 @@ setup'' -- ^ Arguments -> TestM Result setup'' prefix cmd args = do - env <- getTestEnv - when ((cmd == "register" || cmd == "copy") && not (testHavePackageDb env)) $ - error "Cannot register/copy without using 'withPackageDb'" - ghc_path <- programPathM ghcProgram - haddock_path <- programPathM haddockProgram - let args' = case cmd of - "configure" -> - -- If the package database is empty, setting --global - -- here will make us error loudly if we try to install - -- into a bad place. - [ "--global" - -- NB: technically unnecessary with Cabal, but - -- definitely needed for Setup, which doesn't - -- respect cabal.config - , "--with-ghc", ghc_path - , "--with-haddock", haddock_path - -- This avoids generating hashes in our package IDs, - -- which helps the test suite's expect tests. - , "--enable-deterministic" - -- These flags make the test suite run faster - -- Can't do this unless we LD_LIBRARY_PATH correctly - -- , "--enable-executable-dynamic" - -- , "--disable-optimization" - -- Specify where we want our installed packages to go - , "--prefix=" ++ testPrefixDir env - ] ++ packageDBParams (testPackageDBStack env) - ++ args - _ -> args - let rel_dist_dir = definitelyMakeRelative (testCurrentDir env) (testDistDir env) - full_args = cmd :| [marked_verbose, "--distdir", rel_dist_dir] ++ args' - defaultRecordMode RecordMarked $ do + env <- getTestEnv + when ((cmd == "register" || cmd == "copy") && not (testHavePackageDb env)) $ + error "Cannot register/copy without using 'withPackageDb'" + ghc_path <- programPathM ghcProgram + haddock_path <- programPathM haddockProgram + let args' = case cmd of + "configure" -> + -- If the package database is empty, setting --global + -- here will make us error loudly if we try to install + -- into a bad place. + [ "--global" + , -- NB: technically unnecessary with Cabal, but + -- definitely needed for Setup, which doesn't + -- respect cabal.config + "--with-ghc" + , ghc_path + , "--with-haddock" + , haddock_path + , -- This avoids generating hashes in our package IDs, + -- which helps the test suite's expect tests. + "--enable-deterministic" + , -- These flags make the test suite run faster + -- Can't do this unless we LD_LIBRARY_PATH correctly + -- , "--enable-executable-dynamic" + -- , "--disable-optimization" + -- Specify where we want our installed packages to go + "--prefix=" ++ testPrefixDir env + ] + ++ packageDBParams (testPackageDBStack env) + ++ args + _ -> args + let rel_dist_dir = definitelyMakeRelative (testCurrentDir env) (testDistDir env) + full_args = cmd :| [marked_verbose, "--distdir", rel_dist_dir] ++ args' + defaultRecordMode RecordMarked $ do recordHeader ["Setup", cmd] -- We test `cabal act-as-setup` when running cabal-tests. @@ -178,84 +189,90 @@ setup'' prefix cmd args = do pdfile <- liftIO $ tryFindPackageDesc (testVerbosity env) (testCurrentDir env prefix) pdesc <- liftIO $ readGenericPackageDescription (testVerbosity env) pdfile if testCabalInstallAsSetup env - then if buildType (packageDescription pdesc) == Simple - then runProgramM cabalProgram ("act-as-setup" : "--" : NE.toList full_args) Nothing - else fail "Using act-as-setup for not 'build-type: Simple' package" - else do + then + if buildType (packageDescription pdesc) == Simple + then runProgramM cabalProgram ("act-as-setup" : "--" : NE.toList full_args) Nothing + else fail "Using act-as-setup for not 'build-type: Simple' package" + else do if buildType (packageDescription pdesc) == Simple - then runM (testSetupPath env) (NE.toList full_args) Nothing - -- Run the Custom script! - else do - r <- liftIO $ runghc (testScriptEnv env) - (Just (testCurrentDir env)) - (testEnvironment env) - (testCurrentDir env prefix "Setup.hs") - (NE.toList full_args) - recordLog r - requireSuccess r - - -- This code is very tempting (and in principle should be quick: - -- after all we are loading the built version of Cabal), but - -- actually it costs quite a bit in wallclock time (e.g. 54sec to - -- 68sec on AllowNewer, working with un-optimized Cabal.) - {- - r <- liftIO $ runghc (testScriptEnv env) - (Just (testCurrentDir env)) - (testEnvironment env) - "Setup.hs" - (cmd : ["-v", "--distdir", testDistDir env] ++ args') - -- don't forget to check results... - -} + then runM (testSetupPath env) (NE.toList full_args) Nothing + else -- Run the Custom script! + do + r <- + liftIO $ + runghc + (testScriptEnv env) + (Just (testCurrentDir env)) + (testEnvironment env) + (testCurrentDir env prefix "Setup.hs") + (NE.toList full_args) + recordLog r + requireSuccess r + +-- This code is very tempting (and in principle should be quick: +-- after all we are loading the built version of Cabal), but +-- actually it costs quite a bit in wallclock time (e.g. 54sec to +-- 68sec on AllowNewer, working with un-optimized Cabal.) +{- +r <- liftIO $ runghc (testScriptEnv env) + (Just (testCurrentDir env)) + (testEnvironment env) + "Setup.hs" + (cmd : ["-v", "--distdir", testDistDir env] ++ args') +-- don't forget to check results... +-} definitelyMakeRelative :: FilePath -> FilePath -> FilePath definitelyMakeRelative base0 path0 = - let go [] path = joinPath path - go base [] = joinPath (replicate (length base) "..") - go (x:xs) (y:ys) - | x == y = go xs ys - | otherwise = go (x:xs) [] go [] (y:ys) - -- NB: It's important to normalize, as otherwise if - -- we see "foo/./bar" we'll incorrectly conclude that we need - -- to go "../../.." to get out of it. - in go (splitPath (normalise base0)) (splitPath (normalise path0)) + let go [] path = joinPath path + go base [] = joinPath (replicate (length base) "..") + go (x : xs) (y : ys) + | x == y = go xs ys + | otherwise = go (x : xs) [] go [] (y : ys) + in -- NB: It's important to normalize, as otherwise if + -- we see "foo/./bar" we'll incorrectly conclude that we need + -- to go "../../.." to get out of it. + go (splitPath (normalise base0)) (splitPath (normalise path0)) -- | This abstracts the common pattern of configuring and then building. setup_build :: [String] -> TestM () setup_build args = do - setup "configure" args - setup "build" [] - return () + setup "configure" args + setup "build" [] + return () -- | This abstracts the common pattern of "installing" a package. setup_install :: [String] -> TestM () setup_install args = do - setup "configure" args - setup "build" [] - setup "copy" [] - setup "register" [] - return () + setup "configure" args + setup "build" [] + setup "copy" [] + setup "register" [] + return () -- | This abstracts the common pattern of "installing" a package, -- with haddock documentation. setup_install_with_docs :: [String] -> TestM () setup_install_with_docs args = do - setup "configure" args - setup "build" [] - setup "haddock" [] - setup "copy" [] - setup "register" [] - return () + setup "configure" args + setup "build" [] + setup "haddock" [] + setup "copy" [] + setup "register" [] + return () packageDBParams :: PackageDBStack -> [String] -packageDBParams dbs = "--package-db=clear" - : map (("--package-db=" ++) . convert) dbs +packageDBParams dbs = + "--package-db=clear" + : map (("--package-db=" ++) . convert) dbs where convert :: PackageDB -> String - convert GlobalPackageDB = "global" - convert UserPackageDB = "user" + convert GlobalPackageDB = "global" + convert UserPackageDB = "user" convert (SpecificPackageDB path) = path ------------------------------------------------------------------------ + -- * Running cabal -- cabal cmd args @@ -277,51 +294,55 @@ cabalG' global_args cmd args = cabalGArgs global_args cmd args Nothing cabalGArgs :: [String] -> String -> [String] -> Maybe String -> TestM Result cabalGArgs global_args cmd args input = do - env <- getTestEnv - -- Freeze writes out cabal.config to source directory, this is not - -- overwritable - when (cmd == "v1-freeze") requireHasSourceCopy - let extra_args - | cmd `elem` - [ "v1-update" - , "outdated" - , "user-config" - , "man" - , "v1-freeze" - , "check" - , "gen-bounds" - , "get", "unpack" - , "info" - , "init" - ] - = [ ] - - -- new-build commands are affected by testCabalProjectFile - | cmd == "v2-sdist" - = [ "--project-file", testCabalProjectFile env ] - - | cmd == "v2-clean" - = [ "--builddir", testDistDir env - , "--project-file", testCabalProjectFile env ] - - | "v2-" `isPrefixOf` cmd - = [ "--builddir", testDistDir env - , "--project-file", testCabalProjectFile env - , "-j1" ] - - | otherwise - = [ "--builddir", testDistDir env ] ++ - install_args - - install_args - | cmd == "v1-install" || cmd == "v1-build" = [ "-j1" ] - | otherwise = [] - - cabal_args = global_args - ++ [ cmd, marked_verbose ] - ++ extra_args - ++ args - defaultRecordMode RecordMarked $ do + env <- getTestEnv + -- Freeze writes out cabal.config to source directory, this is not + -- overwritable + when (cmd == "v1-freeze") requireHasSourceCopy + let extra_args + | cmd + `elem` [ "v1-update" + , "outdated" + , "user-config" + , "man" + , "v1-freeze" + , "check" + , "gen-bounds" + , "get" + , "unpack" + , "info" + , "init" + ] = + [] + -- new-build commands are affected by testCabalProjectFile + | cmd == "v2-sdist" = + ["--project-file", testCabalProjectFile env] + | cmd == "v2-clean" = + [ "--builddir" + , testDistDir env + , "--project-file" + , testCabalProjectFile env + ] + | "v2-" `isPrefixOf` cmd = + [ "--builddir" + , testDistDir env + , "--project-file" + , testCabalProjectFile env + , "-j1" + ] + | otherwise = + ["--builddir", testDistDir env] + ++ install_args + + install_args + | cmd == "v1-install" || cmd == "v1-build" = ["-j1"] + | otherwise = [] + + cabal_args = + global_args + ++ [cmd, marked_verbose] + ++ extra_args + ++ args + defaultRecordMode RecordMarked $ do recordHeader ["cabal", cmd] cabal_raw' cabal_args input @@ -330,92 +351,110 @@ cabal_raw' cabal_args input = runProgramM cabalProgram cabal_args input withProjectFile :: FilePath -> TestM a -> TestM a withProjectFile fp m = - withReaderT (\env -> env { testCabalProjectFile = fp }) m + withReaderT (\env -> env{testCabalProjectFile = fp}) m -- | Assuming we've successfully configured a new-build project, -- read out the plan metadata so that we can use it to do other -- operations. withPlan :: TestM a -> TestM a withPlan m = do - env0 <- getTestEnv - let filepath = testDistDir env0 "cache" "plan.json" - mplan <- JSON.eitherDecode `fmap` liftIO (BSL.readFile filepath) - case mplan of - Left err -> fail $ "withPlan: cannot decode plan " ++ err - Right plan -> withReaderT (\env -> env { testPlan = Just plan }) m + env0 <- getTestEnv + let filepath = testDistDir env0 "cache" "plan.json" + mplan <- JSON.eitherDecode `fmap` liftIO (BSL.readFile filepath) + case mplan of + Left err -> fail $ "withPlan: cannot decode plan " ++ err + Right plan -> withReaderT (\env -> env{testPlan = Just plan}) m -- | Run an executable from a package. Requires 'withPlan' to have -- been run so that we can find the dist dir. -runPlanExe :: String {- package name -} -> String {- component name -} - -> [String] -> TestM () +runPlanExe + :: String {- package name -} + -> String {- component name -} + -> [String] + -> TestM () runPlanExe pkg_name cname args = void $ runPlanExe' pkg_name cname args -- | Run an executable from a package. Requires 'withPlan' to have -- been run so that we can find the dist dir. Also returns 'Result'. -runPlanExe' :: String {- package name -} -> String {- component name -} - -> [String] -> TestM Result +runPlanExe' + :: String {- package name -} + -> String {- component name -} + -> [String] + -> TestM Result runPlanExe' pkg_name cname args = do - Just plan <- testPlan `fmap` getTestEnv - let distDirOrBinFile = planDistDir plan (mkPackageName pkg_name) - (CExeName (mkUnqualComponentName cname)) - exePath = case distDirOrBinFile of - DistDir dist_dir -> dist_dir "build" cname cname - BinFile bin_file -> bin_file - defaultRecordMode RecordAll $ do + Just plan <- testPlan `fmap` getTestEnv + let distDirOrBinFile = + planDistDir + plan + (mkPackageName pkg_name) + (CExeName (mkUnqualComponentName cname)) + exePath = case distDirOrBinFile of + DistDir dist_dir -> dist_dir "build" cname cname + BinFile bin_file -> bin_file + defaultRecordMode RecordAll $ do recordHeader [pkg_name, cname] runM exePath args Nothing ------------------------------------------------------------------------ + -- * Running ghc-pkg withPackageDb :: TestM a -> TestM a withPackageDb m = do - env <- getTestEnv - let db_path = testPackageDbDir env - if testHavePackageDb env - then m - else withReaderT (\nenv -> - nenv { testPackageDBStack - = testPackageDBStack env - ++ [SpecificPackageDB db_path] - , testHavePackageDb = True - } ) - $ do ghcPkg "init" [db_path] - m + env <- getTestEnv + let db_path = testPackageDbDir env + if testHavePackageDb env + then m + else withReaderT + ( \nenv -> + nenv + { testPackageDBStack = + testPackageDBStack env + ++ [SpecificPackageDB db_path] + , testHavePackageDb = True + } + ) + $ do + ghcPkg "init" [db_path] + m ghcPkg :: String -> [String] -> TestM () ghcPkg cmd args = void (ghcPkg' cmd args) ghcPkg' :: String -> [String] -> TestM Result ghcPkg' cmd args = do - env <- getTestEnv - unless (testHavePackageDb env) $ - error "Must initialize package database using withPackageDb" - -- NB: testDBStack already has the local database - ghcConfProg <- requireProgramM ghcProgram - let db_stack = testPackageDBStack env - extraArgs = ghcPkgPackageDBParams - (fromMaybe - (error "ghc-pkg: cannot detect version") - (programVersion ghcConfProg)) - db_stack - recordHeader ["ghc-pkg", cmd] - runProgramM ghcPkgProgram (cmd : extraArgs ++ args) Nothing + env <- getTestEnv + unless (testHavePackageDb env) $ + error "Must initialize package database using withPackageDb" + -- NB: testDBStack already has the local database + ghcConfProg <- requireProgramM ghcProgram + let db_stack = testPackageDBStack env + extraArgs = + ghcPkgPackageDBParams + ( fromMaybe + (error "ghc-pkg: cannot detect version") + (programVersion ghcConfProg) + ) + db_stack + recordHeader ["ghc-pkg", cmd] + runProgramM ghcPkgProgram (cmd : extraArgs ++ args) Nothing ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String] -ghcPkgPackageDBParams version dbs = concatMap convert dbs where +ghcPkgPackageDBParams version dbs = concatMap convert dbs + where convert :: PackageDB -> [String] -- Ignoring global/user is dodgy but there's no way good -- way to give ghc-pkg the correct flags in this case. - convert GlobalPackageDB = [] - convert UserPackageDB = [] + convert GlobalPackageDB = [] + convert UserPackageDB = [] convert (SpecificPackageDB path) - | version >= mkVersion [7,6] - = ["--package-db=" ++ path] - | otherwise - = ["--package-conf=" ++ path] + | version >= mkVersion [7, 6] = + ["--package-db=" ++ path] + | otherwise = + ["--package-conf=" ++ path] ------------------------------------------------------------------------ + -- * Running other things -- | Run an executable that was produced by cabal. The @exe_name@ @@ -425,8 +464,8 @@ runExe exe_name args = void (runExe' exe_name args) runExe' :: String -> [String] -> TestM Result runExe' exe_name args = do - env <- getTestEnv - defaultRecordMode RecordAll $ do + env <- getTestEnv + defaultRecordMode RecordAll $ do recordHeader [exe_name] runM (testDistDir env "build" exe_name exe_name) args Nothing @@ -440,8 +479,8 @@ runInstalledExe exe_name args = void (runInstalledExe' exe_name args) -- stdout/stderr output. runInstalledExe' :: String -> [String] -> TestM Result runInstalledExe' exe_name args = do - env <- getTestEnv - defaultRecordMode RecordAll $ do + env <- getTestEnv + defaultRecordMode RecordAll $ do recordHeader [exe_name] runM (testPrefixDir env "bin" exe_name) args Nothing @@ -450,6 +489,7 @@ shell :: String -> [String] -> TestM Result shell exe args = runM exe args Nothing ------------------------------------------------------------------------ + -- * Repository manipulation -- Workflows we support: @@ -487,29 +527,30 @@ hackageRepoTool cmd args = void $ hackageRepoTool' cmd args hackageRepoTool' :: String -> [String] -> TestM Result hackageRepoTool' cmd args = do - recordHeader ["hackage-repo-tool", cmd] - runProgramM hackageRepoToolProgram (cmd : args) Nothing + recordHeader ["hackage-repo-tool", cmd] + runProgramM hackageRepoToolProgram (cmd : args) Nothing tar :: [String] -> TestM () tar args = void $ tar' args tar' :: [String] -> TestM Result tar' args = do - recordHeader ["tar"] - runProgramM tarProgram args Nothing + recordHeader ["tar"] + runProgramM tarProgram args Nothing -- | Creates a tarball of a directory, such that if you -- archive the directory "/foo/bar/baz" to "mine.tgz", @tar tf@ reports -- @baz/file1@, @baz/file2@, etc. archiveTo :: FilePath -> FilePath -> TestM () src `archiveTo` dst = do - -- TODO: Consider using the @tar@ library? - let (src_parent, src_dir) = splitFileName src - -- TODO: --format ustar, like createArchive? - -- --force-local is necessary for handling colons in Windows paths. - tar $ ["-czf", dst] - ++ ["--force-local" | buildOS == Windows] - ++ ["-C", src_parent, src_dir] + -- TODO: Consider using the @tar@ library? + let (src_parent, src_dir) = splitFileName src + -- TODO: --format ustar, like createArchive? + -- --force-local is necessary for handling colons in Windows paths. + tar $ + ["-czf", dst] + ++ ["--force-local" | buildOS == Windows] + ++ ["-C", src_parent, src_dir] infixr 4 `archiveTo` @@ -518,156 +559,179 @@ infixr 4 `archiveTo` -- external repository corresponding to all of these packages withRepo :: FilePath -> TestM a -> TestM a withRepo repo_dir m = do - -- https://github.com/haskell/cabal/issues/7065 - -- you don't simply put a windows path into URL... - skipIfWindows + -- https://github.com/haskell/cabal/issues/7065 + -- you don't simply put a windows path into URL... + skipIfWindows - env <- getTestEnv + env <- getTestEnv - -- 1. Initialize repo directory - let package_dir = testRepoDir env - liftIO $ createDirectoryIfMissing True package_dir - - -- 2. Create tarballs - pkgs <- liftIO $ getDirectoryContents (testCurrentDir env repo_dir) - forM_ pkgs $ \pkg -> do - let srcPath = testCurrentDir env repo_dir pkg - let destPath = package_dir pkg - isPreferredVersionsFile <- liftIO $ - -- validate this is the "magic" 'preferred-versions' file - -- and perform a sanity-check whether this is actually a file - -- and not a package that happens to have the same name. - if pkg == "preferred-versions" - then doesFileExist srcPath - else return False - case pkg of - '.':_ -> return () - _ - | isPreferredVersionsFile -> - liftIO $ copyFile srcPath destPath - | otherwise -> archiveTo - srcPath - (destPath <.> "tar.gz") - - -- 3. Wire it up in .cabal/config - -- TODO: libify this - let package_cache = testCabalDir env "packages" - liftIO $ appendFile (testUserCabalConfigFile env) - $ unlines [ "repository test-local-repo" - , " url: " ++ repoUri env - , "remote-repo-cache: " ++ package_cache ] - liftIO $ print $ testUserCabalConfigFile env - liftIO $ print =<< readFile (testUserCabalConfigFile env) - - -- 4. Update our local index - -- Note: this doesn't do anything for file+noindex repositories. - cabal "v2-update" ["-z"] - - -- 5. Profit - withReaderT (\env' -> env' { testHaveRepo = True }) m - -- TODO: Arguably should undo everything when we're done... + -- 1. Initialize repo directory + let package_dir = testRepoDir env + liftIO $ createDirectoryIfMissing True package_dir + + -- 2. Create tarballs + pkgs <- liftIO $ getDirectoryContents (testCurrentDir env repo_dir) + forM_ pkgs $ \pkg -> do + let srcPath = testCurrentDir env repo_dir pkg + let destPath = package_dir pkg + isPreferredVersionsFile <- + liftIO $ + -- validate this is the "magic" 'preferred-versions' file + -- and perform a sanity-check whether this is actually a file + -- and not a package that happens to have the same name. + if pkg == "preferred-versions" + then doesFileExist srcPath + else return False + case pkg of + '.' : _ -> return () + _ + | isPreferredVersionsFile -> + liftIO $ copyFile srcPath destPath + | otherwise -> + archiveTo + srcPath + (destPath <.> "tar.gz") + + -- 3. Wire it up in .cabal/config + -- TODO: libify this + let package_cache = testCabalDir env "packages" + liftIO $ + appendFile (testUserCabalConfigFile env) $ + unlines + [ "repository test-local-repo" + , " url: " ++ repoUri env + , "remote-repo-cache: " ++ package_cache + ] + liftIO $ print $ testUserCabalConfigFile env + liftIO $ print =<< readFile (testUserCabalConfigFile env) + + -- 4. Update our local index + -- Note: this doesn't do anything for file+noindex repositories. + cabal "v2-update" ["-z"] + + -- 5. Profit + withReaderT (\env' -> env'{testHaveRepo = True}) m where - repoUri env ="file+noindex://" ++ testRepoDir env + -- TODO: Arguably should undo everything when we're done... + + repoUri env = "file+noindex://" ++ testRepoDir env -- | Given a directory (relative to the 'testCurrentDir') containing -- a series of directories representing packages, generate an -- remote repository corresponding to all of these packages withRemoteRepo :: FilePath -> TestM a -> TestM a withRemoteRepo repoDir m = do - -- https://github.com/haskell/cabal/issues/7065 - -- you don't simply put a windows path into URL... - skipIfWindows - - -- we rely on the presence of python3 for a simple http server - skipUnless "no python3" =<< isAvailableProgram python3Program - -- we rely on hackage-repo-tool to set up the secure repository - skipUnless "no hackage-repo-tool" =<< isAvailableProgram hackageRepoToolProgram + -- https://github.com/haskell/cabal/issues/7065 + -- you don't simply put a windows path into URL... + skipIfWindows - env <- getTestEnv + -- we rely on the presence of python3 for a simple http server + skipUnless "no python3" =<< isAvailableProgram python3Program + -- we rely on hackage-repo-tool to set up the secure repository + skipUnless "no hackage-repo-tool" =<< isAvailableProgram hackageRepoToolProgram - let workDir = testRepoDir env - - -- 1. Initialize repo and repo_keys directory - let keysDir = workDir "keys" - let packageDir = workDir "package" - - liftIO $ createDirectoryIfMissing True packageDir - liftIO $ createDirectoryIfMissing True keysDir - - -- 2. Create tarballs - entries <- liftIO $ getDirectoryContents (testCurrentDir env repoDir) - forM_ entries $ \entry -> do - let srcPath = testCurrentDir env repoDir entry - let destPath = packageDir entry - isPreferredVersionsFile <- liftIO $ - -- validate this is the "magic" 'preferred-versions' file - -- and perform a sanity-check whether this is actually a file - -- and not a package that happens to have the same name. - if entry == "preferred-versions" - then doesFileExist srcPath - else return False - case entry of - '.' : _ -> return () - _ - | isPreferredVersionsFile -> - liftIO $ copyFile srcPath destPath - | otherwise -> - archiveTo srcPath (destPath <.> "tar.gz") - - -- 3. Create keys and bootstrap repository - hackageRepoTool "create-keys" $ ["--keys", keysDir ] - hackageRepoTool "bootstrap" $ ["--keys", keysDir, "--repo", workDir] - - -- 4. Wire it up in .cabal/config - let package_cache = testCabalDir env "packages" - -- In the following we launch a python http server to serve the remote - -- repository. When the http server is ready we proceed with the tests. - -- NOTE 1: it's important that both the http server and cabal use the - -- same hostname ("localhost"), otherwise there could be a mismatch - -- (depending on the details of the host networking settings). - -- NOTE 2: here we use a fixed port (8000). This can cause problems in - -- case multiple tests are running concurrently or other another - -- process on the developer machine is using the same port. - liftIO $ do - appendFile (testUserCabalConfigFile env) $ - unlines [ "repository repository.localhost" - , " url: http://localhost:8000/" - , " secure: True" - , " root-keys:" - , " key-threshold: 0" - , "remote-repo-cache: " ++ package_cache ] - putStrLn $ testUserCabalConfigFile env - putStrLn =<< readFile (testUserCabalConfigFile env) - - withAsync - (flip runReaderT env $ python3 ["-m", "http.server", "-d", workDir, "--bind", "localhost", "8000"]) - (\_ -> do - -- wait for the python webserver to come up with a exponential - -- backoff starting from 50ms, up to a maximum wait of 60s - _ <- waitTcpVerbose putStrLn (limitRetriesByCumulativeDelay 60000000 $ exponentialBackoff 50000) "localhost" "8000" - runReaderT m (env { testHaveRepo = True })) + env <- getTestEnv + let workDir = testRepoDir env + + -- 1. Initialize repo and repo_keys directory + let keysDir = workDir "keys" + let packageDir = workDir "package" + + liftIO $ createDirectoryIfMissing True packageDir + liftIO $ createDirectoryIfMissing True keysDir + + -- 2. Create tarballs + entries <- liftIO $ getDirectoryContents (testCurrentDir env repoDir) + forM_ entries $ \entry -> do + let srcPath = testCurrentDir env repoDir entry + let destPath = packageDir entry + isPreferredVersionsFile <- + liftIO $ + -- validate this is the "magic" 'preferred-versions' file + -- and perform a sanity-check whether this is actually a file + -- and not a package that happens to have the same name. + if entry == "preferred-versions" + then doesFileExist srcPath + else return False + case entry of + '.' : _ -> return () + _ + | isPreferredVersionsFile -> + liftIO $ copyFile srcPath destPath + | otherwise -> + archiveTo srcPath (destPath <.> "tar.gz") + + -- 3. Create keys and bootstrap repository + hackageRepoTool "create-keys" $ ["--keys", keysDir] + hackageRepoTool "bootstrap" $ ["--keys", keysDir, "--repo", workDir] + + -- 4. Wire it up in .cabal/config + let package_cache = testCabalDir env "packages" + -- In the following we launch a python http server to serve the remote + -- repository. When the http server is ready we proceed with the tests. + -- NOTE 1: it's important that both the http server and cabal use the + -- same hostname ("localhost"), otherwise there could be a mismatch + -- (depending on the details of the host networking settings). + -- NOTE 2: here we use a fixed port (8000). This can cause problems in + -- case multiple tests are running concurrently or other another + -- process on the developer machine is using the same port. + liftIO $ do + appendFile (testUserCabalConfigFile env) $ + unlines + [ "repository repository.localhost" + , " url: http://localhost:8000/" + , " secure: True" + , " root-keys:" + , " key-threshold: 0" + , "remote-repo-cache: " ++ package_cache + ] + putStrLn $ testUserCabalConfigFile env + putStrLn =<< readFile (testUserCabalConfigFile env) + + withAsync + (flip runReaderT env $ python3 ["-m", "http.server", "-d", workDir, "--bind", "localhost", "8000"]) + ( \_ -> do + -- wait for the python webserver to come up with a exponential + -- backoff starting from 50ms, up to a maximum wait of 60s + _ <- waitTcpVerbose putStrLn (limitRetriesByCumulativeDelay 60000000 $ exponentialBackoff 50000) "localhost" "8000" + runReaderT m (env{testHaveRepo = True}) + ) ------------------------------------------------------------------------ + -- * Subprocess run results requireSuccess :: Result -> TestM Result -requireSuccess r@Result { resultCommand = cmd - , resultExitCode = exitCode - , resultOutput = output } = withFrozenCallStack $ do +requireSuccess + r@Result + { resultCommand = cmd + , resultExitCode = exitCode + , resultOutput = output + } = withFrozenCallStack $ do env <- getTestEnv when (exitCode /= ExitSuccess && not (testShouldFail env)) $ - assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ - "Output:\n" ++ output ++ "\n" + assertFailure $ + "Command " + ++ cmd + ++ " failed.\n" + ++ "Output:\n" + ++ output + ++ "\n" when (exitCode == ExitSuccess && testShouldFail env) $ - assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++ - "Output:\n" ++ output ++ "\n" + assertFailure $ + "Command " + ++ cmd + ++ " succeeded.\n" + ++ "Output:\n" + ++ output + ++ "\n" return r initWorkDir :: TestM () initWorkDir = do - env <- getTestEnv - liftIO $ createDirectoryIfMissing True (testWorkDir env) + env <- getTestEnv + liftIO $ createDirectoryIfMissing True (testWorkDir env) -- | Record a header to help identify the output to the expect -- log. Unlike the 'recordLog', we don't record all arguments; @@ -676,47 +740,55 @@ initWorkDir = do -- so we don't want to spew them to the log.) recordHeader :: [String] -> TestM () recordHeader args = do - env <- getTestEnv - let mode = testRecordMode env - str_header = "# " ++ intercalate " " args ++ "\n" - header = C.pack str_header - case mode of - DoNotRecord -> return () - _ -> do - initWorkDir - liftIO $ putStr str_header - liftIO $ C.appendFile (testWorkDir env "test.log") header - liftIO $ C.appendFile (testActualFile env) header + env <- getTestEnv + let mode = testRecordMode env + str_header = "# " ++ intercalate " " args ++ "\n" + header = C.pack str_header + case mode of + DoNotRecord -> return () + _ -> do + initWorkDir + liftIO $ putStr str_header + liftIO $ C.appendFile (testWorkDir env "test.log") header + liftIO $ C.appendFile (testActualFile env) header recordLog :: Result -> TestM () recordLog res = do - env <- getTestEnv - let mode = testRecordMode env - initWorkDir - liftIO $ C.appendFile (testWorkDir env "test.log") - (C.pack $ "+ " ++ resultCommand res ++ "\n" - ++ resultOutput res ++ "\n\n") - liftIO . C.appendFile (testActualFile env) . C.pack $ - case mode of - RecordAll -> unlines (lines (resultOutput res)) - RecordMarked -> getMarkedOutput (resultOutput res) - DoNotRecord -> "" + env <- getTestEnv + let mode = testRecordMode env + initWorkDir + liftIO $ + C.appendFile + (testWorkDir env "test.log") + ( C.pack $ + "+ " + ++ resultCommand res + ++ "\n" + ++ resultOutput res + ++ "\n\n" + ) + liftIO . C.appendFile (testActualFile env) . C.pack $ + case mode of + RecordAll -> unlines (lines (resultOutput res)) + RecordMarked -> getMarkedOutput (resultOutput res) + DoNotRecord -> "" getMarkedOutput :: String -> String -- trailing newline getMarkedOutput out = unlines (go (lines out) False) where go [] _ = [] - go (x:xs) True - | "-----END CABAL OUTPUT-----" `isPrefixOf` x - = go xs False - | otherwise = x : go xs True - go (x:xs) False - -- NB: Windows has extra goo at the end - | "-----BEGIN CABAL OUTPUT-----" `isPrefixOf` x - = go xs True - | otherwise = go xs False + go (x : xs) True + | "-----END CABAL OUTPUT-----" `isPrefixOf` x = + go xs False + | otherwise = x : go xs True + go (x : xs) False + -- NB: Windows has extra goo at the end + | "-----BEGIN CABAL OUTPUT-----" `isPrefixOf` x = + go xs True + | otherwise = go xs False ------------------------------------------------------------------------ + -- * Test helpers assertFailure :: WithCallStack (String -> m ()) @@ -725,108 +797,157 @@ assertFailure msg = withFrozenCallStack $ error msg assertExitCode :: MonadIO m => WithCallStack (ExitCode -> Result -> m ()) assertExitCode code result = when (code /= resultExitCode result) $ - assertFailure $ "Expected exit code: " - ++ show code - ++ "\nActual: " - ++ show (resultExitCode result) + assertFailure $ + "Expected exit code: " + ++ show code + ++ "\nActual: " + ++ show (resultExitCode result) assertEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ()) assertEqual s x y = - withFrozenCallStack $ - when (x /= y) $ - error (s ++ ":\nExpected: " ++ show x ++ "\nActual: " ++ show y) + withFrozenCallStack $ + when (x /= y) $ + error (s ++ ":\nExpected: " ++ show x ++ "\nActual: " ++ show y) assertNotEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ()) assertNotEqual s x y = - withFrozenCallStack $ - when (x == y) $ - error (s ++ ":\nGot both: " ++ show x) + withFrozenCallStack $ + when (x == y) $ + error (s ++ ":\nGot both: " ++ show x) assertBool :: MonadIO m => WithCallStack (String -> Bool -> m ()) assertBool s x = - withFrozenCallStack $ - unless x $ error s + withFrozenCallStack $ + unless x $ + error s shouldExist :: MonadIO m => WithCallStack (FilePath -> m ()) shouldExist path = - withFrozenCallStack $ - liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") + withFrozenCallStack $ + liftIO $ + doesFileExist path >>= assertBool (path ++ " should exist") shouldNotExist :: MonadIO m => WithCallStack (FilePath -> m ()) shouldNotExist path = - withFrozenCallStack $ - liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not + withFrozenCallStack $ + liftIO $ + doesFileExist path >>= assertBool (path ++ " should exist") . not shouldDirectoryExist :: MonadIO m => WithCallStack (FilePath -> m ()) shouldDirectoryExist path = - withFrozenCallStack $ - liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist") + withFrozenCallStack $ + liftIO $ + doesDirectoryExist path >>= assertBool (path ++ " should exist") shouldDirectoryNotExist :: MonadIO m => WithCallStack (FilePath -> m ()) shouldDirectoryNotExist path = - withFrozenCallStack $ - liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist") . not + withFrozenCallStack $ + liftIO $ + doesDirectoryExist path >>= assertBool (path ++ " should exist") . not assertRegex :: MonadIO m => String -> String -> Result -> m () assertRegex msg regex r = - withFrozenCallStack $ + withFrozenCallStack $ let out = resultOutput r - in assertBool (msg ++ ",\nactual output:\n" ++ out) - (out =~ regex) + in assertBool + (msg ++ ",\nactual output:\n" ++ out) + (out =~ regex) fails :: TestM a -> TestM a -fails = withReaderT (\env -> env { testShouldFail = not (testShouldFail env) }) +fails = withReaderT (\env -> env{testShouldFail = not (testShouldFail env)}) defaultRecordMode :: RecordMode -> TestM a -> TestM a -defaultRecordMode mode = withReaderT (\env -> env { - testRecordDefaultMode = mode - }) +defaultRecordMode mode = + withReaderT + ( \env -> + env + { testRecordDefaultMode = mode + } + ) recordMode :: RecordMode -> TestM a -> TestM a -recordMode mode = withReaderT (\env -> env { - testRecordUserMode = Just mode - }) +recordMode mode = + withReaderT + ( \env -> + env + { testRecordUserMode = Just mode + } + ) assertOutputContains :: MonadIO m => WithCallStack (String -> Result -> m ()) assertOutputContains needle result = - withFrozenCallStack $ + withFrozenCallStack $ unless (needle `isInfixOf` (concatOutput output)) $ - assertFailure $ " expected: " ++ needle - where output = resultOutput result + assertFailure $ + " expected: " ++ needle + where + output = resultOutput result assertOutputDoesNotContain :: MonadIO m => WithCallStack (String -> Result -> m ()) assertOutputDoesNotContain needle result = - withFrozenCallStack $ + withFrozenCallStack $ when (needle `isInfixOf` (concatOutput output)) $ - assertFailure $ "unexpected: " ++ needle - where output = resultOutput result + assertFailure $ + "unexpected: " ++ needle + where + output = resultOutput result assertFindInFile :: MonadIO m => WithCallStack (String -> FilePath -> m ()) assertFindInFile needle path = - withFrozenCallStack $ - liftIO $ withFileContents path - (\contents -> - unless (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) + withFrozenCallStack $ + liftIO $ + withFileContents + path + ( \contents -> + unless + (needle `isInfixOf` contents) + ( assertFailure + ( "expected: " + ++ needle + ++ "\n" + ++ " in file: " + ++ path + ) + ) + ) assertFileDoesContain :: MonadIO m => WithCallStack (FilePath -> String -> m ()) assertFileDoesContain path needle = - withFrozenCallStack $ - liftIO $ withFileContents path - (\contents -> - unless (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) + withFrozenCallStack $ + liftIO $ + withFileContents + path + ( \contents -> + unless + (needle `isInfixOf` contents) + ( assertFailure + ( "expected: " + ++ needle + ++ "\n" + ++ " in file: " + ++ path + ) + ) + ) assertFileDoesNotContain :: MonadIO m => WithCallStack (FilePath -> String -> m ()) assertFileDoesNotContain path needle = - withFrozenCallStack $ - liftIO $ withFileContents path - (\contents -> - when (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) + withFrozenCallStack $ + liftIO $ + withFileContents + path + ( \contents -> + when + (needle `isInfixOf` contents) + ( assertFailure + ( "expected: " + ++ needle + ++ "\n" + ++ " in file: " + ++ path + ) + ) + ) -- | Replace line breaks with spaces, correctly handling "\r\n". concatOutput :: String -> String @@ -835,30 +956,43 @@ concatOutput = unwords . lines . filter ((/=) '\r') -- | The directory where script build artifacts are expected to be cached getScriptCacheDirectory :: FilePath -> TestM FilePath getScriptCacheDirectory script = do - cabalDir <- testCabalDir `fmap` getTestEnv - hashinput <- liftIO $ canonicalizePath script - let hash = map (\c -> if c == '/' then '%' else c) . take 26 - . C.unpack . Base64.encode . SHA256.hash . C.pack $ hashinput - return $ cabalDir "script-builds" hash + cabalDir <- testCabalDir `fmap` getTestEnv + hashinput <- liftIO $ canonicalizePath script + let hash = + map (\c -> if c == '/' then '%' else c) + . take 26 + . C.unpack + . Base64.encode + . SHA256.hash + . C.pack + $ hashinput + return $ cabalDir "script-builds" hash ------------------------------------------------------------------------ + -- * Skipping tests -hasSharedLibraries :: TestM Bool +hasSharedLibraries :: TestM Bool hasSharedLibraries = do - shared_libs_were_removed <- isGhcVersion ">= 7.8" - return (not (buildOS == Windows && shared_libs_were_removed)) + shared_libs_were_removed <- isGhcVersion ">= 7.8" + return (not (buildOS == Windows && shared_libs_were_removed)) hasProfiledLibraries :: TestM Bool hasProfiledLibraries = do - env <- getTestEnv - ghc_path <- programPathM ghcProgram - let prof_test_hs = testWorkDir env "Prof.hs" - liftIO $ writeFile prof_test_hs "module Prof where" - r <- liftIO $ run (testVerbosity env) (Just (testCurrentDir env)) - (testEnvironment env) ghc_path ["-prof", "-c", prof_test_hs] - Nothing - return (resultExitCode r == ExitSuccess) + env <- getTestEnv + ghc_path <- programPathM ghcProgram + let prof_test_hs = testWorkDir env "Prof.hs" + liftIO $ writeFile prof_test_hs "module Prof where" + r <- + liftIO $ + run + (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + ghc_path + ["-prof", "-c", prof_test_hs] + Nothing + return (resultExitCode r == ExitSuccess) -- | Check if the GHC that is used for compiling package tests has -- a shared library of the cabal library under test in its database. @@ -872,15 +1006,17 @@ hasCabalShared = do isGhcVersion :: WithCallStack (String -> TestM Bool) isGhcVersion range = do - ghc_program <- requireProgramM ghcProgram - v <- case programVersion ghc_program of - Nothing -> error $ "isGhcVersion: no ghc version for " - ++ show (programLocation ghc_program) - Just v -> return v - vr <- case eitherParsec range of - Left err -> fail err - Right vr -> return vr - return (v `withinRange` vr) + ghc_program <- requireProgramM ghcProgram + v <- case programVersion ghc_program of + Nothing -> + error $ + "isGhcVersion: no ghc version for " + ++ show (programLocation ghc_program) + Just v -> return v + vr <- case eitherParsec range of + Left err -> fail err + Right vr -> return vr + return (v `withinRange` vr) skipUnlessGhcVersion :: String -> TestM () skipUnlessGhcVersion range = skipUnless ("needs ghc " ++ range) =<< isGhcVersion range @@ -905,8 +1041,9 @@ isLinux = return (buildOS == Linux) isJavaScript :: TestM Bool isJavaScript = return (buildArch == JavaScript) - -- should probably be `hostArch` but Cabal doesn't distinguish build platform - -- and host platform + +-- should probably be `hostArch` but Cabal doesn't distinguish build platform +-- and host platform skipIfWindows :: TestM () skipIfWindows = skipIf "Windows" =<< isWindows @@ -926,21 +1063,23 @@ getOpenFilesLimit = liftIO $ do hasCabalForGhc :: TestM Bool hasCabalForGhc = do - env <- getTestEnv - ghc_program <- requireProgramM ghcProgram - (runner_ghc_program, _) <- liftIO $ requireProgram + env <- getTestEnv + ghc_program <- requireProgramM ghcProgram + (runner_ghc_program, _) <- + liftIO $ + requireProgram (testVerbosity env) ghcProgram (runnerProgramDb (testScriptEnv env)) - -- TODO: I guess, to be more robust what we should check for - -- specifically is that the Cabal library we want to use - -- will be picked up by the package db stack of ghc-program + -- TODO: I guess, to be more robust what we should check for + -- specifically is that the Cabal library we want to use + -- will be picked up by the package db stack of ghc-program - -- liftIO $ putStrLn $ "ghc_program: " ++ show ghc_program - -- liftIO $ putStrLn $ "runner_ghc_program: " ++ show runner_ghc_program + -- liftIO $ putStrLn $ "ghc_program: " ++ show ghc_program + -- liftIO $ putStrLn $ "runner_ghc_program: " ++ show runner_ghc_program - return (programPath ghc_program == programPath runner_ghc_program) + return (programPath ghc_program == programPath runner_ghc_program) -- | If you want to use a Custom setup with new-build, it needs to -- be 1.20 or later. Ordinarily, Cabal can go off and build a @@ -949,25 +1088,25 @@ hasCabalForGhc = do -- rather lengthy build process), instead using the boot Cabal if -- possible. But some GHCs don't have a recent enough boot Cabal! -- You'll want to exclude them in that case. --- hasNewBuildCompatBootCabal :: TestM Bool hasNewBuildCompatBootCabal = isGhcVersion ">= 7.9" ------------------------------------------------------------------------ + -- * Broken tests expectBroken :: Int -> TestM a -> TestM () expectBroken ticket m = do - env <- getTestEnv - liftIO . withAsync (runReaderT m env) $ \a -> do - r <- waitCatch a - case r of - Left e -> do - putStrLn $ "This test is known broken, see #" ++ show ticket ++ ":" - print e - runReaderT expectedBroken env - Right _ -> do - runReaderT unexpectedSuccess env + env <- getTestEnv + liftIO . withAsync (runReaderT m env) $ \a -> do + r <- waitCatch a + case r of + Left e -> do + putStrLn $ "This test is known broken, see #" ++ show ticket ++ ":" + print e + runReaderT expectedBroken env + Right _ -> do + runReaderT unexpectedSuccess env expectBrokenIf :: Bool -> Int -> TestM a -> TestM () expectBrokenIf False _ m = void $ m @@ -977,6 +1116,7 @@ expectBrokenUnless :: Bool -> Int -> TestM a -> TestM () expectBrokenUnless b = expectBrokenIf (not b) ------------------------------------------------------------------------ + -- * Miscellaneous git :: String -> [String] -> TestM () @@ -984,32 +1124,32 @@ git cmd args = void $ git' cmd args git' :: String -> [String] -> TestM Result git' cmd args = do - recordHeader ["git", cmd] - runProgramM gitProgram (cmd : args) Nothing + recordHeader ["git", cmd] + runProgramM gitProgram (cmd : args) Nothing gcc :: [String] -> TestM () gcc args = void $ gcc' args gcc' :: [String] -> TestM Result gcc' args = do - recordHeader ["gcc"] - runProgramM gccProgram args Nothing + recordHeader ["gcc"] + runProgramM gccProgram args Nothing ghc :: [String] -> TestM () ghc args = void $ ghc' args ghc' :: [String] -> TestM Result ghc' args = do - recordHeader ["ghc"] - runProgramM ghcProgram args Nothing + recordHeader ["ghc"] + runProgramM ghcProgram args Nothing python3 :: [String] -> TestM () python3 args = void $ python3' args python3' :: [String] -> TestM Result python3' args = do - recordHeader ["python3"] - runProgramM python3Program args Nothing + recordHeader ["python3"] + runProgramM python3Program args Nothing -- | If a test needs to modify or write out source files, it's -- necessary to make a hermetic copy of the source files to operate @@ -1022,15 +1162,15 @@ python3' args = do -- Also see 'withSourceCopyDir'. withSourceCopy :: TestM a -> TestM a withSourceCopy m = do - env <- getTestEnv - let cwd = testCurrentDir env - dest = testSourceCopyDir env - r <- git' "ls-files" ["--cached", "--modified"] - forM_ (lines (resultOutput r)) $ \f -> do - unless (isTestFile f) $ do - liftIO $ createDirectoryIfMissing True (takeDirectory (dest f)) - liftIO $ copyFile (cwd f) (dest f) - withReaderT (\nenv -> nenv { testHaveSourceCopy = True }) m + env <- getTestEnv + let cwd = testCurrentDir env + dest = testSourceCopyDir env + r <- git' "ls-files" ["--cached", "--modified"] + forM_ (lines (resultOutput r)) $ \f -> do + unless (isTestFile f) $ do + liftIO $ createDirectoryIfMissing True (takeDirectory (dest f)) + liftIO $ copyFile (cwd f) (dest f) + withReaderT (\nenv -> nenv{testHaveSourceCopy = True}) m -- | If a test needs to modify or write out source files, it's -- necessary to make a hermetic copy of the source files to operate @@ -1045,49 +1185,50 @@ withSourceCopy m = do -- Also see 'withSourceCopy'. withSourceCopyDir :: FilePath -> TestM a -> TestM a withSourceCopyDir dir = - withReaderT (\nenv -> nenv { testSourceCopyRelativeDir = dir }) . withSourceCopy + withReaderT (\nenv -> nenv{testSourceCopyRelativeDir = dir}) . withSourceCopy -- | Look up the 'InstalledPackageId' of a package name. getIPID :: String -> TestM String getIPID pn = do - r <- ghcPkg' "field" ["--global", pn, "id"] - -- Don't choke on warnings from ghc-pkg - case mapMaybe (stripPrefix "id: ") (lines (resultOutput r)) of - -- ~/.cabal/store may contain multiple versions of single package - -- we pick first one. It should work - (x:_) -> return (takeWhile (not . Char.isSpace) x) - _ -> error $ "could not determine id of " ++ pn + r <- ghcPkg' "field" ["--global", pn, "id"] + -- Don't choke on warnings from ghc-pkg + case mapMaybe (stripPrefix "id: ") (lines (resultOutput r)) of + -- ~/.cabal/store may contain multiple versions of single package + -- we pick first one. It should work + (x : _) -> return (takeWhile (not . Char.isSpace) x) + _ -> error $ "could not determine id of " ++ pn -- | Delay a sufficient period of time to permit file timestamp -- to be updated. delay :: TestM () delay = do - env <- getTestEnv - is_old_ghc <- isGhcVersion "< 7.7" - -- For old versions of GHC, we only had second-level precision, - -- so we need to sleep a full second. Newer versions use - -- millisecond level precision, so we only have to wait - -- the granularity of the underlying filesystem. - -- TODO: cite commit when GHC got better precision; this - -- version bound was empirically generated. - liftIO . threadDelay $ - if is_old_ghc - then 1000000 - else fromMaybe - (error "Delay must be enclosed by withDelay") - (testMtimeChangeDelay env) + env <- getTestEnv + is_old_ghc <- isGhcVersion "< 7.7" + -- For old versions of GHC, we only had second-level precision, + -- so we need to sleep a full second. Newer versions use + -- millisecond level precision, so we only have to wait + -- the granularity of the underlying filesystem. + -- TODO: cite commit when GHC got better precision; this + -- version bound was empirically generated. + liftIO . threadDelay $ + if is_old_ghc + then 1000000 + else + fromMaybe + (error "Delay must be enclosed by withDelay") + (testMtimeChangeDelay env) -- | Calibrate file modification time delay, if not -- already determined. withDelay :: TestM a -> TestM a withDelay m = do - env <- getTestEnv - case testMtimeChangeDelay env of - Nothing -> do - -- Figure out how long we need to delay for recompilation tests - (_, mtimeChange) <- liftIO $ calibrateMtimeChangeDelay - withReaderT (\nenv -> nenv { testMtimeChangeDelay = Just mtimeChange }) m - Just _ -> m + env <- getTestEnv + case testMtimeChangeDelay env of + Nothing -> do + -- Figure out how long we need to delay for recompilation tests + (_, mtimeChange) <- liftIO $ calibrateMtimeChangeDelay + withReaderT (\nenv -> nenv{testMtimeChangeDelay = Just mtimeChange}) m + Just _ -> m -- | Create a symlink for the duration of the provided action. If the symlink -- already exists, it is deleted. Does not work on Windows. @@ -1107,29 +1248,29 @@ withSymlink oldpath newpath0 act = do writeSourceFile :: FilePath -> String -> TestM () writeSourceFile fp s = do - requireHasSourceCopy - cwd <- fmap testCurrentDir getTestEnv - liftIO $ writeFile (cwd fp) s + requireHasSourceCopy + cwd <- fmap testCurrentDir getTestEnv + liftIO $ writeFile (cwd fp) s copySourceFileTo :: FilePath -> FilePath -> TestM () copySourceFileTo src dest = do - requireHasSourceCopy - cwd <- fmap testCurrentDir getTestEnv - liftIO $ copyFile (cwd src) (cwd dest) + requireHasSourceCopy + cwd <- fmap testCurrentDir getTestEnv + liftIO $ copyFile (cwd src) (cwd dest) requireHasSourceCopy :: TestM () requireHasSourceCopy = do - env <- getTestEnv - unless (testHaveSourceCopy env) $ do - error "This operation requires a source copy; use withSourceCopy and 'git add' all test files" + env <- getTestEnv + unless (testHaveSourceCopy env) $ do + error "This operation requires a source copy; use withSourceCopy and 'git add' all test files" -- NB: Keep this synchronized with partitionTests isTestFile :: FilePath -> Bool isTestFile f = - case takeExtensions f of - ".test.hs" -> True - ".multitest.hs" -> True - _ -> False + case takeExtensions f of + ".test.hs" -> True + ".multitest.hs" -> True + _ -> False -- | Work around issue #4515 (store paths exceeding the Windows path length -- limit) by creating a temporary directory for the new-build store. This @@ -1137,25 +1278,30 @@ isTestFile f = -- The directory must be passed to new- commands with --store-dir. withShorterPathForNewBuildStore :: (FilePath -> IO a) -> IO a withShorterPathForNewBuildStore test = do - tempDir <- if buildOS == Windows - then takeDrive `fmap` getCurrentDirectory - else getTemporaryDirectory + tempDir <- + if buildOS == Windows + then takeDrive `fmap` getCurrentDirectory + else getTemporaryDirectory withTempDirectory normal tempDir "cabal-test-store" test -- | Find where a package locates in the store dir. This works only if there is exactly one 1 ghc version -- and exactly 1 directory for the given package in the store dir. -findDependencyInStore :: FilePath -- ^store dir - -> String -- ^package name prefix - -> IO FilePath -- ^package dir +findDependencyInStore + :: FilePath + -- ^ store dir + -> String + -- ^ package name prefix + -> IO FilePath + -- ^ package dir findDependencyInStore storeDir pkgName = do - storeDirForGhcVersion <- head <$> listDirectory storeDir - packageDirs <- listDirectory (storeDir storeDirForGhcVersion) - -- Ideally, we should call 'hashedInstalledPackageId' from 'Distribution.Client.PackageHash'. - -- But 'PackageHashInputs', especially 'PackageHashConfigInputs', is too hard to construct. - let pkgName' = - if buildOS == OSX - then filter (not . flip elem "aeiou") pkgName - -- simulates the way 'hashedInstalledPackageId' uses to compress package name - else pkgName - let libDir = head $ filter (pkgName' `isPrefixOf`) packageDirs - pure (storeDir storeDirForGhcVersion libDir) + storeDirForGhcVersion <- head <$> listDirectory storeDir + packageDirs <- listDirectory (storeDir storeDirForGhcVersion) + -- Ideally, we should call 'hashedInstalledPackageId' from 'Distribution.Client.PackageHash'. + -- But 'PackageHashInputs', especially 'PackageHashConfigInputs', is too hard to construct. + let pkgName' = + if buildOS == OSX + then filter (not . flip elem "aeiou") pkgName + else -- simulates the way 'hashedInstalledPackageId' uses to compress package name + pkgName + let libDir = head $ filter (pkgName' `isPrefixOf`) packageDirs + pure (storeDir storeDirForGhcVersion libDir) diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 6c06dec91d7..762599387bb 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.hs @@ -1,92 +1,108 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | A module for running commands in a chatty way. -module Test.Cabal.Run ( - run, - runAction, - Result(..) -) where +module Test.Cabal.Run + ( run + , runAction + , Result (..) + ) where import Distribution.Simple.Program.Run import Distribution.Verbosity import Control.Concurrent.Async -import System.Process -import System.IO -import System.Exit import System.Directory +import System.Exit import System.FilePath +import System.IO +import System.Process -- | The result of invoking the command line. data Result = Result - { resultExitCode :: ExitCode - , resultCommand :: String - , resultOutput :: String - } deriving Show + { resultExitCode :: ExitCode + , resultCommand :: String + , resultOutput :: String + } + deriving (Show) -- | Run a command, streaming its output to stdout, and return a 'Result' -- with this information. -run :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] - -> Maybe String -> IO Result +run + :: Verbosity + -> Maybe FilePath + -> [(String, Maybe String)] + -> FilePath + -> [String] + -> Maybe String + -> IO Result run verbosity mb_cwd env_overrides path0 args input = - runAction verbosity mb_cwd env_overrides path0 args input (\_ -> return ()) + runAction verbosity mb_cwd env_overrides path0 args input (\_ -> return ()) -runAction :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] - -> Maybe String -> (ProcessHandle -> IO ()) -> IO Result +runAction + :: Verbosity + -> Maybe FilePath + -> [(String, Maybe String)] + -> FilePath + -> [String] + -> Maybe String + -> (ProcessHandle -> IO ()) + -> IO Result runAction _verbosity mb_cwd env_overrides path0 args input action = do - -- In our test runner, we allow a path to be relative to the - -- current directory using the same heuristic as shells: - -- 'foo' refers to an executable in the PATH, but './foo' - -- and 'foo/bar' refer to relative files. - -- - -- Unfortunately, we cannot just pass these relative paths directly: - -- 'runProcess' resolves an executable path not with respect to the - -- current working directory, but the working directory that the - -- subprocess will execute in. Thus, IF we have a relative - -- path which is not a bare executable name, we have to tack on - -- the CWD to make it resolve correctly - cwdir <- getCurrentDirectory - let path | length (splitPath path0) /= 1 && isRelative path0 - = cwdir path0 - | otherwise - = path0 - - mb_env <- getEffectiveEnvironment env_overrides - putStrLn $ "+ " ++ showCommandForUser path args - (readh, writeh) <- createPipe - hSetBuffering readh LineBuffering - hSetBuffering writeh LineBuffering - let drain = do - r <- hGetContents readh - putStr r -- forces the output - hClose readh - return r - withAsync drain $ \sync -> do + -- In our test runner, we allow a path to be relative to the + -- current directory using the same heuristic as shells: + -- 'foo' refers to an executable in the PATH, but './foo' + -- and 'foo/bar' refer to relative files. + -- + -- Unfortunately, we cannot just pass these relative paths directly: + -- 'runProcess' resolves an executable path not with respect to the + -- current working directory, but the working directory that the + -- subprocess will execute in. Thus, IF we have a relative + -- path which is not a bare executable name, we have to tack on + -- the CWD to make it resolve correctly + cwdir <- getCurrentDirectory + let path + | length (splitPath path0) /= 1 && isRelative path0 = + cwdir path0 + | otherwise = + path0 - let prc = (proc path args) - { cwd = mb_cwd - , env = mb_env - , std_in = case input of { Just _ -> CreatePipe; Nothing -> Inherit } - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + mb_env <- getEffectiveEnvironment env_overrides + putStrLn $ "+ " ++ showCommandForUser path args + (readh, writeh) <- createPipe + hSetBuffering readh LineBuffering + hSetBuffering writeh LineBuffering + let drain = do + r <- hGetContents readh + putStr r -- forces the output + hClose readh + return r + withAsync drain $ \sync -> do + let prc = + (proc path args) + { cwd = mb_cwd + , env = mb_env + , std_in = case input of Just _ -> CreatePipe; Nothing -> Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } withCreateProcess prc $ \stdin_h _ _ procHandle -> do + case input of + Just x -> + case stdin_h of + Just h -> hPutStr h x >> hClose h + Nothing -> error "No stdin handle when input was specified!" + Nothing -> return () - case input of - Just x -> - case stdin_h of - Just h -> hPutStr h x >> hClose h - Nothing -> error "No stdin handle when input was specified!" - Nothing -> return () + action procHandle - action procHandle + -- wait for the program to terminate + exitcode <- waitForProcess procHandle + out <- wait sync - -- wait for the program to terminate - exitcode <- waitForProcess procHandle - out <- wait sync - - return Result { - resultExitCode = exitcode, - resultCommand = showCommandForUser path args, - resultOutput = out - } + return + Result + { resultExitCode = exitcode + , resultCommand = showCommandForUser path args + , resultOutput = out + } diff --git a/cabal-testsuite/src/Test/Cabal/Script.hs b/cabal-testsuite/src/Test/Cabal/Script.hs index a7ce082a97b..9aff687e260 100644 --- a/cabal-testsuite/src/Test/Cabal/Script.hs +++ b/cabal-testsuite/src/Test/Cabal/Script.hs @@ -1,43 +1,41 @@ -- | Functionality for invoking Haskell scripts with the correct -- package database setup. -module Test.Cabal.Script ( - ScriptEnv(..), - mkScriptEnv, - runnerGhcArgs, - runnerCommand, - runghc, -) where +module Test.Cabal.Script + ( ScriptEnv (..) + , mkScriptEnv + , runnerGhcArgs + , runnerCommand + , runghc + ) where import Test.Cabal.Run import Test.Cabal.ScriptEnv0 import Distribution.Backpack -import Distribution.Types.ModuleRenaming -import Distribution.Utils.NubList -import Distribution.Simple.Program.Db +import Distribution.Simple.Compiler +import Distribution.Simple.Program import Distribution.Simple.Program.Builtin import Distribution.Simple.Program.GHC -import Distribution.Simple.Program -import Distribution.Simple.Compiler -import Distribution.Verbosity +import Distribution.Simple.Setup (Flag (..)) import Distribution.System -import Distribution.Simple.Setup (Flag(..)) +import Distribution.Types.ModuleRenaming +import Distribution.Utils.NubList +import Distribution.Verbosity import qualified Data.Monoid as M - -- | The runner environment, which contains all of the important -- parameters for invoking GHC. Mostly subset of 'LocalBuildInfo'. data ScriptEnv = ScriptEnv - { runnerProgramDb :: ProgramDb - , runnerPackageDbStack :: PackageDBStack - , runnerVerbosity :: Verbosity - , runnerPlatform :: Platform - , runnerCompiler :: Compiler - , runnerPackages :: [(OpenUnitId, ModuleRenaming)] - , runnerWithSharedLib :: Bool - } - deriving Show + { runnerProgramDb :: ProgramDb + , runnerPackageDbStack :: PackageDBStack + , runnerVerbosity :: Verbosity + , runnerPlatform :: Platform + , runnerCompiler :: Compiler + , runnerPackages :: [(OpenUnitId, ModuleRenaming)] + , runnerWithSharedLib :: Bool + } + deriving (Show) {- @@ -54,33 +52,46 @@ canonicalizePackageDB x = return x -- the GHC that we want to use. mkScriptEnv :: Verbosity -> IO ScriptEnv mkScriptEnv verbosity = - return $ ScriptEnv - { runnerVerbosity = verbosity - , runnerProgramDb = lbiProgramDb - , runnerPackageDbStack = lbiPackageDbStack - , runnerPlatform = lbiPlatform - , runnerCompiler = lbiCompiler - -- NB: the set of packages available to test.hs scripts will COINCIDE - -- with the dependencies on the cabal-testsuite library - , runnerPackages = lbiPackages - , runnerWithSharedLib = lbiWithSharedLib - } + return $ + ScriptEnv + { runnerVerbosity = verbosity + , runnerProgramDb = lbiProgramDb + , runnerPackageDbStack = lbiPackageDbStack + , runnerPlatform = lbiPlatform + , runnerCompiler = lbiCompiler + , -- NB: the set of packages available to test.hs scripts will COINCIDE + -- with the dependencies on the cabal-testsuite library + runnerPackages = lbiPackages + , runnerWithSharedLib = lbiWithSharedLib + } -- | Run a script with 'runghc', under the 'ScriptEnv'. -runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)] - -> FilePath -> [String] -> IO Result +runghc + :: ScriptEnv + -> Maybe FilePath + -> [(String, Maybe String)] + -> FilePath + -> [String] + -> IO Result runghc senv mb_cwd env_overrides script_path args = do - (real_path, real_args) <- runnerCommand senv mb_cwd env_overrides script_path args - run (runnerVerbosity senv) mb_cwd env_overrides real_path real_args Nothing + (real_path, real_args) <- runnerCommand senv mb_cwd env_overrides script_path args + run (runnerVerbosity senv) mb_cwd env_overrides real_path real_args Nothing -- | Compute the command line which should be used to run a Haskell -- script with 'runghc'. -runnerCommand :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)] - -> FilePath -> [String] -> IO (FilePath, [String]) +runnerCommand + :: ScriptEnv + -> Maybe FilePath + -> [(String, Maybe String)] + -> FilePath + -> [String] + -> IO (FilePath, [String]) runnerCommand senv _mb_cwd _env_overrides script_path args = do - (prog, _) <- requireProgram verbosity runghcProgram (runnerProgramDb senv) - return (programPath prog, - runghc_args ++ ["--"] ++ map ("--ghc-arg="++) ghc_args ++ [script_path] ++ args) + (prog, _) <- requireProgram verbosity runghcProgram (runnerProgramDb senv) + return + ( programPath prog + , runghc_args ++ ["--"] ++ map ("--ghc-arg=" ++) ghc_args ++ [script_path] ++ args + ) where verbosity = runnerVerbosity senv runghc_args = [] @@ -89,10 +100,13 @@ runnerCommand senv _mb_cwd _env_overrides script_path args = do -- | Compute the GHC flags to invoke 'runghc' with under a 'ScriptEnv'. runnerGhcArgs :: ScriptEnv -> [String] runnerGhcArgs senv = - renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options + renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options where - ghc_options = M.mempty { ghcOptPackageDBs = runnerPackageDbStack senv - , ghcOptPackages = toNubListR (runnerPackages senv) - -- Avoid picking stray module files that look - -- like our imports - , ghcOptSourcePathClear = Flag True } + ghc_options = + M.mempty + { ghcOptPackageDBs = runnerPackageDbStack senv + , ghcOptPackages = toNubListR (runnerPackages senv) + , -- Avoid picking stray module files that look + -- like our imports + ghcOptSourcePathClear = Flag True + } diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index 450c6f660c7..a00dba5fdd1 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -1,39 +1,38 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | A GHC run-server, which supports running multiple GHC scripts -- without having to restart from scratch. -module Test.Cabal.Server ( - Server, - serverProcessId, - ServerLogMsg(..), - ServerLogMsgType(..), - ServerResult(..), - withNewServer, - runOnServer, - runMain, -) where +module Test.Cabal.Server + ( Server + , serverProcessId + , ServerLogMsg (..) + , ServerLogMsgType (..) + , ServerResult (..) + , withNewServer + , runOnServer + , runMain + ) where import Test.Cabal.Script import Test.Cabal.TestCode -import Prelude hiding (log) -import Control.Concurrent.MVar import Control.Concurrent import Control.Concurrent.Async -import System.Process -import System.IO -import System.Exit -import Data.List (intercalate, isPrefixOf) -import Distribution.Simple.Program.Db -import Distribution.Simple.Program import Control.Exception import qualified Control.Exception as E import Control.Monad import Data.IORef +import Data.List (intercalate, isPrefixOf) import Data.Maybe -import Text.Read (readMaybe) +import Distribution.Simple.Program import Foreign.C.Error (Errno (..), ePIPE) +import System.Exit +import System.IO +import System.Process +import Text.Read (readMaybe) +import Prelude hiding (log) import qualified GHC.IO.Exception as GHC @@ -55,46 +54,48 @@ import qualified System.Win32.Process as Win32 -- | A GHCi server session, which we can ask to run scripts. -- It operates in a *fixed* runner environment as specified -- by 'serverScriptEnv'. -data Server = Server { - serverStdin :: Handle, - serverStdout :: Handle, - serverStderr :: Handle, - serverProcessHandle :: ProcessHandle, - serverProcessId :: ProcessId, - serverScriptEnv :: ScriptEnv, - -- | Accumulators which we use to keep tracking - -- of stdout/stderr we've incrementally read out. In the event - -- of an error we'll use this to give diagnostic information. - serverStdoutAccum :: MVar [String], - serverStderrAccum :: MVar [String], - serverLogChan :: Chan ServerLogMsg - } +data Server = Server + { serverStdin :: Handle + , serverStdout :: Handle + , serverStderr :: Handle + , serverProcessHandle :: ProcessHandle + , serverProcessId :: ProcessId + , serverScriptEnv :: ScriptEnv + , serverStdoutAccum :: MVar [String] + -- ^ Accumulators which we use to keep tracking + -- of stdout/stderr we've incrementally read out. In the event + -- of an error we'll use this to give diagnostic information. + , serverStderrAccum :: MVar [String] + , serverLogChan :: Chan ServerLogMsg + } -- | Portable representation of process ID; just a string rendered -- number. type ProcessId = String -data ServerLogMsg = ServerLogMsg ServerLogMsgType String - | ServerLogEnd -data ServerLogMsgType = ServerOut ProcessId - | ServerErr ProcessId - | ServerIn ProcessId - | ServerMeta ProcessId - | AllServers +data ServerLogMsg + = ServerLogMsg ServerLogMsgType String + | ServerLogEnd +data ServerLogMsgType + = ServerOut ProcessId + | ServerErr ProcessId + | ServerIn ProcessId + | ServerMeta ProcessId + | AllServers data ServerResult = ServerResult - { serverResultTestCode :: TestCode - , serverResultCommand :: String - , serverResultStdout :: String - , serverResultStderr :: String - } + { serverResultTestCode :: TestCode + , serverResultCommand :: String + , serverResultStdout :: String + , serverResultStderr :: String + } -- | With 'ScriptEnv', create a new GHCi 'Server' session. -- When @f@ returns, the server is terminated and no longer -- valid. withNewServer :: Chan ServerLogMsg -> ScriptEnv -> (Server -> IO a) -> IO a withNewServer chan senv f = - bracketWithInit (startServer chan senv) initServer stopServer f + bracketWithInit (startServer chan senv) initServer stopServer f -- | Like 'bracket', but with an initialization function on the resource -- which will be called, unmasked, on the resource to transform it @@ -112,8 +113,8 @@ bracketWithInit :: IO a -> (a -> IO a) -> (a -> IO b) -> (a -> IO c) -> IO c bracketWithInit before initialize after thing = mask $ \restore -> do a0 <- before - a <- restore (initialize a0) `onException` uninterruptibleMask_ (after a0) - r <- restore (thing a) `onException` uninterruptibleMask_ (after a) + a <- restore (initialize a0) `onException` uninterruptibleMask_ (after a0) + r <- restore (thing a) `onException` uninterruptibleMask_ (after a) _ <- uninterruptibleMask_ (after a) return r @@ -131,81 +132,89 @@ bracketWithInit before initialize after thing = -- -- * Current working directory and environment overrides -- are currently not implemented. --- -runOnServer :: Server -> Maybe FilePath -> [(String, Maybe String)] - -> FilePath -> [String] -> IO ServerResult +runOnServer + :: Server + -> Maybe FilePath + -> [(String, Maybe String)] + -> FilePath + -> [String] + -> IO ServerResult runOnServer s mb_cwd env_overrides script_path args = do - -- TODO: cwd not implemented - when (isJust mb_cwd) $ error "runOnServer change directory not implemented" - -- TODO: env_overrides not implemented - unless (null env_overrides) $ error "runOnServer set environment not implemented" - - -- Set arguments returned by System.getArgs - write s $ ":set args " ++ show args - -- Output start sigil (do it here so we pick up compilation - -- failures) - write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show start_sigil - write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show start_sigil - _ <- readUntilSigil s start_sigil IsOut - _ <- readUntilSigil s start_sigil IsErr - -- Drain the output produced by the script as we are running so that - -- we do not deadlock over a full pipe. - withAsync (readUntilEnd s IsOut) $ \a_exit_out -> do + -- TODO: cwd not implemented + when (isJust mb_cwd) $ error "runOnServer change directory not implemented" + -- TODO: env_overrides not implemented + unless (null env_overrides) $ error "runOnServer set environment not implemented" + + -- Set arguments returned by System.getArgs + write s $ ":set args " ++ show args + -- Output start sigil (do it here so we pick up compilation + -- failures) + write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show start_sigil + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show start_sigil + _ <- readUntilSigil s start_sigil IsOut + _ <- readUntilSigil s start_sigil IsErr + -- Drain the output produced by the script as we are running so that + -- we do not deadlock over a full pipe. + withAsync (readUntilEnd s IsOut) $ \a_exit_out -> do withAsync (readUntilSigil s end_sigil IsErr) $ \a_err -> do - -- NB: No :set prog; don't rely on this value in test scripts, - -- we pass it in via the arguments - -- NB: load drops all bindings, which is GOOD. Avoid holding onto - -- garbage. - write s $ ":load " ++ script_path - -- Create a ref which will record the exit status of the command - -- NB: do this after :load so it doesn't get dropped - write s $ "ref <- Data.IORef.newIORef Test.Cabal.TestCode.TestCodeFail" - -- TODO: What if an async exception gets raised here? At the - -- moment, there is no way to recover until we get to the top-level - -- bracket; then stopServer which correctly handles this case. - -- If you do want to be able to abort this computation but KEEP - -- USING THE SERVER SESSION, you will need to have a lot more - -- sophisticated logic. - write s $ "Test.Cabal.Server.runMain ref Main.main" - -- Output end sigil. - -- NB: We're line-oriented, so we MUST add an extra newline - -- to ensure that we see the end sigil. - write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show "" - write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show "" - write s $ "Data.IORef.readIORef ref >>= \\e -> " ++ - " System.IO.hPutStrLn System.IO.stdout (" ++ show end_sigil ++ " ++ \" \" ++ show e)" - write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show end_sigil - (code, out) <- wait a_exit_out - err <- wait a_err - - -- Give the user some indication about how they could run the - -- command by hand. - (real_path, real_args) <- runnerCommand (serverScriptEnv s) mb_cwd env_overrides script_path args - return ServerResult { - serverResultTestCode = code, - serverResultCommand = showCommandForUser real_path real_args, - serverResultStdout = out, - serverResultStderr = err - } + -- NB: No :set prog; don't rely on this value in test scripts, + -- we pass it in via the arguments + -- NB: load drops all bindings, which is GOOD. Avoid holding onto + -- garbage. + write s $ ":load " ++ script_path + -- Create a ref which will record the exit status of the command + -- NB: do this after :load so it doesn't get dropped + write s $ "ref <- Data.IORef.newIORef Test.Cabal.TestCode.TestCodeFail" + -- TODO: What if an async exception gets raised here? At the + -- moment, there is no way to recover until we get to the top-level + -- bracket; then stopServer which correctly handles this case. + -- If you do want to be able to abort this computation but KEEP + -- USING THE SERVER SESSION, you will need to have a lot more + -- sophisticated logic. + write s $ "Test.Cabal.Server.runMain ref Main.main" + -- Output end sigil. + -- NB: We're line-oriented, so we MUST add an extra newline + -- to ensure that we see the end sigil. + write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show "" + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show "" + write s $ + "Data.IORef.readIORef ref >>= \\e -> " + ++ " System.IO.hPutStrLn System.IO.stdout (" + ++ show end_sigil + ++ " ++ \" \" ++ show e)" + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show end_sigil + (code, out) <- wait a_exit_out + err <- wait a_err + + -- Give the user some indication about how they could run the + -- command by hand. + (real_path, real_args) <- runnerCommand (serverScriptEnv s) mb_cwd env_overrides script_path args + return + ServerResult + { serverResultTestCode = code + , serverResultCommand = showCommandForUser real_path real_args + , serverResultStdout = out + , serverResultStderr = err + } -- | Helper function which we use in the GHCi session to communicate -- the exit code of the process. runMain :: IORef TestCode -> IO () -> IO () runMain ref m = do - E.catch (m >> writeIORef ref TestCodeOk) serverHandler + E.catch (m >> writeIORef ref TestCodeOk) serverHandler where serverHandler :: SomeException -> IO () serverHandler e = do - -- TODO: Probably a few more cases you could handle; - -- e.g., StackOverflow should return ExitCode 2; also signals. - writeIORef ref $ case fromException e of - Just test_code -> test_code - _ -> TestCodeFail - - -- Only rethrow for non ExitFailure exceptions - case fromException e :: Maybe TestCode of - Just _ -> return () - _ -> throwIO e + -- TODO: Probably a few more cases you could handle; + -- e.g., StackOverflow should return ExitCode 2; also signals. + writeIORef ref $ case fromException e of + Just test_code -> test_code + _ -> TestCodeFail + + -- Only rethrow for non ExitFailure exceptions + case fromException e :: Maybe TestCode of + Just _ -> return () + _ -> throwIO e -- ----------------------------------------------------------------- -- -- Initialize/tear down @@ -214,149 +223,154 @@ runMain ref m = do -- | Start a new GHCi session. startServer :: Chan ServerLogMsg -> ScriptEnv -> IO Server startServer chan senv = do - (prog, _) <- requireProgram verbosity ghcProgram (runnerProgramDb senv) - let ghc_args = runnerGhcArgs senv ++ ["--interactive", "-v0", "-ignore-dot-ghci"] - proc_spec = (proc (programPath prog) ghc_args) { - create_group = True, - -- Closing fds is VERY important to avoid - -- deadlock; we won't see the end of a - -- stream until everyone gives up. - close_fds = True, - std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - when (verbosity >= verbose) $ - writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args)) - (Just hin, Just hout, Just herr, proch) <- createProcess proc_spec - out_acc <- newMVar [] - err_acc <- newMVar [] - tid <- myThreadId - return Server { - serverStdin = hin, - serverStdout = hout, - serverStderr = herr, - serverProcessHandle = proch, - serverProcessId = show tid, - serverLogChan = chan, - serverStdoutAccum = out_acc, - serverStderrAccum = err_acc, - serverScriptEnv = senv - } + (prog, _) <- requireProgram verbosity ghcProgram (runnerProgramDb senv) + let ghc_args = runnerGhcArgs senv ++ ["--interactive", "-v0", "-ignore-dot-ghci"] + proc_spec = + (proc (programPath prog) ghc_args) + { create_group = True + , -- Closing fds is VERY important to avoid + -- deadlock; we won't see the end of a + -- stream until everyone gives up. + close_fds = True + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + when (verbosity >= verbose) $ + writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args)) + (Just hin, Just hout, Just herr, proch) <- createProcess proc_spec + out_acc <- newMVar [] + err_acc <- newMVar [] + tid <- myThreadId + return + Server + { serverStdin = hin + , serverStdout = hout + , serverStderr = herr + , serverProcessHandle = proch + , serverProcessId = show tid + , serverLogChan = chan + , serverStdoutAccum = out_acc + , serverStderrAccum = err_acc + , serverScriptEnv = senv + } where verbosity = runnerVerbosity senv +{- FOURMOLU_DISABLE -} -- | Unmasked initialization for the server initServer :: Server -> IO Server initServer s0 = do - -- NB: withProcessHandle reads an MVar and is interruptible + -- NB: withProcessHandle reads an MVar and is interruptible - pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> - case ph of + pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> + case ph of #if mingw32_HOST_OS - OpenHandle x -> fmap show (Win32.getProcessId x) + OpenHandle x -> fmap show (Win32.getProcessId x) #else - OpenHandle x -> return (show x) + OpenHandle x -> return (show x) #endif - -- TODO: handle OpenExtHandle? - _ -> return (serverProcessId s0) - - let s = s0 { serverProcessId = pid } - -- We will read/write a line at a time, including for - -- output; our demarcation tokens are an entire line. - forM_ [serverStdin, serverStdout, serverStderr] $ \f -> do - hSetBuffering (f s) LineBuffering - hSetEncoding (f s) utf8 - write s ":set prompt \"\"" - write s "System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering" - return s + -- TODO: handle OpenExtHandle? + _ -> return (serverProcessId s0) + + let s = s0{serverProcessId = pid} + -- We will read/write a line at a time, including for + -- output; our demarcation tokens are an entire line. + forM_ [serverStdin, serverStdout, serverStderr] $ \f -> do + hSetBuffering (f s) LineBuffering + hSetEncoding (f s) utf8 + write s ":set prompt \"\"" + write s "System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering" + return s +{- FOURMOLU_ENABLE -} -- | Stop a GHCi session. stopServer :: Server -> IO () stopServer s = do - -- This is quite a bit of funny business. - -- On Linux, terminateProcess will send a SIGINT, which - -- GHCi will swallow and actually only use to terminate - -- whatever computation is going on at that time. So we - -- have to follow up with an actual :quit command to - -- finish it up (if you delete it, the processes will - -- hang around). On Windows, this will just actually kill - -- the process so the rest should be unnecessary. - mb_exit <- getProcessExitCode (serverProcessHandle s) - - let hardKiller = do - threadDelay 2000000 -- 2sec - log ServerMeta s $ "Terminating..." - terminateProcess (serverProcessHandle s) - softKiller = do - -- Ask to quit. If we're in the middle of a computation, - -- this will buffer up (unless the program is intercepting - -- stdin, but that should NOT happen.) - ignore $ write s ":quit" - - -- NB: it's important that we used create_group. We - -- run this AFTER write s ":quit" because if we C^C - -- sufficiently early in GHCi startup process, GHCi - -- will actually die, and then hClose will fail because - -- the ":quit" command was buffered up but never got - -- flushed. - interruptProcessGroupOf (serverProcessHandle s) - - log ServerMeta s $ "Waiting..." - -- Close input BEFORE waiting, close output AFTER waiting. - -- If you get either order wrong, deadlock! - ignoreSigPipe $ hClose (serverStdin s) - -- waitForProcess has race condition - -- https://github.com/haskell/process/issues/46 - waitForProcess $ serverProcessHandle s - - let drain f = do - r <- hGetContents (f s) - _ <- evaluate (length r) - hClose (f s) - return r - - withAsync (drain serverStdout) $ \a_out -> do + -- This is quite a bit of funny business. + -- On Linux, terminateProcess will send a SIGINT, which + -- GHCi will swallow and actually only use to terminate + -- whatever computation is going on at that time. So we + -- have to follow up with an actual :quit command to + -- finish it up (if you delete it, the processes will + -- hang around). On Windows, this will just actually kill + -- the process so the rest should be unnecessary. + mb_exit <- getProcessExitCode (serverProcessHandle s) + + let hardKiller = do + threadDelay 2000000 -- 2sec + log ServerMeta s $ "Terminating..." + terminateProcess (serverProcessHandle s) + softKiller = do + -- Ask to quit. If we're in the middle of a computation, + -- this will buffer up (unless the program is intercepting + -- stdin, but that should NOT happen.) + ignore $ write s ":quit" + + -- NB: it's important that we used create_group. We + -- run this AFTER write s ":quit" because if we C^C + -- sufficiently early in GHCi startup process, GHCi + -- will actually die, and then hClose will fail because + -- the ":quit" command was buffered up but never got + -- flushed. + interruptProcessGroupOf (serverProcessHandle s) + + log ServerMeta s $ "Waiting..." + -- Close input BEFORE waiting, close output AFTER waiting. + -- If you get either order wrong, deadlock! + ignoreSigPipe $ hClose (serverStdin s) + -- waitForProcess has race condition + -- https://github.com/haskell/process/issues/46 + waitForProcess $ serverProcessHandle s + + let drain f = do + r <- hGetContents (f s) + _ <- evaluate (length r) + hClose (f s) + return r + + withAsync (drain serverStdout) $ \a_out -> do withAsync (drain serverStderr) $ \a_err -> do - - r <- case mb_exit of + r <- case mb_exit of Nothing -> do - log ServerMeta s $ "Terminating GHCi" - race hardKiller softKiller + log ServerMeta s $ "Terminating GHCi" + race hardKiller softKiller Just exit -> do - log ServerMeta s $ "GHCi died unexpectedly" - return (Right exit) - - -- Drain the output buffers - rest_out <- wait a_out - rest_err <- wait a_err - if r /= Right ExitSuccess && - r /= Right (ExitFailure (-2)) -- SIGINT; happens frequently for some reason - then do withMVar (serverStdoutAccum s) $ \acc -> - mapM_ (info ServerOut s) (reverse acc) - info ServerOut s rest_out - withMVar (serverStderrAccum s) $ \acc -> - mapM_ (info ServerErr s) (reverse acc) - info ServerErr s rest_err - info ServerMeta s $ - (case r of - Left () -> "GHCi was forcibly terminated" - Right exit -> "GHCi exited with " ++ show exit) ++ - if verbosity < verbose - then " (use -v for more information)" - else "" + log ServerMeta s $ "GHCi died unexpectedly" + return (Right exit) + + -- Drain the output buffers + rest_out <- wait a_out + rest_err <- wait a_err + if r /= Right ExitSuccess + && r /= Right (ExitFailure (-2)) -- SIGINT; happens frequently for some reason + then do + withMVar (serverStdoutAccum s) $ \acc -> + mapM_ (info ServerOut s) (reverse acc) + info ServerOut s rest_out + withMVar (serverStderrAccum s) $ \acc -> + mapM_ (info ServerErr s) (reverse acc) + info ServerErr s rest_err + info ServerMeta s $ + ( case r of + Left () -> "GHCi was forcibly terminated" + Right exit -> "GHCi exited with " ++ show exit + ) + ++ if verbosity < verbose + then " (use -v for more information)" + else "" else log ServerOut s rest_out - log ServerMeta s $ "Done" - return () + log ServerMeta s $ "Done" + return () where verbosity = runnerVerbosity (serverScriptEnv s) ignoreSigPipe :: IO () -> IO () ignoreSigPipe = E.handle $ \e -> case e of - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e + GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe} + | Errno ioe == ePIPE -> return () + _ -> throwIO e -- Using the procedure from -- https://www.schoolofhaskell.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions @@ -369,26 +383,26 @@ ignore m = withAsync m $ \a -> void (waitCatch a) log :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO () log ctor s msg = - when (verbosity >= verbose) $ info ctor s msg + when (verbosity >= verbose) $ info ctor s msg where verbosity = runnerVerbosity (serverScriptEnv s) info :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO () info ctor s msg = - writeChan chan (ServerLogMsg (ctor (serverProcessId s)) msg) + writeChan chan (ServerLogMsg (ctor (serverProcessId s)) msg) where chan = serverLogChan s -- | Write a string to the prompt of the GHCi server. write :: Server -> String -> IO () write s msg = do - log ServerIn s $ msg - hPutStrLn (serverStdin s) msg - hFlush (serverStdin s) -- line buffering should get it, but just for good luck + log ServerIn s $ msg + hPutStrLn (serverStdin s) msg + hFlush (serverStdin s) -- line buffering should get it, but just for good luck accumulate :: MVar [String] -> String -> IO () accumulate acc msg = - modifyMVar_ acc (\msgs -> return (msg:msgs)) + modifyMVar_ acc (\msgs -> return (msg : msgs)) flush :: MVar [String] -> IO [String] flush acc = modifyMVar acc (\msgs -> return ([], reverse msgs)) @@ -413,12 +427,13 @@ outOrErrMsgType IsErr = ServerErr -- send a command to GHCi to emit the start sigil. readUntilSigil :: Server -> String -> OutOrErr -> IO String readUntilSigil s sigil outerr = do - l <- hGetLine (serverHandle s outerr) - log (outOrErrMsgType outerr) s l - if sigil `isPrefixOf` l -- NB: on Windows there might be extra goo at end - then intercalate "\n" `fmap` flush (serverAccum s outerr) - else do accumulate (serverAccum s outerr) l - readUntilSigil s sigil outerr + l <- hGetLine (serverHandle s outerr) + log (outOrErrMsgType outerr) s l + if sigil `isPrefixOf` l -- NB: on Windows there might be extra goo at end + then intercalate "\n" `fmap` flush (serverAccum s outerr) + else do + accumulate (serverAccum s outerr) l + readUntilSigil s sigil outerr -- | Consume output from the GHCi server until we hit the -- end sigil. Return the consumed output as well as the @@ -427,18 +442,20 @@ readUntilEnd :: Server -> OutOrErr -> IO (TestCode, String) readUntilEnd s outerr = go [] where go rs = do - l <- hGetLine (serverHandle s outerr) - log (outOrErrMsgType outerr) s l - if end_sigil `isPrefixOf` l - -- NB: NOT unlines, we don't want the trailing newline! - then do exit <- evaluate (parseExit l) - _ <- flush (serverAccum s outerr) -- TODO: don't toss this out - return (exit, intercalate "\n" (reverse rs)) - else do accumulate (serverAccum s outerr) l - go (l:rs) + l <- hGetLine (serverHandle s outerr) + log (outOrErrMsgType outerr) s l + if end_sigil `isPrefixOf` l + then -- NB: NOT unlines, we don't want the trailing newline! + do + exit <- evaluate (parseExit l) + _ <- flush (serverAccum s outerr) -- TODO: don't toss this out + return (exit, intercalate "\n" (reverse rs)) + else do + accumulate (serverAccum s outerr) l + go (l : rs) parseExit l = case readMaybe (drop (length end_sigil) l) of - Nothing -> error $ "Cannot parse TestCode at the end of: " ++ l - Just tc -> tc + Nothing -> error $ "Cannot parse TestCode at the end of: " ++ l + Just tc -> tc -- | The start and end sigils. This should be chosen to be -- reasonably unique, so that test scripts don't accidentally @@ -446,4 +463,4 @@ readUntilEnd s outerr = go [] -- probably deadlock. start_sigil, end_sigil :: String start_sigil = "BEGIN Test.Cabal.Server" -end_sigil = "END Test.Cabal.Server" +end_sigil = "END Test.Cabal.Server" diff --git a/cabal-testsuite/src/Test/Cabal/TestCode.hs b/cabal-testsuite/src/Test/Cabal/TestCode.hs index e29c9ea6b45..5ce151dcdb2 100644 --- a/cabal-testsuite/src/Test/Cabal/TestCode.hs +++ b/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} + -- | Exception type like 'ExitCode' but with more information -- than just integer. -module Test.Cabal.TestCode ( - -- * TestCode - TestCode (..), - displayTestCode, - isTestCodeSkip, -) where +module Test.Cabal.TestCode + ( -- * TestCode + TestCode (..) + , displayTestCode + , isTestCodeSkip + ) where import Control.Exception (Exception (..)) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable) ------------------------------------------------------------------------------- -- TestCode ------------------------------------------------------------------------------- data TestCode - = TestCodeOk - | TestCodeSkip String - | TestCodeKnownFail - | TestCodeUnexpectedOk - | TestCodeFail + = TestCodeOk + | TestCodeSkip String + | TestCodeKnownFail + | TestCodeUnexpectedOk + | TestCodeFail deriving (Eq, Show, Read, Typeable) instance Exception TestCode @@ -31,12 +32,12 @@ instance Exception TestCode #endif displayTestCode :: TestCode -> String -displayTestCode TestCodeOk = "OK" -displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg -displayTestCode TestCodeKnownFail = "OK (known failure)" +displayTestCode TestCodeOk = "OK" +displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg +displayTestCode TestCodeKnownFail = "OK (known failure)" displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" -displayTestCode TestCodeFail = "FAIL" +displayTestCode TestCodeFail = "FAIL" isTestCodeSkip :: TestCode -> Bool isTestCodeSkip (TestCodeSkip _) = True -isTestCodeSkip _ = False +isTestCodeSkip _ = False diff --git a/cabal-testsuite/src/Test/Cabal/Workdir.hs b/cabal-testsuite/src/Test/Cabal/Workdir.hs index 063c321201d..f83f6161cbe 100644 --- a/cabal-testsuite/src/Test/Cabal/Workdir.hs +++ b/cabal-testsuite/src/Test/Cabal/Workdir.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} + -- | Functions for interrogating the current working directory module Test.Cabal.Workdir where -import Distribution.Simple.Setup import Distribution.Simple.Configure +import Distribution.Simple.Setup import System.Directory import System.FilePath @@ -26,5 +27,6 @@ guessDistDir = do let dist0 = error "no path" b = False #endif - if b then canonicalizePath dist0 - else findDistPrefOrDefault NoFlag >>= canonicalizePath + if b + then canonicalizePath dist0 + else findDistPrefOrDefault NoFlag >>= canonicalizePath diff --git a/cabal-testsuite/tests/fail.test.hs b/cabal-testsuite/tests/fail.test.hs index bd2d5a96005..3842973043a 100644 --- a/cabal-testsuite/tests/fail.test.hs +++ b/cabal-testsuite/tests/fail.test.hs @@ -1,8 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} -import Test.Cabal.Prelude -import Data.IORef -import Control.Monad.IO.Class + import Control.Exception (ErrorCall) +import Control.Monad.IO.Class +import Data.IORef +import Test.Cabal.Prelude import qualified Control.Monad.Catch as Catch diff --git a/cabal-testsuite/tests/ok.test.hs b/cabal-testsuite/tests/ok.test.hs index 3e03980e21c..8ffaa2877ec 100644 --- a/cabal-testsuite/tests/ok.test.hs +++ b/cabal-testsuite/tests/ok.test.hs @@ -1,2 +1,3 @@ import Test.Cabal.Prelude + main = return () diff --git a/solver-benchmarks/HackageBenchmark.hs b/solver-benchmarks/HackageBenchmark.hs index d650f38e56a..5692370a6c6 100644 --- a/solver-benchmarks/HackageBenchmark.hs +++ b/solver-benchmarks/HackageBenchmark.hs @@ -1,13 +1,12 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module HackageBenchmark ( - hackageBenchmarkMain - --- Exposed for testing: - , CabalResult(..) +module HackageBenchmark + ( hackageBenchmarkMain + -- Exposed for testing: + , CabalResult (..) , isSignificantTimeDifference , combineTrialResults , isSignificantResult @@ -17,46 +16,63 @@ module HackageBenchmark ( import Control.Concurrent.Async (concurrently) import Control.Monad (forM, replicateM, unless, when) import qualified Data.ByteString as BS +import Data.Function ((&)) import Data.List (nub, unzip4) -import Data.Maybe (isJust, catMaybes) +import Data.Maybe (catMaybes, isJust) import Data.Monoid ((<>)) import Data.String (fromString) -import Data.Function ((&)) import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) import qualified Data.Vector.Unboxed as V import Options.Applicative -import Statistics.Sample (mean, stdDev, geometricMean) -import Statistics.Test.MannWhitneyU ( PositionTest(..), TestResult(..) - , mannWhitneyUCriticalValue - , mannWhitneyUtest) +import Statistics.Sample (geometricMean, mean, stdDev) +import Statistics.Test.MannWhitneyU + ( PositionTest (..) + , TestResult (..) + , mannWhitneyUCriticalValue + , mannWhitneyUtest + ) import Statistics.Types (PValue, mkPValue) -import System.Directory (getTemporaryDirectory, createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) import System.Environment (getEnvironment) -import System.Exit (ExitCode(..), exitWith, exitFailure) +import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (()) -import System.IO ( BufferMode(LineBuffering), hPutStrLn, hSetBuffering, stderr - , stdout) -import System.Process ( StdStream(CreatePipe), CreateProcess(..), callProcess - , createProcess, readProcess, shell, waitForProcess, proc, readCreateProcessWithExitCode ) +import System.IO + ( BufferMode (LineBuffering) + , hPutStrLn + , hSetBuffering + , stderr + , stdout + ) +import System.Process + ( CreateProcess (..) + , StdStream (CreatePipe) + , callProcess + , createProcess + , proc + , readCreateProcessWithExitCode + , readProcess + , shell + , waitForProcess + ) import Text.Printf (printf) import qualified Data.Map.Strict as Map import Distribution.Package (PackageName, mkPackageName, unPackageName) -data Args = Args { - argCabal1 :: FilePath - , argCabal2 :: FilePath - , argCabal1Flags :: [String] - , argCabal2Flags :: [String] - , argPackages :: [PackageName] +data Args = Args + { argCabal1 :: FilePath + , argCabal2 :: FilePath + , argCabal1Flags :: [String] + , argCabal2Flags :: [String] + , argPackages :: [PackageName] , argMinRunTimeDifferenceToRerun :: Double - , argPValue :: PValue Double - , argTrials :: Int - , argConcurrently :: Bool - , argPrintTrials :: Bool - , argPrintSkippedPackages :: Bool - , argTimeoutSeconds :: Int + , argPValue :: PValue Double + , argTrials :: Int + , argConcurrently :: Bool + , argPrintTrials :: Bool + , argPrintSkippedPackages :: Bool + , argTimeoutSeconds :: Int } data CabalTrial = CabalTrial NominalDiffTime CabalResult @@ -77,20 +93,22 @@ data CabalResult hackageBenchmarkMain :: IO () hackageBenchmarkMain = do hSetBuffering stdout LineBuffering - args@Args {..} <- execParser parserInfo + args@Args{..} <- execParser parserInfo checkArgs args printConfig args pkgs <- getPackages args putStrLn "" let concurrently' :: IO a -> IO b -> IO (a, b) - concurrently' | argConcurrently = concurrently - | otherwise = \ma mb -> do { a <- ma; b <- mb; return (a, b) } + concurrently' + | argConcurrently = concurrently + | otherwise = \ma mb -> do a <- ma; b <- mb; return (a, b) - let -- The maximum length of the heading and package names. - nameColumnWidth :: Int - nameColumnWidth = - maximum $ map length $ "package" : map unPackageName pkgs + let + -- The maximum length of the heading and package names. + nameColumnWidth :: Int + nameColumnWidth = + maximum $ map length $ "package" : map unPackageName pkgs -- create cabal runners runCabal1 <- runCabal argTimeoutSeconds CabalUnderTest1 argCabal1 argCabal1Flags @@ -100,77 +118,103 @@ hackageBenchmarkMain = do -- "trial" or "summary". when argPrintTrials $ putStr $ printf "%-16s " "trial/summary" putStrLn $ - printf "%-*s %-14s %-14s %11s %11s %11s %11s %11s" - nameColumnWidth "package" "result1" "result2" - "mean1" "mean2" "stddev1" "stddev2" "speedup" + printf + "%-*s %-14s %-14s %11s %11s %11s %11s %11s" + nameColumnWidth + "package" + "result1" + "result2" + "mean1" + "mean2" + "stddev1" + "stddev2" + "speedup" speedups :: [Double] <- fmap catMaybes $ forM pkgs $ \pkg -> do let printTrial msgType result1 result2 time1 time2 = - putStrLn $ - printf "%-16s %-*s %-14s %-14s %10.3fs %10.3fs" - msgType nameColumnWidth (unPackageName pkg) - (show result1) (show result2) - (diffTimeToDouble time1) (diffTimeToDouble time2) + putStrLn $ + printf + "%-16s %-*s %-14s %-14s %10.3fs %10.3fs" + msgType + nameColumnWidth + (unPackageName pkg) + (show result1) + (show result2) + (diffTimeToDouble time1) + (diffTimeToDouble time2) (CabalTrial t1 r1, CabalTrial t2 r2) <- runCabal1 pkg `concurrently'` runCabal2 pkg if not $ - shouldContinueAfterFirstTrial argMinRunTimeDifferenceToRerun t1 t2 r1 r2 - then do - when argPrintSkippedPackages $ - if argPrintTrials - then printTrial "trial (skipping)" r1 r2 t1 t2 - else putStrLn $ printf "%-*s (first run times were too similar)" - nameColumnWidth (unPackageName pkg) - return Nothing - else do - when argPrintTrials $ printTrial "trial" r1 r2 t1 t2 - (ts1, ts2, rs1, rs2) <- (unzip4 . ((t1, t2, r1, r2) :) <$>) - . replicateM (argTrials - 1) $ do - - (CabalTrial t1' r1', CabalTrial t2' r2') <- runCabal1 pkg `concurrently'` runCabal2 pkg - when argPrintTrials $ printTrial "trial" r1' r2' t1' t2' - return (t1', t2', r1', r2') - - let result1 = combineTrialResults rs1 - result2 = combineTrialResults rs2 - times1 = V.fromList (map diffTimeToDouble ts1) - times2 = V.fromList (map diffTimeToDouble ts2) - mean1 = mean times1 - mean2 = mean times2 - stddev1 = stdDev times1 - stddev2 = stdDev times2 - speedup = mean1 / mean2 - - when argPrintTrials $ putStr $ printf "%-16s " "summary" - if isSignificantResult result1 result2 + shouldContinueAfterFirstTrial argMinRunTimeDifferenceToRerun t1 t2 r1 r2 + then do + when argPrintSkippedPackages $ + if argPrintTrials + then printTrial "trial (skipping)" r1 r2 t1 t2 + else + putStrLn $ + printf + "%-*s (first run times were too similar)" + nameColumnWidth + (unPackageName pkg) + return Nothing + else do + when argPrintTrials $ printTrial "trial" r1 r2 t1 t2 + (ts1, ts2, rs1, rs2) <- (unzip4 . ((t1, t2, r1, r2) :) <$>) + . replicateM (argTrials - 1) + $ do + (CabalTrial t1' r1', CabalTrial t2' r2') <- runCabal1 pkg `concurrently'` runCabal2 pkg + when argPrintTrials $ printTrial "trial" r1' r2' t1' t2' + return (t1', t2', r1', r2') + + let result1 = combineTrialResults rs1 + result2 = combineTrialResults rs2 + times1 = V.fromList (map diffTimeToDouble ts1) + times2 = V.fromList (map diffTimeToDouble ts2) + mean1 = mean times1 + mean2 = mean times2 + stddev1 = stdDev times1 + stddev2 = stdDev times2 + speedup = mean1 / mean2 + + when argPrintTrials $ putStr $ printf "%-16s " "summary" + if isSignificantResult result1 result2 || isSignificantTimeDifference argPValue ts1 ts2 - then putStrLn $ - printf "%-*s %-14s %-14s %10.3fs %10.3fs %10.3fs %10.3fs %10.3f" - nameColumnWidth (unPackageName pkg) - (show result1) (show result2) mean1 mean2 stddev1 stddev2 speedup - else when (argPrintTrials || argPrintSkippedPackages) $ - putStrLn $ - printf "%-*s (not significant, speedup = %10.3f)" nameColumnWidth (unPackageName pkg) speedup - - -- return speedup value - return (Just speedup) + then + putStrLn $ + printf + "%-*s %-14s %-14s %10.3fs %10.3fs %10.3fs %10.3fs %10.3f" + nameColumnWidth + (unPackageName pkg) + (show result1) + (show result2) + mean1 + mean2 + stddev1 + stddev2 + speedup + else + when (argPrintTrials || argPrintSkippedPackages) $ + putStrLn $ + printf "%-*s (not significant, speedup = %10.3f)" nameColumnWidth (unPackageName pkg) speedup + + -- return speedup value + return (Just speedup) -- finally, calculate the geometric mean of speedups printf "Geometric mean of %d packages' speedups is %10.3f\n" (length speedups) (geometricMean (V.fromList speedups)) - where checkArgs :: Args -> IO () - checkArgs Args {..} = do + checkArgs Args{..} = do let die msg = hPutStrLn stderr msg >> exitFailure unless (argTrials > 0) $ die "--trials must be greater than 0." unless (argMinRunTimeDifferenceToRerun >= 0) $ - die "--min-run-time-percentage-difference-to-rerun must be non-negative." + die "--min-run-time-percentage-difference-to-rerun must be non-negative." unless (isSampleLargeEnough argPValue argTrials) $ - die "p-value is too small for the number of trials." + die "p-value is too small for the number of trials." printConfig :: Args -> IO () - printConfig Args {..} = do + printConfig Args{..} = do putStrLn "Comparing:" putStrLn $ "1: " ++ argCabal1 ++ " " ++ unwords argCabal1Flags callProcess argCabal1 ["--version"] @@ -181,9 +225,9 @@ hackageBenchmarkMain = do callProcess "ghc-pkg" ["list"] getPackages :: Args -> IO [PackageName] - getPackages Args {..} = do + getPackages Args{..} = do pkgs <- - if null argPackages + if null argPackages then do putStrLn $ "Obtaining the package list (using " ++ argCabal1 ++ ") ..." list <- readProcess argCabal1 ["list", "--simple-output"] "" @@ -197,16 +241,22 @@ hackageBenchmarkMain = do data CabalUnderTest = CabalUnderTest1 | CabalUnderTest2 runCabal - :: Int -- ^ timeout in seconds - -> CabalUnderTest -- ^ cabal under test - -> FilePath -- ^ cabal - -> [String] -- ^ flags - -> IO (PackageName -> IO CabalTrial) -- ^ testing function. + :: Int + -- ^ timeout in seconds + -> CabalUnderTest + -- ^ cabal under test + -> FilePath + -- ^ cabal + -> [String] + -- ^ flags + -> IO (PackageName -> IO CabalTrial) + -- ^ testing function. runCabal timeoutSeconds cabalUnderTest cabal flags = do tmpDir <- getTemporaryDirectory -- cabal directory for this cabal under test - let cabalDir = tmpDir "solver-benchmarks-workdir" case cabalUnderTest of + let cabalDir = + tmpDir "solver-benchmarks-workdir" case cabalUnderTest of CabalUnderTest1 -> "cabal1" CabalUnderTest2 -> "cabal2" @@ -214,57 +264,54 @@ runCabal timeoutSeconds cabalUnderTest cabal flags = do createDirectoryIfMissing True cabalDir -- shell environment - currEnv <- Map.fromList <$> getEnvironment + currEnv <- Map.fromList <$> getEnvironment let thisEnv :: [(String, String)] - thisEnv = Map.toList $ currEnv - & Map.insert "CABAL_CONFIG" (cabalDir "config") - & Map.insert "CABAL_DIR" cabalDir + thisEnv = + Map.toList $ + currEnv + & Map.insert "CABAL_CONFIG" (cabalDir "config") + & Map.insert "CABAL_DIR" cabalDir -- Run cabal update, putStrLn $ "Running cabal update (using " ++ cabal ++ ") ..." - (ec, uout, uerr) <- readCreateProcessWithExitCode (proc cabal ["update"]) - { cwd = Just cabalDir - , env = Just thisEnv - } + (ec, uout, uerr) <- + readCreateProcessWithExitCode + (proc cabal ["update"]) + { cwd = Just cabalDir + , env = Just thisEnv + } "" unless (ec == ExitSuccess) $ do - putStrLn uout - putStrLn uerr - exitWith ec + putStrLn uout + putStrLn uerr + exitWith ec -- return an actual runner return $ \pkg -> do ((exitCode, err), time) <- timeEvent $ do - let timeout = "timeout --foreground -sINT " ++ show timeoutSeconds - cabalCmd = unwords $ + cabalCmd = + unwords $ [ cabal - , "v2-install" - - -- These flags prevent a Cabal project or package environment from + , -- These flags prevent a Cabal project or package environment from -- affecting the install plan. -- -- Note: we are somewhere in /tmp, hopefully there is no cabal.project on upper level - , "--package-env=non-existent-package-env" - - -- --lib allows solving for packages with libraries or + "--package-env=non-existent-package-env" + , -- --lib allows solving for packages with libraries or -- executables. - , "--lib" - + "--lib" , unPackageName pkg - , "--dry-run" - - -- The test doesn't currently handle stdout, so we suppress it + , -- The test doesn't currently handle stdout, so we suppress it -- with silent. nowrap simplifies parsing the errors messages. - , "-vsilent+nowrap" - + "-vsilent+nowrap" ] + ++ flags - ++ flags - - cmd = (shell (timeout ++ " " ++ cabalCmd)) + cmd = + (shell (timeout ++ " " ++ cabalCmd)) { std_err = CreatePipe , env = Just thisEnv , cwd = Just cabalDir @@ -273,75 +320,76 @@ runCabal timeoutSeconds cabalUnderTest cabal flags = do -- TODO: Read stdout and compare the install plans. (_, _, Just errh, ph) <- createProcess cmd err <- BS.hGetContents errh - (, err) <$> waitForProcess ph + (,err) <$> waitForProcess ph let exhaustiveMsg = - "After searching the rest of the dependency tree exhaustively" + "After searching the rest of the dependency tree exhaustively" result - | exitCode == ExitSuccess = Solution - | exitCode == ExitFailure 124 = Timeout - | fromString exhaustiveMsg `BS.isInfixOf` err = NoInstallPlan - | fromString "Backjump limit reached" `BS.isInfixOf` err = BackjumpLimit - | fromString "none of the components are available to build" `BS.isInfixOf` err = Unbuildable - | fromString "Dependency on unbuildable" `BS.isInfixOf` err = UnbuildableDep + | exitCode == ExitSuccess = Solution + | exitCode == ExitFailure 124 = Timeout + | fromString exhaustiveMsg `BS.isInfixOf` err = NoInstallPlan + | fromString "Backjump limit reached" `BS.isInfixOf` err = BackjumpLimit + | fromString "none of the components are available to build" `BS.isInfixOf` err = Unbuildable + | fromString "Dependency on unbuildable" `BS.isInfixOf` err = UnbuildableDep | fromString "Dependency cycle between the following components" `BS.isInfixOf` err = ComponentCycle - | fromString "Problem with module re-exports" `BS.isInfixOf` err = ModReexpIssue - | fromString "There is no package named" `BS.isInfixOf` err = PkgNotFound - | otherwise = Unknown + | fromString "Problem with module re-exports" `BS.isInfixOf` err = ModReexpIssue + | fromString "There is no package named" `BS.isInfixOf` err = PkgNotFound + | otherwise = Unknown return (CabalTrial time result) isSampleLargeEnough :: PValue Double -> Int -> Bool isSampleLargeEnough pvalue trials = - -- mannWhitneyUCriticalValue, which can fail with too few samples, is only - -- used when both sample sizes are less than or equal to 20. - trials > 20 || isJust (mannWhitneyUCriticalValue (trials, trials) pvalue) + -- mannWhitneyUCriticalValue, which can fail with too few samples, is only + -- used when both sample sizes are less than or equal to 20. + trials > 20 || isJust (mannWhitneyUCriticalValue (trials, trials) pvalue) isSignificantTimeDifference :: PValue Double -> [NominalDiffTime] -> [NominalDiffTime] -> Bool isSignificantTimeDifference pvalue xs ys = let toVector = V.fromList . map diffTimeToDouble - in case mannWhitneyUtest SamplesDiffer pvalue (toVector xs) (toVector ys) of - Nothing -> error "not enough data for mannWhitneyUtest" - Just Significant -> True - Just NotSignificant -> False + in case mannWhitneyUtest SamplesDiffer pvalue (toVector xs) (toVector ys) of + Nothing -> error "not enough data for mannWhitneyUtest" + Just Significant -> True + Just NotSignificant -> False -- Should we stop after the first trial of this package to save time? This -- function skips the package if the results are uninteresting and the times are -- within --min-run-time-percentage-difference-to-rerun. -shouldContinueAfterFirstTrial :: Double - -> NominalDiffTime - -> NominalDiffTime - -> CabalResult - -> CabalResult - -> Bool -shouldContinueAfterFirstTrial 0 _ _ _ _ = True -shouldContinueAfterFirstTrial _ _ _ Timeout Timeout = False -shouldContinueAfterFirstTrial maxRunTimeDifferenceToIgnore t1 t2 r1 r2 = - isSignificantResult r1 r2 - || abs (t1 - t2) / min t1 t2 >= realToFrac (maxRunTimeDifferenceToIgnore / 100) +shouldContinueAfterFirstTrial + :: Double + -> NominalDiffTime + -> NominalDiffTime + -> CabalResult + -> CabalResult + -> Bool +shouldContinueAfterFirstTrial 0 _ _ _ _ = True +shouldContinueAfterFirstTrial _ _ _ Timeout Timeout = False +shouldContinueAfterFirstTrial maxRunTimeDifferenceToIgnore t1 t2 r1 r2 = + isSignificantResult r1 r2 + || abs (t1 - t2) / min t1 t2 >= realToFrac (maxRunTimeDifferenceToIgnore / 100) isSignificantResult :: CabalResult -> CabalResult -> Bool isSignificantResult r1 r2 = r1 /= r2 || not (isExpectedResult r1) -- Is this result expected in a benchmark run on all of Hackage? isExpectedResult :: CabalResult -> Bool -isExpectedResult Solution = True -isExpectedResult NoInstallPlan = True -isExpectedResult BackjumpLimit = True -isExpectedResult Timeout = True -isExpectedResult Unbuildable = True +isExpectedResult Solution = True +isExpectedResult NoInstallPlan = True +isExpectedResult BackjumpLimit = True +isExpectedResult Timeout = True +isExpectedResult Unbuildable = True isExpectedResult UnbuildableDep = True isExpectedResult ComponentCycle = True -isExpectedResult ModReexpIssue = True -isExpectedResult PkgNotFound = False -isExpectedResult Unknown = False +isExpectedResult ModReexpIssue = True +isExpectedResult PkgNotFound = False +isExpectedResult Unknown = False -- Combine CabalResults from multiple trials. Ignoring timeouts, all results -- should be the same. If they aren't the same, we returns Unknown. combineTrialResults :: [CabalResult] -> CabalResult combineTrialResults rs - | allEqual rs = head rs + | allEqual rs = head rs | allEqual [r | r <- rs, r /= Timeout] = Timeout - | otherwise = Unknown + | otherwise = Unknown where allEqual :: Eq a => [a] -> Bool allEqual xs = length (nub xs) == 1 @@ -357,71 +405,102 @@ diffTimeToDouble :: NominalDiffTime -> Double diffTimeToDouble = fromRational . toRational parserInfo :: ParserInfo Args -parserInfo = info (argParser <**> helper) - ( fullDesc - <> progDesc ("Find differences between two cabal commands when solving" - ++ " for all packages on Hackage.") - <> header "hackage-benchmark" ) +parserInfo = + info + (argParser <**> helper) + ( fullDesc + <> progDesc + ( "Find differences between two cabal commands when solving" + ++ " for all packages on Hackage." + ) + <> header "hackage-benchmark" + ) argParser :: Parser Args -argParser = Args +argParser = + Args <$> strOption - ( long "cabal1" - <> metavar "PATH" - <> help "First cabal executable") + ( long "cabal1" + <> metavar "PATH" + <> help "First cabal executable" + ) <*> strOption - ( long "cabal2" - <> metavar "PATH" - <> help "Second cabal executable") - <*> option (words <$> str) - ( long "cabal1-flags" - <> value [] - <> metavar "FLAGS" - <> help "Extra flags for the first cabal executable") - <*> option (words <$> str) - ( long "cabal2-flags" - <> value [] - <> metavar "FLAGS" - <> help "Extra flags for the second cabal executable") - <*> option (map mkPackageName . words <$> str) - ( long "packages" - <> value [] - <> metavar "PACKAGES" - <> help ("Space separated list of packages to test, or all of Hackage" - ++ " if unspecified")) - <*> option auto - ( long "min-run-time-percentage-difference-to-rerun" - <> showDefault - <> value 0.0 - <> metavar "PERCENTAGE" - <> help ("Stop testing a package when the difference in run times in" - ++ " the first trial are within this percentage, in order to" - ++ " save time")) - <*> option (mkPValue <$> auto) - ( long "pvalue" - <> showDefault - <> value (mkPValue 0.05) - <> metavar "DOUBLE" - <> help ("p-value used to determine whether to print the results for" - ++ " each package")) - <*> option auto - ( long "trials" - <> showDefault - <> value 10 - <> metavar "N" - <> help "Number of trials for each package") + ( long "cabal2" + <> metavar "PATH" + <> help "Second cabal executable" + ) + <*> option + (words <$> str) + ( long "cabal1-flags" + <> value [] + <> metavar "FLAGS" + <> help "Extra flags for the first cabal executable" + ) + <*> option + (words <$> str) + ( long "cabal2-flags" + <> value [] + <> metavar "FLAGS" + <> help "Extra flags for the second cabal executable" + ) + <*> option + (map mkPackageName . words <$> str) + ( long "packages" + <> value [] + <> metavar "PACKAGES" + <> help + ( "Space separated list of packages to test, or all of Hackage" + ++ " if unspecified" + ) + ) + <*> option + auto + ( long "min-run-time-percentage-difference-to-rerun" + <> showDefault + <> value 0.0 + <> metavar "PERCENTAGE" + <> help + ( "Stop testing a package when the difference in run times in" + ++ " the first trial are within this percentage, in order to" + ++ " save time" + ) + ) + <*> option + (mkPValue <$> auto) + ( long "pvalue" + <> showDefault + <> value (mkPValue 0.05) + <> metavar "DOUBLE" + <> help + ( "p-value used to determine whether to print the results for" + ++ " each package" + ) + ) + <*> option + auto + ( long "trials" + <> showDefault + <> value 10 + <> metavar "N" + <> help "Number of trials for each package" + ) <*> switch - ( long "concurrently" - <> help "Run cabals concurrently") + ( long "concurrently" + <> help "Run cabals concurrently" + ) <*> switch - ( long "print-trials" - <> help "Whether to include the results from individual trials in the output") + ( long "print-trials" + <> help "Whether to include the results from individual trials in the output" + ) <*> switch - ( long "print-skipped-packages" - <> help "Whether to include skipped packages in the output") - <*> option auto - ( long "timeout" - <> showDefault - <> value 90 - <> metavar "SECONDS" - <> help "Maximum time to run a cabal command, in seconds") + ( long "print-skipped-packages" + <> help "Whether to include skipped packages in the output" + ) + <*> option + auto + ( long "timeout" + <> showDefault + <> value 90 + <> metavar "SECONDS" + <> help "Maximum time to run a cabal command, in seconds" + ) diff --git a/solver-benchmarks/tests/HackageBenchmarkTest.hs b/solver-benchmarks/tests/HackageBenchmarkTest.hs index cf220fb4aa1..cf6a5b74e63 100644 --- a/solver-benchmarks/tests/HackageBenchmarkTest.hs +++ b/solver-benchmarks/tests/HackageBenchmarkTest.hs @@ -7,84 +7,87 @@ main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "unit tests" [ - - testGroup "isSignificantTimeDifference" [ - - testCase "detect increase in distribution" $ assertBool "" $ - isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [4,5..10] - - , testCase "detect decrease in distribution" $ assertBool "" $ - isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [-2,-1..4] - - , testCase "ignore same data" $ assertBool "" $ - not $ isSignificantTimeDifference (mkPValue 0.05) [1,2..10] [1,2..10] - - , testCase "same data with high p-value is significant" $ assertBool "" $ - isSignificantTimeDifference (mkPValue 0.9) [1,2..10] [1,2..10] - - , testCase "ignore outlier" $ assertBool "" $ - not $ isSignificantTimeDifference (mkPValue 0.05) [1, 2, 1, 1, 1] [2, 1, 50, 1, 1] - ] - - , testGroup "combineTrialResults" [ - - testCase "convert unexpected difference to Unknown" $ +tests = + testGroup + "unit tests" + [ testGroup + "isSignificantTimeDifference" + [ testCase "detect increase in distribution" $ + assertBool "" $ + isSignificantTimeDifference (mkPValue 0.05) [1, 2 .. 7] [4, 5 .. 10] + , testCase "detect decrease in distribution" $ + assertBool "" $ + isSignificantTimeDifference (mkPValue 0.05) [1, 2 .. 7] [-2, -1 .. 4] + , testCase "ignore same data" $ + assertBool "" $ + not $ + isSignificantTimeDifference (mkPValue 0.05) [1, 2 .. 10] [1, 2 .. 10] + , testCase "same data with high p-value is significant" $ + assertBool "" $ + isSignificantTimeDifference (mkPValue 0.9) [1, 2 .. 10] [1, 2 .. 10] + , testCase "ignore outlier" $ + assertBool "" $ + not $ + isSignificantTimeDifference (mkPValue 0.05) [1, 2, 1, 1, 1] [2, 1, 50, 1, 1] + ] + , testGroup + "combineTrialResults" + [ testCase "convert unexpected difference to Unknown" $ combineTrialResults [NoInstallPlan, BackjumpLimit] @?= Unknown - - , testCase "return one of identical errors" $ + , testCase "return one of identical errors" $ combineTrialResults [NoInstallPlan, NoInstallPlan] @?= NoInstallPlan - - , testCase "return one of identical successes" $ + , testCase "return one of identical successes" $ combineTrialResults [Solution, Solution] @?= Solution - - , testCase "timeout overrides other results" $ + , testCase "timeout overrides other results" $ combineTrialResults [Solution, Timeout, Solution] @?= Timeout - - , testCase "convert unexpected difference to Unknown, even with timeout" $ + , testCase "convert unexpected difference to Unknown, even with timeout" $ combineTrialResults [Solution, Timeout, NoInstallPlan] @?= Unknown + ] + , testGroup + "isSignificantResult" + [ testCase "different results are significant" $ + assertBool "" $ + isSignificantResult NoInstallPlan BackjumpLimit + , testCase "unknown result is significant" $ + assertBool "" $ + isSignificantResult Unknown Unknown + , testCase "PkgNotFound is significant" $ + assertBool "" $ + isSignificantResult PkgNotFound PkgNotFound + , testCase "same expected error is not significant" $ + assertBool "" $ + not $ + isSignificantResult NoInstallPlan NoInstallPlan + , testCase "success is not significant" $ + assertBool "" $ + not $ + isSignificantResult Solution Solution + ] + , testGroup + "shouldContinueAfterFirstTrial" + [ testCase "rerun when min difference is zero" $ + assertBool "" $ + shouldContinueAfterFirstTrial 0 1.0 1.0 Solution Solution + , testCase "rerun when min difference is zero, even with timeout" $ + assertBool "" $ + shouldContinueAfterFirstTrial 0 1.0 1.0 Timeout Timeout + , testCase "treat timeouts as the same time" $ + assertBool "" $ + not $ + shouldContinueAfterFirstTrial 0.000001 89.9 92.0 Timeout Timeout + , testCase "skip when times are too close - 1" $ + assertBool "" $ + not $ + shouldContinueAfterFirstTrial 10 1.0 0.91 Solution Solution + , testCase "skip when times are too close - 2" $ + assertBool "" $ + not $ + shouldContinueAfterFirstTrial 10 1.0 1.09 Solution Solution + , testCase "rerun when times aren't too close - 1" $ + assertBool "" $ + shouldContinueAfterFirstTrial 10 1.0 0.905 Solution Solution + , testCase "rerun when times aren't too close - 2" $ + assertBool "" $ + shouldContinueAfterFirstTrial 10 1.0 1.1 Solution Solution + ] ] - - , testGroup "isSignificantResult" [ - - testCase "different results are significant" $ assertBool "" $ - isSignificantResult NoInstallPlan BackjumpLimit - - , testCase "unknown result is significant" $ assertBool "" $ - isSignificantResult Unknown Unknown - - , testCase "PkgNotFound is significant" $ assertBool "" $ - isSignificantResult PkgNotFound PkgNotFound - - , testCase "same expected error is not significant" $ assertBool "" $ - not $ isSignificantResult NoInstallPlan NoInstallPlan - - , testCase "success is not significant" $ assertBool "" $ - not $ isSignificantResult Solution Solution - ] - - , testGroup "shouldContinueAfterFirstTrial" [ - - testCase "rerun when min difference is zero" $ assertBool "" $ - shouldContinueAfterFirstTrial 0 1.0 1.0 Solution Solution - - , testCase "rerun when min difference is zero, even with timeout" $ - assertBool "" $ - shouldContinueAfterFirstTrial 0 1.0 1.0 Timeout Timeout - - , testCase "treat timeouts as the same time" $ assertBool "" $ - not $ shouldContinueAfterFirstTrial 0.000001 89.9 92.0 Timeout Timeout - - , testCase "skip when times are too close - 1" $ assertBool "" $ - not $ shouldContinueAfterFirstTrial 10 1.0 0.91 Solution Solution - - , testCase "skip when times are too close - 2" $ assertBool "" $ - not $ shouldContinueAfterFirstTrial 10 1.0 1.09 Solution Solution - - , testCase "rerun when times aren't too close - 1" $ assertBool "" $ - shouldContinueAfterFirstTrial 10 1.0 0.905 Solution Solution - - , testCase "rerun when times aren't too close - 2" $ assertBool "" $ - shouldContinueAfterFirstTrial 10 1.0 1.1 Solution Solution - ] - ]