diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 11f4c4ce5d2..5f1b41c0916 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -13,8 +13,23 @@ jobs: - uses: haskell-actions/run-fourmolu@v11 with: version: "0.12.0.0" + # NOTE: Keep this in sync with `../../Makefile` pattern: | + bootstrap/**/*.hs + buildinfo-reference-generator/**/*.hs Cabal/**/*.hs - Cabal-syntax/**/*.hs + Cabal-benchmarks/**/*.hs + Cabal-described/**/*.hs + Cabal-dev-scripts/**/*.hs + Cabal-hooks/**/*.hs cabal-install/**/*.hs + cabal-install-solver/**/*.hs + Cabal-QuickCheck/**/*.hs + Cabal-syntax/**/*.hs + Cabal-tests/**/*.hs + Cabal-testsuite/src/**/*.hs + Cabal-testsuite/main/**/*.hs + Cabal-testsuite/static/**/*.hs + Cabal-tree-diff/**/*.hs cabal-validate/**/*.hs + solver-benchmarks/**/*.hs diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs b/Cabal-QuickCheck/src/Test/QuickCheck/GenericArbitrary.hs index 29f0b5d85e9..1498f7eefd3 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 @@ -15,31 +16,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 a3b489ef369..70ef2fb2e32 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -1,31 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Test.QuickCheck.Instances.Cabal () where #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -import Data.Bits (countLeadingZeros, finiteBitSize, shiftL, shiftR) -import Data.Char (isAlphaNum, isDigit, toLower) -import Data.List (intercalate, (\\)) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Bits (countLeadingZeros, finiteBitSize, shiftL, shiftR) +import Data.Char (isAlphaNum, isDigit, toLower) +import Data.List (intercalate, (\\)) +import Data.List.NonEmpty (NonEmpty (..)) import Distribution.Utils.Generic (lowercase) import Test.QuickCheck 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.SPDX import Distribution.Simple.Compiler -import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.Flag (Flag (..)) import Distribution.Simple.InstallDirs -import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..), DumpBuildInfo) -import Distribution.SPDX +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 @@ -45,7 +46,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 ------------------------------------------------------------------------------- @@ -53,26 +54,27 @@ import qualified Distribution.Compat.NonEmptySet as NES ------------------------------------------------------------------------------- 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 @@ -81,44 +83,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) @@ -127,18 +135,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 @@ -152,16 +160,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 ------------------------------------------------------------------------------- -- @@ -170,7 +178,7 @@ instance Arbitrary ModuleRenaming where instance Arbitrary LibraryVisibility where arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] - shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] + shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] shrink LibraryVisibilityPrivate = [] ------------------------------------------------------------------------------- @@ -178,220 +186,237 @@ 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 @@ -402,63 +427,82 @@ instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where -- invalid characters or path components 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) @@ -467,27 +511,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 (PackageDBX FilePath) 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 @@ -495,36 +541,36 @@ 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 "{}[]" arbitraryShortPath :: Gen String arbitraryShortPath = arbitraryShortStringWithout "{}[],<>:|*?" `suchThat` (not . winDevice) - where - -- split path components on dots - -- no component can be empty or a device name - -- this blocks a little too much (both "foo..bar" and "foo.con" are legal) - -- but for QC being a little conservative isn't harmful - winDevice = any (any (`elem` ["","con", "aux", "prn", "com", "lpt", "nul"]) . splitBy ".") . splitBy "\\/" . map toLower - splitBy _ "" = [] - splitBy seps str = let (part,rest) = break (`elem` seps) str - in part : if length rest == 1 then [""] else splitBy seps (drop 1 rest) + where + -- split path components on dots + -- no component can be empty or a device name + -- this blocks a little too much (both "foo..bar" and "foo.con" are legal) + -- but for QC being a little conservative isn't harmful + winDevice = any (any (`elem` ["", "con", "aux", "prn", "com", "lpt", "nul"]) . splitBy ".") . splitBy "\\/" . map toLower + splitBy _ "" = [] + splitBy seps str = + let (part, rest) = break (`elem` seps) str + in part : if length rest == 1 then [""] else splitBy seps (drop 1 rest) arbitraryShortStringWithout :: String -> Gen String arbitraryShortStringWithout excludeChars = - shortListOf1 5 $ elements $ ['#' .. '~'] \\ excludeChars + shortListOf1 5 $ elements $ ['#' .. '~'] \\ 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 717fd6a5c7a..59a681d1594 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -1,127 +1,150 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# 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, reverse, undefined - , ($), (.), (<$>) - ) + ( Bool (..) + , Char + , Either (..) + , Enum (..) + , Eq (..) + , Ord (..) + , Show (..) + , String + , elem + , fmap + , foldr + , id + , map + , maybe + , otherwise + , return + , reverse + , 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.PackageDescription.FieldGrammar (CompatLicenseFile, CompatDataDir) +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.PackageDescription.FieldGrammar (CompatDataDir, CompatLicenseFile) +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.Utils.Path (SymbolicPath, RelativePath) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, VersionRange) -import Language.Haskell.Extension (Extension, Language, knownLanguages) +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.Utils.Path (RelativePath, SymbolicPath) +import Distribution.Verbosity (Verbosity) +import Distribution.Version (Version, VersionRange) +import Language.Haskell.Extension (Extension, Language, knownLanguages) -- | 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 @@ -144,11 +167,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 @@ -160,11 +185,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 -- @@ -208,7 +234,8 @@ csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ',' ------------------------------------------------------------------------------- describeFlagAssignmentNonEmpty :: GrammarRegex void -describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $ +describeFlagAssignmentNonEmpty = + REMunch1 RESpaces1 $ REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) ------------------------------------------------------------------------------- @@ -216,50 +243,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 @@ -267,10 +295,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 @@ -283,10 +311,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 @@ -296,8 +327,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 @@ -312,8 +343,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 @@ -322,280 +353,297 @@ 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","Hooks","Make","Default"] + describe _ = REUnion ["Simple", "Configure", "Custom", "Hooks", "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 $ (REString . show) <$> reverse knownLanguages + describe _ = REUnion $ (REString . show) <$> reverse knownLanguages 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 (SymbolicPath from to) where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) instance Described (RelativePath from to) where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) instance Described (SymbolicPathNT from to) where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) instance Described (RelativePathNT from to) where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) instance Described CompatLicenseFile where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) instance Described CompatDataDir where - describe _ = describe ([] :: [Token]) + describe _ = describe ([] :: [Token]) 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 9243615c7fa..cdb0e287b4f 100644 --- a/Cabal-described/src/Distribution/Utils/CharSet.hs +++ b/Cabal-described/src/Distribution/Utils/CharSet.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{- FOURMOLU_DISABLE -} + -- | Sets of characters. -- -- Using this is more efficient than 'RE.Type.Alt':ng individual characters. diff --git a/Cabal-described/src/Distribution/Utils/GrammarRegex.hs b/Cabal-described/src/Distribution/Utils/GrammarRegex.hs index 471ee25d44f..2bdb030060d 100644 --- a/Cabal-described/src/Distribution/Utils/GrammarRegex.hs +++ b/Cabal-described/src/Distribution/Utils/GrammarRegex.hs @@ -1,33 +1,36 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# 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.<>) @@ -38,46 +41,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 @@ -121,56 +140,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 @@ -182,9 +205,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{\"}}" @@ -194,20 +217,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-hooks/Setup.hs b/Cabal-hooks/Setup.hs index 7dc1709c778..00bfe1fe441 100644 --- a/Cabal-hooks/Setup.hs +++ b/Cabal-hooks/Setup.hs @@ -1,4 +1,4 @@ -import Distribution.Simple - -main :: IO () -main = defaultMain +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs index 5e194ec9161..608eb63d280 100644 --- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -5,61 +5,66 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StaticPointers #-} -{-| -Module: Distribution.Simple.SetupHooks -Description: Interface for the @Hooks@ @build-type@. - -This module defines the interface for the @Hooks@ @build-type@. - -To write a package that implements @build-type: Hooks@, you should define -a module @SetupHooks.hs@ which exports a value @setupHooks :: 'SetupHooks'@. -This is a record that declares actions that should be hooked into the -cabal build process. - -See 'SetupHooks' for more details. --} +-- | +-- Module: Distribution.Simple.SetupHooks +-- Description: Interface for the @Hooks@ @build-type@. +-- +-- This module defines the interface for the @Hooks@ @build-type@. +-- +-- To write a package that implements @build-type: Hooks@, you should define +-- a module @SetupHooks.hs@ which exports a value @setupHooks :: 'SetupHooks'@. +-- This is a record that declares actions that should be hooked into the +-- cabal build process. +-- +-- See 'SetupHooks' for more details. module Distribution.Simple.SetupHooks ( -- * Hooks - -- $setupHooks - SetupHooks(..) + SetupHooks (..) , noSetupHooks - -- * Configure hooks - - -- $configureHooks - , ConfigureHooks(..) + -- * Configure hooks + -- $configureHooks + , ConfigureHooks (..) , noConfigureHooks + -- ** Per-package configure hooks - , PreConfPackageInputs(..) - , PreConfPackageOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , PreConfPackageInputs (..) + , PreConfPackageOutputs (..) -- See Note [Not hiding SetupHooks constructors] , noPreConfPackageOutputs , PreConfPackageHook - , PostConfPackageInputs(..) + , PostConfPackageInputs (..) , PostConfPackageHook + -- ** Per-component configure hooks - , PreConfComponentInputs(..) - , PreConfComponentOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , PreConfComponentInputs (..) + , PreConfComponentOutputs (..) -- See Note [Not hiding SetupHooks constructors] , noPreConfComponentOutputs , PreConfComponentHook - , ComponentDiff(..), emptyComponentDiff, buildInfoComponentDiff - , LibraryDiff, ForeignLibDiff, ExecutableDiff - , TestSuiteDiff, BenchmarkDiff + , ComponentDiff (..) + , emptyComponentDiff + , buildInfoComponentDiff + , LibraryDiff + , ForeignLibDiff + , ExecutableDiff + , TestSuiteDiff + , BenchmarkDiff , BuildInfoDiff -- * Build hooks - - , BuildHooks(..), noBuildHooks - , BuildingWhat(..), buildingWhatVerbosity, buildingWhatDistPref + , BuildHooks (..) + , noBuildHooks + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatDistPref -- ** Pre-build rules - -- $preBuildRules - , PreBuildComponentInputs(..) + , PreBuildComponentInputs (..) , PreBuildComponentRules -- ** Post-build hooks - , PostBuildComponentInputs(..) + , PostBuildComponentInputs (..) , PostBuildComponentHook -- ** Rules @@ -70,48 +75,58 @@ module Distribution.Simple.SetupHooks , Dependency (..) , RuleOutput (..) , RuleId - , staticRule, dynamicRule - -- *** Rule inputs/outputs + , staticRule + , dynamicRule + -- *** Rule inputs/outputs -- $rulesDemand - , Location(..) + , Location (..) , location , autogenComponentModulesDir , componentBuildDir -- *** Actions - , RuleCommands(..) + , RuleCommands (..) , Command , mkCommand - , Dict(..) + , Dict (..) -- *** Rules API - -- $rulesAPI , RulesM , registerRule , registerRule_ - -- **** File/directory monitoring + -- **** File/directory monitoring , addRuleMonitors , module Distribution.Simple.FileMonitor.Types -- * Install hooks - , InstallHooks(..), noInstallHooks - , InstallComponentInputs(..), InstallComponentHook + , InstallHooks (..) + , noInstallHooks + , InstallComponentInputs (..) + , InstallComponentHook -- * Re-exports -- ** Hooks + -- *** Configure hooks - , ConfigFlags(..) + , ConfigFlags (..) + -- *** Build hooks - , BuildFlags(..), ReplFlags(..), HaddockFlags(..), HscolourFlags(..) + , BuildFlags (..) + , ReplFlags (..) + , HaddockFlags (..) + , HscolourFlags (..) + -- *** Install hooks - , CopyFlags(..) + , CopyFlags (..) -- ** @Hooks@ API - -- + + -- + -- | These are functions provided as part of the @Hooks@ API. -- It is recommended to import them from this module as opposed to -- manually importing them from inside the Cabal module hierarchy. @@ -120,108 +135,156 @@ module Distribution.Simple.SetupHooks , installFileGlob -- *** Interacting with the program database - , Program(..), ConfiguredProgram(..), ProgArg - , ProgramLocation(..) + , Program (..) + , ConfiguredProgram (..) + , ProgArg + , ProgramLocation (..) , ProgramDb , addKnownPrograms , configureUnconfiguredProgram , simpleProgram -- ** General @Cabal@ datatypes - , Verbosity, Compiler(..), Platform(..), Suffix(..) + , Verbosity + , Compiler (..) + , Platform (..) + , Suffix (..) -- *** Package information - , LocalBuildConfig, LocalBuildInfo, PackageBuildDescr - -- NB: we can't simply re-export all the fields of LocalBuildConfig etc, - -- due to the presence of duplicate record fields. - -- Ideally, we'd like to e.g. re-export LocalBuildConfig qualified, - -- but qualified re-exports aren't a thing currently. + , LocalBuildConfig + , LocalBuildInfo + , PackageBuildDescr + -- NB: we can't simply re-export all the fields of LocalBuildConfig etc, + -- due to the presence of duplicate record fields. + -- Ideally, we'd like to e.g. re-export LocalBuildConfig qualified, + -- but qualified re-exports aren't a thing currently. - , PackageDescription(..) + , PackageDescription (..) -- *** Component information - , Component(..), ComponentName(..), componentName - , BuildInfo(..), emptyBuildInfo - , TargetInfo(..), ComponentLocalBuildInfo(..) + , Component (..) + , ComponentName (..) + , componentName + , BuildInfo (..) + , emptyBuildInfo + , TargetInfo (..) + , ComponentLocalBuildInfo (..) -- **** Components - , Library(..), ForeignLib(..), Executable(..) - , TestSuite(..), Benchmark(..) - , LibraryName(..) - , emptyLibrary, emptyForeignLib, emptyExecutable - , emptyTestSuite, emptyBenchmark - + , Library (..) + , ForeignLib (..) + , Executable (..) + , TestSuite (..) + , Benchmark (..) + , LibraryName (..) + , emptyLibrary + , emptyForeignLib + , emptyExecutable + , emptyTestSuite + , emptyBenchmark ) where + import Distribution.PackageDescription - ( PackageDescription(..) - , Library(..), ForeignLib(..) - , Executable(..), TestSuite(..), Benchmark(..) - , emptyLibrary, emptyForeignLib - , emptyExecutable, emptyBenchmark, emptyTestSuite - , BuildInfo(..), emptyBuildInfo - , ComponentName(..), LibraryName(..) + ( Benchmark (..) + , BuildInfo (..) + , ComponentName (..) + , Executable (..) + , ForeignLib (..) + , Library (..) + , LibraryName (..) + , PackageDescription (..) + , TestSuite (..) + , emptyBenchmark + , emptyBuildInfo + , emptyExecutable + , emptyForeignLib + , emptyLibrary + , emptyTestSuite ) import Distribution.Simple.BuildPaths - ( autogenComponentModulesDir ) + ( autogenComponentModulesDir + ) import Distribution.Simple.Compiler - ( Compiler(..) ) + ( Compiler (..) + ) import Distribution.Simple.Errors - ( CabalException(SetupHooksException) ) + ( CabalException (SetupHooksException) + ) import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Install - ( installFileGlob ) + ( installFileGlob + ) import Distribution.Simple.LocalBuildInfo - ( componentBuildDir ) + ( componentBuildDir + ) import Distribution.Simple.PreProcess.Types - ( Suffix(..) ) + ( Suffix (..) + ) import Distribution.Simple.Program.Db - ( ProgramDb, addKnownPrograms + ( ProgramDb + , addKnownPrograms , configureUnconfiguredProgram ) import Distribution.Simple.Program.Find - ( simpleProgram ) + ( simpleProgram + ) import Distribution.Simple.Program.Types - ( Program(..), ConfiguredProgram(..) + ( ConfiguredProgram (..) , ProgArg - , ProgramLocation(..) + , Program (..) + , ProgramLocation (..) ) import Distribution.Simple.Setup - ( BuildFlags(..) - , ConfigFlags(..) - , CopyFlags(..) - , HaddockFlags(..) - , HscolourFlags(..) - , ReplFlags(..) + ( BuildFlags (..) + , ConfigFlags (..) + , CopyFlags (..) + , HaddockFlags (..) + , HscolourFlags (..) + , ReplFlags (..) ) import Distribution.Simple.SetupHooks.Errors import Distribution.Simple.SetupHooks.Internal import Distribution.Simple.SetupHooks.Rule as Rule import Distribution.Simple.Utils - ( dieWithException ) + ( dieWithException + ) import Distribution.System - ( Platform(..) ) + ( Platform (..) + ) import Distribution.Types.Component - ( Component(..), componentName ) + ( Component (..) + , componentName + ) import Distribution.Types.ComponentLocalBuildInfo - ( ComponentLocalBuildInfo(..) ) -import Distribution.Types.LocalBuildInfo - ( LocalBuildInfo(..) ) + ( ComponentLocalBuildInfo (..) + ) import Distribution.Types.LocalBuildConfig - ( LocalBuildConfig, PackageBuildDescr ) + ( LocalBuildConfig + , PackageBuildDescr + ) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo (..) + ) import Distribution.Types.TargetInfo - ( TargetInfo(..) ) + ( TargetInfo (..) + ) import Distribution.Utils.ShortText - ( ShortText ) + ( ShortText + ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity + ) import Control.Monad - ( void ) + ( void + ) import Control.Monad.IO.Class - ( MonadIO(liftIO) ) + ( MonadIO (liftIO) + ) import Control.Monad.Trans.Class - ( lift ) + ( lift + ) import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State as State #if MIN_VERSION_transformers(0,5,6) @@ -230,180 +293,177 @@ import qualified Control.Monad.Trans.Writer.CPS as Writer import qualified Control.Monad.Trans.Writer.Strict as Writer #endif import Data.Foldable - ( for_ ) + ( for_ + ) import Data.Map.Strict as Map - ( insertLookupWithKey ) + ( insertLookupWithKey + ) -------------------------------------------------------------------------------- -- Haddocks for the SetupHooks API -{- $setupHooks -A Cabal package with @Hooks@ @build-type@ must define the Haskell module -@SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@. - -These *setup hooks* allow package authors to customise the configuration and -building of a package by providing certain hooks that get folded into the -general package configuration and building logic within @Cabal@. - -This mechanism replaces the @Custom@ @build-type@, providing better -integration with the rest of the Haskell ecosystem. - -Usage example: - -> -- In your .cabal file -> build-type: Hooks -> -> custom-setup -> setup-depends: -> base >= 4.18 && < 5, -> Cabal-hooks >= 3.14 && < 3.15 -> -> The declared Cabal version should also be at least 3.14. - -> -- In SetupHooks.hs, next to your .cabal file -> module SetupHooks where -> import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) -> -> setupHooks :: SetupHooks -> setupHooks = -> noSetupHooks -> { configureHooks = myConfigureHooks -> , buildHooks = myBuildHooks } - -Note that 'SetupHooks' can be monoidally combined, e.g.: - -> module SetupHooks where -> import Distribution.Simple.SetupHooks -> import qualified SomeOtherLibrary ( setupHooks ) -> -> setupHooks :: SetupHooks -> setupHooks = SomeOtherLibrary.setupHooks <> mySetupHooks -> -> mySetupHooks :: SetupHooks -> mySetupHooks = ... --} - -{- $configureHooks -Configure hooks can be used to augment the Cabal configure logic with -package-specific logic. The main principle is that the configure hooks can -feed into updating the 'PackageDescription' of a @cabal@ package. From then on, -this package configuration is set in stone, and later hooks (e.g. hooks into -the build phase) can no longer modify this configuration; instead they will -receive this configuration in their inputs, and must honour it. - -Configuration happens at two levels: - - * global configuration covers the entire package, - * local configuration covers a single component. - -Once the global package configuration is done, all hooks work on a -per-component level. The configuration hooks thus follow a simple philosophy: - - * All modifications to global package options must use `preConfPackageHook`. - * All modifications to component configuration options must use `preConfComponentHook`. - -For example, to generate modules inside a given component, you should: - - * In the per-component configure hook, declare the modules you are going to - generate by adding them to the `autogenModules` field for that component - (unless you know them ahead of time, in which case they can be listed - textually in the @.cabal@ file of the project). - * In the build hooks, describe the actions that will generate these modules. --} - -{- $preBuildRules -Pre-build hooks are specified as a collection of pre-build 'Rules'. -Each t'Rule' consists of: - - - a specification of its static dependencies and outputs, - - the commands that execute the rule. - -Rules are constructed using either one of the 'staticRule' or 'dynamicRule' -smart constructors. Directly constructing a t'Rule' using the constructors of -that data type is not advised, as this relies on internal implementation details -which are subject to change in between versions of the `Cabal-hooks` library. - -Note that: - - - To declare the dependency on the output of a rule, one must refer to the - rule directly, and not to the path to the output executing that rule will - eventually produce. - To do so, registering a t'Rule' with the API returns a unique identifier - for that rule, in the form of a t'RuleId'. - - File dependencies and outputs are not specified directly by - 'FilePath', but rather use the 'Location' type (which is more convenient - when working with preprocessors). - - Rules refer to the actions that execute them using static pointers, in order - to enable serialisation/deserialisation of rules. - - Rules can additionally monitor files or directories, which determines - when to re-compute the entire set of rules. --} - -{- $rulesDemand -Rules can declare various kinds of dependencies: - - - 'staticDependencies': files or other rules that a rule statically depends on, - - extra dynamic dependencies, using the 'DynamicRuleCommands' constructor, - - 'MonitorFilePath': additional files and directories to monitor. - -Rules are considered __out-of-date__ precisely when any of the following -conditions apply: - - [O1] there has been a (relevant) change in the files and directories - monitored by the rules, - [O2] the environment passed to the computation of rules has changed. - -If the rules are out-of-date, the build system is expected to re-run the -computation that computes all rules. - -After this re-computation of the set of all rules, we match up new rules -with old rules, by 'RuleId'. A rule is then considered __stale__ if any of -following conditions apply: - - [N] the rule is new, or - [S] the rule matches with an old rule, and either: - - [S1] a file dependency of the rule has been modified/created/deleted, or - a (transitive) rule dependency of the rule is itself stale, or - [S2] the rule is different from the old rule, e.g. the argument stored in - the rule command has changed, or the pointer to the action to run the - rule has changed. (This is determined using the @Eq Rule@ instance.) - -A stale rule becomes no longer stale once we run its associated action. The -build system is responsible for re-running the actions associated with -each stale rule, in dependency order. This means the build system is expected -to behave as follows: - - 1. Any time the rules are out-of-date, query the rules to obtain - up-to-date rules. - 2. Re-run stale rules. --} +-- $setupHooks +-- A Cabal package with @Hooks@ @build-type@ must define the Haskell module +-- @SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@. +-- +-- These *setup hooks* allow package authors to customise the configuration and +-- building of a package by providing certain hooks that get folded into the +-- general package configuration and building logic within @Cabal@. +-- +-- This mechanism replaces the @Custom@ @build-type@, providing better +-- integration with the rest of the Haskell ecosystem. +-- +-- Usage example: +-- +-- > -- In your .cabal file +-- > build-type: Hooks +-- > +-- > custom-setup +-- > setup-depends: +-- > base >= 4.18 && < 5, +-- > Cabal-hooks >= 3.14 && < 3.15 +-- > +-- > The declared Cabal version should also be at least 3.14. +-- +-- > -- In SetupHooks.hs, next to your .cabal file +-- > module SetupHooks where +-- > import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) +-- > +-- > setupHooks :: SetupHooks +-- > setupHooks = +-- > noSetupHooks +-- > { configureHooks = myConfigureHooks +-- > , buildHooks = myBuildHooks } +-- +-- Note that 'SetupHooks' can be monoidally combined, e.g.: +-- +-- > module SetupHooks where +-- > import Distribution.Simple.SetupHooks +-- > import qualified SomeOtherLibrary ( setupHooks ) +-- > +-- > setupHooks :: SetupHooks +-- > setupHooks = SomeOtherLibrary.setupHooks <> mySetupHooks +-- > +-- > mySetupHooks :: SetupHooks +-- > mySetupHooks = ... + +-- $configureHooks +-- Configure hooks can be used to augment the Cabal configure logic with +-- package-specific logic. The main principle is that the configure hooks can +-- feed into updating the 'PackageDescription' of a @cabal@ package. From then on, +-- this package configuration is set in stone, and later hooks (e.g. hooks into +-- the build phase) can no longer modify this configuration; instead they will +-- receive this configuration in their inputs, and must honour it. +-- +-- Configuration happens at two levels: +-- +-- * global configuration covers the entire package, +-- * local configuration covers a single component. +-- +-- Once the global package configuration is done, all hooks work on a +-- per-component level. The configuration hooks thus follow a simple philosophy: +-- +-- * All modifications to global package options must use `preConfPackageHook`. +-- * All modifications to component configuration options must use `preConfComponentHook`. +-- +-- For example, to generate modules inside a given component, you should: +-- +-- * In the per-component configure hook, declare the modules you are going to +-- generate by adding them to the `autogenModules` field for that component +-- (unless you know them ahead of time, in which case they can be listed +-- textually in the @.cabal@ file of the project). +-- * In the build hooks, describe the actions that will generate these modules. + +-- $preBuildRules +-- Pre-build hooks are specified as a collection of pre-build 'Rules'. +-- Each t'Rule' consists of: +-- +-- - a specification of its static dependencies and outputs, +-- - the commands that execute the rule. +-- +-- Rules are constructed using either one of the 'staticRule' or 'dynamicRule' +-- smart constructors. Directly constructing a t'Rule' using the constructors of +-- that data type is not advised, as this relies on internal implementation details +-- which are subject to change in between versions of the `Cabal-hooks` library. +-- +-- Note that: +-- +-- - To declare the dependency on the output of a rule, one must refer to the +-- rule directly, and not to the path to the output executing that rule will +-- eventually produce. +-- To do so, registering a t'Rule' with the API returns a unique identifier +-- for that rule, in the form of a t'RuleId'. +-- - File dependencies and outputs are not specified directly by +-- 'FilePath', but rather use the 'Location' type (which is more convenient +-- when working with preprocessors). +-- - Rules refer to the actions that execute them using static pointers, in order +-- to enable serialisation/deserialisation of rules. +-- - Rules can additionally monitor files or directories, which determines +-- when to re-compute the entire set of rules. + +-- $rulesDemand +-- Rules can declare various kinds of dependencies: +-- +-- - 'staticDependencies': files or other rules that a rule statically depends on, +-- - extra dynamic dependencies, using the 'DynamicRuleCommands' constructor, +-- - 'MonitorFilePath': additional files and directories to monitor. +-- +-- Rules are considered __out-of-date__ precisely when any of the following +-- conditions apply: +-- +-- [O1] there has been a (relevant) change in the files and directories +-- monitored by the rules, +-- [O2] the environment passed to the computation of rules has changed. +-- +-- If the rules are out-of-date, the build system is expected to re-run the +-- computation that computes all rules. +-- +-- After this re-computation of the set of all rules, we match up new rules +-- with old rules, by 'RuleId'. A rule is then considered __stale__ if any of +-- following conditions apply: +-- +-- [N] the rule is new, or +-- [S] the rule matches with an old rule, and either: +-- +-- [S1] a file dependency of the rule has been modified/created/deleted, or +-- a (transitive) rule dependency of the rule is itself stale, or +-- [S2] the rule is different from the old rule, e.g. the argument stored in +-- the rule command has changed, or the pointer to the action to run the +-- rule has changed. (This is determined using the @Eq Rule@ instance.) +-- +-- A stale rule becomes no longer stale once we run its associated action. The +-- build system is responsible for re-running the actions associated with +-- each stale rule, in dependency order. This means the build system is expected +-- to behave as follows: +-- +-- 1. Any time the rules are out-of-date, query the rules to obtain +-- up-to-date rules. +-- 2. Re-run stale rules. -{- $rulesAPI -Defining pre-build rules can be done in the following style: - -> {-# LANGUAGE BlockArguments, StaticPointers #-} -> myPreBuildRules :: PreBuildComponentRules -> myPreBuildRules = rules (static ()) $ \ preBuildEnvironment -> do -> let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. } -> cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. } -> myData <- liftIO someIOAction -> addRuleMonitors [ monitorDirectory "someSearchDir" ] -> registerRule_ "rule_1_1" $ staticRule (cmd1 arg1) deps1 outs1 -> registerRule_ "rule_1_2" $ staticRule (cmd1 arg2) deps2 outs2 -> registerRule_ "rule_1_3" $ staticRule (cmd1 arg3) deps3 outs3 -> registerRule_ "rule_2_4" $ staticRule (cmd2 arg4) deps4 outs4 - -Here we use the 'rules', 'staticRule' and 'mkCommand' smart constructors, -rather than directly using the v'Rules', v'Rule' and v'Command' constructors, -which insulates us from internal changes to the t'Rules', t'Rule' and t'Command' -datatypes, respectively. - -We use 'addRuleMonitors' to declare a monitored directory that the collection -of rules as a whole depends on. In this case, we declare that they depend on the -contents of the "searchDir" directory. This means that the rules will be -computed anew whenever the contents of this directory change. --} +-- $rulesAPI +-- Defining pre-build rules can be done in the following style: +-- +-- > {-# LANGUAGE BlockArguments, StaticPointers #-} +-- > myPreBuildRules :: PreBuildComponentRules +-- > myPreBuildRules = rules (static ()) $ \ preBuildEnvironment -> do +-- > let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. } +-- > cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. } +-- > myData <- liftIO someIOAction +-- > addRuleMonitors [ monitorDirectory "someSearchDir" ] +-- > registerRule_ "rule_1_1" $ staticRule (cmd1 arg1) deps1 outs1 +-- > registerRule_ "rule_1_2" $ staticRule (cmd1 arg2) deps2 outs2 +-- > registerRule_ "rule_1_3" $ staticRule (cmd1 arg3) deps3 outs3 +-- > registerRule_ "rule_2_4" $ staticRule (cmd2 arg4) deps4 outs4 +-- +-- Here we use the 'rules', 'staticRule' and 'mkCommand' smart constructors, +-- rather than directly using the v'Rules', v'Rule' and v'Command' constructors, +-- which insulates us from internal changes to the t'Rules', t'Rule' and t'Command' +-- datatypes, respectively. +-- +-- We use 'addRuleMonitors' to declare a monitored directory that the collection +-- of rules as a whole depends on. In this case, we declare that they depend on the +-- contents of the "searchDir" directory. This means that the rules will be +-- computed anew whenever the contents of this directory change. {- Note [Not hiding SetupHooks constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -421,21 +481,27 @@ corresponding smart constructor instead. -- | Register a rule. Returns an identifier for that rule. registerRule - :: ShortText -- ^ user-given rule name; - -- these should be unique on a per-package level - -> Rule -- ^ the rule to register + :: ShortText + -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule + -- ^ the rule to register -> RulesM RuleId registerRule nm !newRule = RulesT $ do - RulesEnv { rulesEnvNameSpace = ns - , rulesEnvVerbosity = verbosity } <- Reader.ask + RulesEnv + { rulesEnvNameSpace = ns + , rulesEnvVerbosity = verbosity + } <- + Reader.ask oldRules <- lift $ State.get - let rId = RuleId { ruleNameSpace = ns, ruleName = nm } - (mbDup, newRules) = Map.insertLookupWithKey (\ _ new _old -> new) rId newRule oldRules - for_ mbDup $ \ oldRule -> - liftIO $ dieWithException verbosity - $ SetupHooksException - $ RulesException - $ DuplicateRuleId rId oldRule newRule + let rId = RuleId{ruleNameSpace = ns, ruleName = nm} + (mbDup, newRules) = Map.insertLookupWithKey (\_ new _old -> new) rId newRule oldRules + for_ mbDup $ \oldRule -> + liftIO $ + dieWithException verbosity $ + SetupHooksException $ + RulesException $ + DuplicateRuleId rId oldRule newRule lift $ State.put newRules return rId @@ -445,9 +511,11 @@ registerRule nm !newRule = RulesT $ do -- depend on any outputs of this rule. Use 'registerRule' to retain the -- 'RuleId' instead. registerRule_ - :: ShortText -- ^ user-given rule name; - -- these should be unique on a per-package level - -> Rule -- ^ the rule to register + :: ShortText + -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule + -- ^ the rule to register -> RulesT IO () registerRule_ i r = void $ registerRule i r diff --git a/Cabal-tests/lib/Test/Utils/TempTestDir.hs b/Cabal-tests/lib/Test/Utils/TempTestDir.hs index 7d1ca76e04f..22ed8d843bb 100644 --- a/Cabal-tests/lib/Test/Utils/TempTestDir.hs +++ b/Cabal-tests/lib/Test/Utils/TempTestDir.hs @@ -7,18 +7,18 @@ module Test.Utils.TempTestDir ) where import Distribution.Compat.Internal.TempFile (createTempDirectory) -import Distribution.Simple.Utils (warn, TempFileOptions (..), defaultTempFileOptions) +import Distribution.Simple.Utils (TempFileOptions (..), defaultTempFileOptions, warn) import Distribution.Verbosity import Control.Concurrent (threadDelay) import Control.Exception (throwIO, try) import Control.Monad (when) -import Control.Monad.Catch ( bracket, MonadMask) +import Control.Monad.Catch (MonadMask, bracket) import Control.Monad.IO.Class import System.Directory -import System.IO.Error import System.FilePath (()) +import System.IO.Error import qualified System.Info (os) -- | Much like 'withTemporaryDirectory' but with a number of hacks to make @@ -35,15 +35,17 @@ withTestDir' verbosity tempFileOpts template action = do -- /private/var/folders/... which will work. liftIO $ canonicalizePath =<< getTemporaryDirectory bracket - ( do { tmpRelDir <- liftIO $ createTempDirectory systmpdir template - ; return $ systmpdir tmpRelDir } ) - (liftIO - -- This ensures that the temp files are not deleted at the end of the test. - -- It replicates the behavior of @withTempDirectoryEx@. - . when (not (optKeepTempFiles tempFileOpts)) - -- This is the bit that helps with Windows deleting all files. - . removeDirectoryRecursiveHack verbosity - ) + ( do + tmpRelDir <- liftIO $ createTempDirectory systmpdir template + return $ systmpdir tmpRelDir + ) + ( liftIO + -- This ensures that the temp files are not deleted at the end of the test. + -- It replicates the behavior of @withTempDirectoryEx@. + . when (not (optKeepTempFiles tempFileOpts)) + -- This is the bit that helps with Windows deleting all files. + . removeDirectoryRecursiveHack verbosity + ) action -- | On Windows, file locks held by programs we run (in this case VCSs) diff --git a/Cabal-tests/tests/CheckTests.hs b/Cabal-tests/tests/CheckTests.hs index aa2f1e9b041..ec0ee1b4b37 100644 --- a/Cabal-tests/tests/CheckTests.hs +++ b/Cabal-tests/tests/CheckTests.hs @@ -1,23 +1,23 @@ module Main - ( main - ) where + ( main + ) where import Test.Tasty 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 @@ -27,7 +27,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)) - 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)) + 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 e400e73629d..d7931cd139d 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -1,10 +1,11 @@ -{-# 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 #-} #endif +{- FOURMOLU_DISABLE -} module Main where diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs index 6a81475dc03..ec6be40b084 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 3a87df99481..906349fa395 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{- FOURMOLU_DISABLE -} + module Main ( main ) where 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 cc0099175a8..b6f0030670d 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,19 +10,24 @@ 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.PackageDescription.Check +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 @@ -29,59 +35,69 @@ 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.PackageDescription.Check" - UnitTests.Distribution.PackageDescription.Check.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.PackageDescription.Check" + UnitTests.Distribution.PackageDescription.Check.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 = @@ -90,34 +106,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/PackageDescription/Check.hs b/Cabal-tests/tests/UnitTests/Distribution/PackageDescription/Check.hs index 662a0684cda..08d59466b7c 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/PackageDescription/Check.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/PackageDescription/Check.hs @@ -14,24 +14,24 @@ import Test.Tasty.HUnit -- instances import Test.QuickCheck.Instances.Cabal () - tests :: [TestTree] tests = - [ testCase "Unique ignore strings" (uniqueNames @?= True) - , testCase "Short ignore identifiers" (longerThan @?= []) - , testCase "Parsimonious '-' use" (usingTooManyDashes @?= []) - ] + [ testCase "Unique ignore strings" (uniqueNames @?= True) + , testCase "Short ignore identifiers" (longerThan @?= []) + , testCase "Parsimonious '-' use" (usingTooManyDashes @?= []) + ] where allExplanationIdStrings :: [CheckExplanationIDString] - allExplanationIdStrings = map ppCheckExplanationId [minBound..maxBound] + allExplanationIdStrings = map ppCheckExplanationId [minBound .. maxBound] uniqueNames :: Bool uniqueNames = length allExplanationIdStrings == length (nub allExplanationIdStrings) longerThan :: [CheckExplanationIDString] - longerThan = filter ((>25). length) allExplanationIdStrings + longerThan = filter ((> 25) . length) allExplanationIdStrings usingTooManyDashes :: [CheckExplanationIDString] - usingTooManyDashes = filter ((>2) . length . filter (=='-')) - allExplanationIdStrings - + usingTooManyDashes = + filter + ((> 2) . length . filter (== '-')) + allExplanationIdStrings diff --git a/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs b/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs index 8f2d32e0779..752342d9f15 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/PkgconfigVersion.hs @@ -3,7 +3,7 @@ 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 @@ -11,9 +11,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 b9454c20d20..e4d32896c84 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/SPDX.hs @@ -1,12 +1,13 @@ {-# 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 @@ -15,48 +16,48 @@ 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) 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 ------------------------------------------------------------------------------- @@ -64,7 +65,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 @@ -78,7 +81,9 @@ shouldAccept = map License ] shouldReject :: [License] -shouldReject = map License +shouldReject = + map + License [ simpleLicenseExpression BSD_4_Clause , simpleLicenseExpression BSD_4_Clause `EAnd` simpleLicenseExpression MIT ] @@ -93,25 +98,26 @@ shouldReject = map License -- -- * There should be a way to interpret 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 c07fbb38623..8d5f571b0a4 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -1,18 +1,19 @@ {-# LANGUAGE LambdaCase #-} + 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 @@ -107,19 +108,23 @@ testMatchesVersion version pat expected = do -- check can't identify that kind of match. expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected unless (sort expected' == sort actual) $ - assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected + assertFailure $ + "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do makeSampleFiles tmpdir actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat unless (isEqual actual expected) $ - assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected + assertFailure $ + "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected 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 d66b2eb4316..fee1a59bd27 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs @@ -1,77 +1,86 @@ module UnitTests.Distribution.Simple.Program.GHC (tests) where -import qualified Data.Map as Map import Data.Algorithm.Diff (PolyDiff (..), getDiff) -import Test.Tasty (TestTree, testGroup) +import qualified Data.Map as Map +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Distribution.System (Platform(..), Arch(X86_64), OS(Linux)) -import Distribution.Types.ParStrat -import Distribution.Simple.Flag -import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), AbiTag(NoAbiTag)) import Distribution.PackageDescription (emptyPackageDescription) -import Distribution.Simple.Program.GHC (normaliseGhcArgs, renderGhcOptions, ghcOptNumJobs) -import Distribution.Version (mkVersion) +import Distribution.Simple.Compiler (AbiTag (NoAbiTag), Compiler (..), CompilerFlavor (..), CompilerId (..)) +import Distribution.Simple.Flag +import Distribution.Simple.Program.GHC (ghcOptNumJobs, normaliseGhcArgs, renderGhcOptions) +import Distribution.System (Arch (X86_64), OS (Linux), Platform (..)) +import Distribution.Types.ParStrat +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 assertListEquals flags options_9_0_affects ] - , testGroup "renderGhcOptions" - [ testCase "options" $ do + , testGroup + "renderGhcOptions" + [ testCase "options" $ do let flags :: [String] - flags = renderGhcOptions - (Compiler - { compilerId = CompilerId GHC (mkVersion [9,8,1]) - , compilerAbiTag = NoAbiTag - , compilerCompat = [] - , compilerLanguages = [] - , compilerExtensions = [] - , compilerProperties = Map.singleton "Support parallel --make" "YES" - }) - (Platform X86_64 Linux) - (mempty { ghcOptNumJobs = Flag (NumJobs (Just 4)) }) + flags = + renderGhcOptions + ( Compiler + { compilerId = CompilerId GHC (mkVersion [9, 8, 1]) + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = [] + , compilerExtensions = [] + , compilerProperties = Map.singleton "Support parallel --make" "YES" + } + ) + (Platform X86_64 Linux) + (mempty{ghcOptNumJobs = Flag (NumJobs (Just 4))}) assertListEquals flags ["-j4", "-clear-package-db"] ] ] 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 @@ -89,47 +98,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 @@ -137,40 +147,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 @@ -178,16 +189,17 @@ 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" + ] 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 48e8aae9c1d..daa7cc1bcc2 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 @@ -41,7 +46,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 @@ -52,56 +58,65 @@ 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 - res <- withTempFile ".hs" $ \filenameHs handleHs -> do - withTempFile ".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 + res <- withTempFile ".hs" $ \filenameHs handleHs -> do + withTempFile ".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 a7d629ccb08..92b57f78ae1 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/CharSet.hs @@ -1,24 +1,31 @@ {-# LANGUAGE CPP #-} + 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 7daee1b53f8..ccfa837683e 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -1,27 +1,30 @@ {-# 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) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) -import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) tests :: TestTree -tests = testGroup "Distribution.Utils.Structured" +tests = + testGroup + "Distribution.Utils.Structured" -- This test also verifies that structureHash doesn't loop. [ testCase "VersionRange" $ - md5Check (Proxy :: Proxy VersionRange) 0x39396fc4f2d751aaa1f94e6d843f03bd + md5Check (Proxy :: Proxy VersionRange) 0x39396fc4f2d751aaa1f94e6d843f03bd , testCase "SPDX.License" $ - md5Check (Proxy :: Proxy License) 0xd3d4a09f517f9f75bc3d16370d5a853a - -- The difference is in encoding of newtypes - , testCase "GenericPackageDescription" $ md5CheckGenericPackageDescription (Proxy :: Proxy GenericPackageDescription) + md5Check (Proxy :: Proxy License) 0xd3d4a09f517f9f75bc3d16370d5a853a + , -- The difference is in encoding of newtypes + testCase "GenericPackageDescription" $ md5CheckGenericPackageDescription (Proxy :: Proxy GenericPackageDescription) , testCase "LocalBuildInfo" $ md5CheckLocalBuildInfo (Proxy :: Proxy LocalBuildInfo) ] @@ -29,9 +32,13 @@ md5Check :: Structured a => Proxy a -> Integer -> Assertion md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion -md5CheckGenericPackageDescription proxy = md5Check proxy +md5CheckGenericPackageDescription proxy = + md5Check + proxy 0x09251b46ffc5178a7526d31e794d9c62 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion -md5CheckLocalBuildInfo proxy = md5Check proxy +md5CheckLocalBuildInfo proxy = + md5Check + proxy 0x8fa7b2c8cc611407bfdcb734ecb460a2 diff --git a/Cabal-tests/tests/UnitTests/Distribution/Version.hs b/Cabal-tests/tests/UnitTests/Distribution/Version.hs index 9bfcfc0e143..9ffa480aa6c 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Version.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Version.hs @@ -1,81 +1,74 @@ +-- 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 @@ -87,24 +80,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' ] --------------------- @@ -113,34 +108,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 @@ -151,16 +146,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 @@ -172,11 +168,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 @@ -199,76 +195,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 @@ -278,8 +277,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 @@ -291,24 +295,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 @@ -316,14 +323,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 @@ -332,21 +339,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 @@ -356,62 +364,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/custom-setup/CabalDoctestSetup.hs b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs index a6a59c144c9..88867fc4237 100644 --- a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs +++ b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs @@ -1,8 +1,3 @@ --- This is Distribution.Extra.Doctest module from cabal-doctest-1.0.4 --- This isn't technically a Custom-Setup script, but it /was/. - -{-# LANGUAGE FlexibleInstances #-} - {- Copyright (c) 2017, Oleg Grenrus @@ -37,9 +32,13 @@ 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 #-} +-- This is Distribution.Extra.Doctest module from cabal-doctest-1.0.4 +-- This isn't technically a Custom-Setup script, but it /was/. +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{- FOURMOLU_DISABLE -} + -- | The provided 'generateBuildModule' generates 'Build_doctests' module. -- That module exports enough configuration, so your doctests could be simply -- 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 339f9fd9c38..2d7bfed713c 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,13 @@ 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 #-} +{- FOURMOLU_DISABLE -} + module IdrisSetup (main) where #if !defined(MIN_VERSION_Cabal) 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 15fae62649e..d88bd716b25 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 (SymbolicPathX) -import Distribution.Utils.ShortText (ShortText, fromShortText) +import Distribution.Types.UnitId (DefUnitId, UnitId) +import Distribution.Utils.NubList (NubList) +import Distribution.Utils.Path (SymbolicPathX) +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 (SymbolicPathX allowAbs 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 70e150edebb..4f50b45eceb 100644 --- a/Makefile +++ b/Makefile @@ -27,18 +27,40 @@ init: ## Set up git hooks and ignored revisions. @git config core.hooksPath .githooks ## TODO +# NOTE: Keep this in sync with `.github/workflows/format.yml`. +FORMAT_DIRS := \ + bootstrap \ + buildinfo-reference-generator \ + Cabal \ + Cabal-benchmarks \ + Cabal-described \ + Cabal-dev-scripts \ + Cabal-hooks \ + cabal-install \ + cabal-install-solver \ + Cabal-QuickCheck \ + Cabal-syntax \ + Cabal-tests \ + Cabal-testsuite/src \ + Cabal-testsuite/main \ + Cabal-testsuite/static \ + Cabal-tree-diff \ + cabal-validate \ + solver-benchmarks + + .PHONY: style -style: ## Run the code styler. - @fourmolu -q -i Cabal Cabal-syntax cabal-install cabal-validate +style: ## Run the code styler + @fourmolu -q -i $(FORMAT_DIRS) .PHONY: style-modified -style-modified: ## Run the code styler on modified files. - @git ls-files --modified Cabal Cabal-syntax cabal-install cabal-validate \ +style-modified: ## Run the code styler on modified files + @git ls-files --modified $(FORMAT_DIRS) \ | grep '.hs$$' | xargs -P $(PROCS) -I {} fourmolu -q -i {} .PHONY: style-commit -style-commit: ## Run the code styler on the previous commit. - @git diff --name-only HEAD $(COMMIT) Cabal Cabal-syntax cabal-install cabal-validate \ +style-commit: ## Run the code styler on the previous commit + @git diff --name-only HEAD $(COMMIT) -- $(FORMAT_DIRS) \ | grep '.hs$$' | xargs -P $(PROCS) -I {} fourmolu -q -i {} .PHONY: whitespace diff --git a/bootstrap/src/Main.hs b/bootstrap/src/Main.hs index af3929fe16c..a88b3e79e88 100644 --- a/bootstrap/src/Main.hs +++ b/bootstrap/src/Main.hs @@ -4,25 +4,25 @@ module Main (main) where -import Data.Either (partitionEithers) -import Data.Foldable (for_) -import Data.String (fromString) -import Data.Traversable (for) +import Data.Either (partitionEithers) +import Data.Foldable (for_) +import Data.String (fromString) +import Data.Traversable (for) import System.Environment (getArgs) -import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import qualified Cabal.Index as I +import qualified Cabal.Plan as P +import Control.Exception +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Cabal.Index as I -import qualified Cabal.Plan as P -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map.Strict as Map import qualified Distribution.Types.PackageName as C import qualified Distribution.Types.Version as C -import qualified Topograph as TG -import Control.Exception import System.IO.Error (isDoesNotExistError) +import qualified Topograph as TG ------------------------------------------------------------------------------- -- Main @@ -30,38 +30,38 @@ import System.IO.Error (isDoesNotExistError) main :: IO () main = do - args <- getArgs - case args of - [fp] -> - handleJust - (\e -> if isDoesNotExistError e then Just e else Nothing) - (\e -> die $ unlines ["~~~ ERROR ~~~", "", displayException e, "", cabalDirWarning]) - (main1 fp) - _ -> die "Usage: cabal-bootstrap-gen plan.json" + args <- getArgs + case args of + [fp] -> + handleJust + (\e -> if isDoesNotExistError e then Just e else Nothing) + (\e -> die $ unlines ["~~~ ERROR ~~~", "", displayException e, "", cabalDirWarning]) + (main1 fp) + _ -> die "Usage: cabal-bootstrap-gen plan.json" cabalDirWarning :: String cabalDirWarning = - unlines [ - "~~~ NOTE ~~~", - "", - "This script will look for cabal global config file in the following locations", - " - $CABAL_CONFIG", - " - $CABAL_DIR/config", - " - $HOME/.cabal/config (on Unix-like systems)", - " - %APPDATA%/cabal (on Windows)", - "", - "If you are using XDG paths or a entirely different location, you can set either", - "CABAL_CONFIG or CABAL_DIR to guide the script to the correct location.", - "", - "E.g.", - " $ CABAL_DIR=$HOME/.config/cabal cabal-bootstrap-gen" + unlines + [ "~~~ NOTE ~~~" + , "" + , "This script will look for cabal global config file in the following locations" + , " - $CABAL_CONFIG" + , " - $CABAL_DIR/config" + , " - $HOME/.cabal/config (on Unix-like systems)" + , " - %APPDATA%/cabal (on Windows)" + , "" + , "If you are using XDG paths or a entirely different location, you can set either" + , "CABAL_CONFIG or CABAL_DIR to guide the script to the correct location." + , "" + , "E.g." + , " $ CABAL_DIR=$HOME/.config/cabal cabal-bootstrap-gen" ] main1 :: FilePath -> IO () main1 planPath = do - meta <- getMap <$> I.cachedHackageMetadata - plan <- P.decodePlanJson planPath - main2 meta plan + meta <- getMap <$> I.cachedHackageMetadata + plan <- P.decodePlanJson planPath + main2 meta plan where #if MIN_VERSION_cabal_install_parsers(0,4,0) getMap = snd @@ -71,64 +71,71 @@ main1 planPath = do main2 :: Map.Map C.PackageName I.PackageInfo -> P.PlanJson -> IO () main2 meta plan = do - info $ show $ Map.keys $ P.pjUnits plan - - let res = TG.runG (P.planJsonIdGraph plan) $ \g -> - map (TG.gFromVertex g) (reverse $ TG.gVertices g) - - units <- case res of - Left loop -> die $ "Loop in install-plan: " ++ show loop - Right uids -> for uids $ lookupUnit (P.pjUnits plan) - - info "Unit order:" - for_ units $ \unit -> do - info $ " - " ++ show (P.uId unit) - - (builtin, deps) <- fmap partitionEithers $ for units $ \unit -> do - let P.PkgId pkgname@(P.PkgName tpkgname) ver@(P.Ver verdigits) = P.uPId unit - - let cpkgname :: C.PackageName - cpkgname = C.mkPackageName (T.unpack tpkgname) - - let cversion :: C.Version - cversion = C.mkVersion verdigits - - let flags = [ (if fval then "+" else "-") ++ T.unpack fname - | (P.FlagName fname, fval) <- Map.toList (P.uFlags unit) - ] - let relInfo = Map.lookup cpkgname meta >>= \pkgInfo -> Map.lookup cversion $ I.piVersions pkgInfo - case P.uType unit of - P.UnitTypeBuiltin -> - return $ Left Builtin - { builtinPackageName = pkgname - , builtinVersion = ver - } - _ -> do - let component = case Map.keys (P.uComps unit) of - [c] -> Just (P.dispCompNameTarget pkgname c) - _ -> Nothing - - source <- - case P.uPkgSrc unit of - Just (P.RepoTarballPackage (P.RepoSecure _uri)) -> - return Hackage - Just (P.LocalUnpackedPackage _path) -> - return Local - pkgsrc -> - die $ "package source not supported: " ++ show pkgsrc - - return $ Right Dep - { depPackageName = pkgname - , depVersion = ver - , depSource = source - , depSrcHash = P.uSha256 unit - , depRevision = fromIntegral . I.riRevision <$> relInfo - , depRevHash = relInfo >>= P.sha256FromByteString . I.getSHA256 . getHash - , depFlags = flags - , depComponent = component - } - LBS.putStr $ A.encode Result - { resBuiltin = builtin + info $ show $ Map.keys $ P.pjUnits plan + + let res = TG.runG (P.planJsonIdGraph plan) $ \g -> + map (TG.gFromVertex g) (reverse $ TG.gVertices g) + + units <- case res of + Left loop -> die $ "Loop in install-plan: " ++ show loop + Right uids -> for uids $ lookupUnit (P.pjUnits plan) + + info "Unit order:" + for_ units $ \unit -> do + info $ " - " ++ show (P.uId unit) + + (builtin, deps) <- fmap partitionEithers $ for units $ \unit -> do + let P.PkgId pkgname@(P.PkgName tpkgname) ver@(P.Ver verdigits) = P.uPId unit + + let cpkgname :: C.PackageName + cpkgname = C.mkPackageName (T.unpack tpkgname) + + let cversion :: C.Version + cversion = C.mkVersion verdigits + + let flags = + [ (if fval then "+" else "-") ++ T.unpack fname + | (P.FlagName fname, fval) <- Map.toList (P.uFlags unit) + ] + let relInfo = Map.lookup cpkgname meta >>= \pkgInfo -> Map.lookup cversion $ I.piVersions pkgInfo + case P.uType unit of + P.UnitTypeBuiltin -> + return $ + Left + Builtin + { builtinPackageName = pkgname + , builtinVersion = ver + } + _ -> do + let component = case Map.keys (P.uComps unit) of + [c] -> Just (P.dispCompNameTarget pkgname c) + _ -> Nothing + + source <- + case P.uPkgSrc unit of + Just (P.RepoTarballPackage (P.RepoSecure _uri)) -> + return Hackage + Just (P.LocalUnpackedPackage _path) -> + return Local + pkgsrc -> + die $ "package source not supported: " ++ show pkgsrc + + return $ + Right + Dep + { depPackageName = pkgname + , depVersion = ver + , depSource = source + , depSrcHash = P.uSha256 unit + , depRevision = fromIntegral . I.riRevision <$> relInfo + , depRevHash = relInfo >>= P.sha256FromByteString . I.getSHA256 . getHash + , depFlags = flags + , depComponent = component + } + LBS.putStr $ + A.encode + Result + { resBuiltin = builtin , resDependencies = deps } where @@ -139,70 +146,73 @@ main2 meta plan = do #endif lookupUnit :: Map.Map P.UnitId P.Unit -> P.UnitId -> IO P.Unit -lookupUnit units uid - = maybe (die $ "Cannot find unit " ++ show uid) return - $ Map.lookup uid units +lookupUnit units uid = + maybe (die $ "Cannot find unit " ++ show uid) return $ + Map.lookup uid units ------------------------------------------------------------------------------- -- Data ------------------------------------------------------------------------------- data Result = Result - { resBuiltin :: [Builtin] - , resDependencies :: [Dep] - } + { resBuiltin :: [Builtin] + , resDependencies :: [Dep] + } deriving (Show) data Builtin = Builtin - { builtinPackageName :: P.PkgName - , builtinVersion :: P.Ver - } + { builtinPackageName :: P.PkgName + , builtinVersion :: P.Ver + } deriving (Show) data Dep = Dep - { depPackageName :: P.PkgName - , depVersion :: P.Ver - , depSource :: SrcType - , depSrcHash :: Maybe P.Sha256 - , depRevision :: Maybe Int - , depRevHash :: Maybe P.Sha256 - , depFlags :: [String] - , depComponent :: Maybe T.Text - } + { depPackageName :: P.PkgName + , depVersion :: P.Ver + , depSource :: SrcType + , depSrcHash :: Maybe P.Sha256 + , depRevision :: Maybe Int + , depRevHash :: Maybe P.Sha256 + , depFlags :: [String] + , depComponent :: Maybe T.Text + } deriving (Show) data SrcType - = Hackage - | Local + = Hackage + | Local deriving (Show) instance A.ToJSON Result where - toJSON res = A.object - [ fromString "builtin" A..= resBuiltin res - , fromString "dependencies" A..= resDependencies res - ] + toJSON res = + A.object + [ fromString "builtin" A..= resBuiltin res + , fromString "dependencies" A..= resDependencies res + ] instance A.ToJSON Builtin where - toJSON b = A.object - [ fromString "package" A..= builtinPackageName b - , fromString "version" A..= builtinVersion b - ] + toJSON b = + A.object + [ fromString "package" A..= builtinPackageName b + , fromString "version" A..= builtinVersion b + ] instance A.ToJSON Dep where - toJSON dep = A.object - [ fromString "package" A..= depPackageName dep - , fromString "version" A..= depVersion dep - , fromString "source" A..= depSource dep - , fromString "src_sha256" A..= depSrcHash dep - , fromString "revision" A..= depRevision dep - , fromString "cabal_sha256" A..= depRevHash dep - , fromString "flags" A..= depFlags dep - , fromString "component" A..= depComponent dep - ] + toJSON dep = + A.object + [ fromString "package" A..= depPackageName dep + , fromString "version" A..= depVersion dep + , fromString "source" A..= depSource dep + , fromString "src_sha256" A..= depSrcHash dep + , fromString "revision" A..= depRevision dep + , fromString "cabal_sha256" A..= depRevHash dep + , fromString "flags" A..= depFlags dep + , fromString "component" A..= depComponent dep + ] instance A.ToJSON SrcType where - toJSON Hackage = fromString "hackage" - toJSON Local = fromString "local" + toJSON Hackage = fromString "hackage" + toJSON Local = fromString "local" ------------------------------------------------------------------------------- -- Utilities @@ -212,12 +222,12 @@ instance A.ToJSON SrcType where -- -- Disabled by default to keep the output tidy, replace by -- the version with 'hPutStrLn' when debugging. --- info :: String -> IO () info _msg = return () + -- info msg = hPutStrLn stderr $ "INFO: " ++ msg die :: String -> IO a die msg = do - hPutStrLn stderr msg - exitFailure + hPutStrLn stderr msg + exitFailure diff --git a/buildinfo-reference-generator/src/Main.hs b/buildinfo-reference-generator/src/Main.hs index 309d711b55e..030330b973d 100644 --- a/buildinfo-reference-generator/src/Main.hs +++ b/buildinfo-reference-generator/src/Main.hs @@ -1,26 +1,27 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} + module Main (main) where import Data.Map.Strict (Map) -import Data.Bifunctor (first) -import Data.Proxy (Proxy (..)) -import Data.Void (Void) -import Distribution.CabalSpecVersion (CabalSpecVersion, showCabalSpecVersion) -import Distribution.Compat.Newtype (pack') +import Data.Bifunctor (first) +import Data.Proxy (Proxy (..)) +import Data.Void (Void) +import Distribution.CabalSpecVersion (CabalSpecVersion, showCabalSpecVersion) +import Distribution.Compat.Newtype (pack') import Distribution.FieldGrammar.Class (FieldGrammar (..)) -import Distribution.Fields.Field (FieldName) -import Distribution.Pretty (pretty) -import Distribution.Simple.Utils (fromUTF8BS) -import GHC.Generics (Generic) -import System.Environment (getArgs) -import System.Exit (exitFailure) +import Distribution.Fields.Field (FieldName) +import Distribution.Pretty (pretty) +import Distribution.Simple.Utils (fromUTF8BS) +import GHC.Generics (Generic) +import System.Environment (getArgs) +import System.Exit (exitFailure) import Distribution.PackageDescription.FieldGrammar (buildInfoFieldGrammar, packageDescriptionFieldGrammar, testSuiteFieldGrammar) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import qualified Text.PrettyPrint as PP import qualified Zinza as Z @@ -28,8 +29,8 @@ import qualified Zinza as Z import Distribution.Described import Distribution.Utils.GrammarRegex -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange) ------------------------------------------------------------------------------- @@ -38,57 +39,73 @@ import Distribution.Types.VersionRange (VersionRange) main :: IO () main = do - args <- getArgs - case args of - [tmpl] -> do - -- TODO: getArgs - run <- Z.parseAndCompileTemplateIO tmpl - contents <- run $ Z - { zBuildInfoFields = fromReference buildInfoFieldGrammar - , zPackageDescriptionFields = fromReference packageDescriptionFieldGrammar - , zTestSuiteFields = fromReference $ testSuiteFieldGrammar // buildInfoFieldGrammar - , zProductions = - [ zproduction "hs-string" reHsString - "String as in Haskell; it's recommended to avoid using Haskell-specific escapes." - , zproduction "unqual-name" reUnqualComponent $ unwords - [ "Unqualified component names are used for package names, component names etc. but not flag names." - , "Unqualified component name consist of components separated by dash, each component is non-empty alphanumeric string, with at least one alphabetic character." - , "In other words, component may not look like a number." - ] - - , zproduction "module-name" (describe (Proxy :: Proxy ModuleName)) - "Haskell module name as recognized by Cabal parser." - , zproduction "version" (describe (Proxy :: Proxy Version)) - "Version is to first approximation numbers separated by dots, where leading zero is not allowed and each version digit is consists at most of nine characters." - , zproduction "version-range" (describe (Proxy :: Proxy VersionRange)) - "Version range syntax is recursive. Also note the set syntax added in ``cabal-version: 3.0``, set cannot be empty." - ] - , zSpaceList = show $ regexDoc $ + args <- getArgs + case args of + [tmpl] -> do + -- TODO: getArgs + run <- Z.parseAndCompileTemplateIO tmpl + contents <- + run $ + Z + { zBuildInfoFields = fromReference buildInfoFieldGrammar + , zPackageDescriptionFields = fromReference packageDescriptionFieldGrammar + , zTestSuiteFields = fromReference $ testSuiteFieldGrammar // buildInfoFieldGrammar + , zProductions = + [ zproduction + "hs-string" + reHsString + "String as in Haskell; it's recommended to avoid using Haskell-specific escapes." + , zproduction "unqual-name" reUnqualComponent $ + unwords + [ "Unqualified component names are used for package names, component names etc. but not flag names." + , "Unqualified component name consist of components separated by dash, each component is non-empty alphanumeric string, with at least one alphabetic character." + , "In other words, component may not look like a number." + ] + , zproduction + "module-name" + (describe (Proxy :: Proxy ModuleName)) + "Haskell module name as recognized by Cabal parser." + , zproduction + "version" + (describe (Proxy :: Proxy Version)) + "Version is to first approximation numbers separated by dots, where leading zero is not allowed and each version digit is consists at most of nine characters." + , zproduction + "version-range" + (describe (Proxy :: Proxy VersionRange)) + "Version range syntax is recursive. Also note the set syntax added in ``cabal-version: 3.0``, set cannot be empty." + ] + , zSpaceList = + show $ + regexDoc $ REMunch RESpaces1 (RENamed "element" RETodo) - , zCommaList = show $ regexDoc $ + , zCommaList = + show $ + regexDoc $ expandedCommaList (RENamed "element" RETodo) - , zOptCommaList = show $ regexDoc $ + , zOptCommaList = + show $ + regexDoc $ expandedOptCommaList (RENamed "element" RETodo) + , zNull = null + , zNotNull = not . null + } - , zNull = null - , zNotNull = not . null - } - - putStrLn contents - _ -> do - putStrLn "Usage: generator " - exitFailure + putStrLn contents + _ -> do + putStrLn "Usage: generator " + exitFailure zproduction :: String -> GrammarRegex Void -> String -> ZProduction -zproduction name re desc = ZProduction - { zprodName = name - , zprodSyntax = show (regexDoc re') +zproduction name re desc = + ZProduction + { zprodName = name + , zprodSyntax = show (regexDoc re') , zprodDescription = desc } where re' = case re of - RENamed _ r -> r - _ -> re + RENamed _ r -> r + _ -> re -- also in UnitTests.Distribution.Described expandedCommaList :: GrammarRegex a -> GrammarRegex a @@ -96,10 +113,10 @@ expandedCommaList = REUnion . expandedCommaList' 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 @@ -109,50 +126,50 @@ expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r ------------------------------------------------------------------------------- data Z = Z - { zBuildInfoFields :: [ZField] - , zPackageDescriptionFields :: [ZField] - , zTestSuiteFields :: [ZField] - , zProductions :: [ZProduction] - , zSpaceList :: String - , zCommaList :: String - , zOptCommaList :: String - , zNull :: String -> Bool - , zNotNull :: String -> Bool - } + { zBuildInfoFields :: [ZField] + , zPackageDescriptionFields :: [ZField] + , zTestSuiteFields :: [ZField] + , zProductions :: [ZProduction] + , zSpaceList :: String + , zCommaList :: String + , zOptCommaList :: String + , zNull :: String -> Bool + , zNotNull :: String -> Bool + } deriving (Generic) data ZField = ZField - { zfieldName :: String - , zfieldAvailableSince :: String - , zfieldDeprecatedSince :: (String, String) - , zfieldRemovedIn :: (String, String) - , zfieldFormat :: String - , zfieldDefault :: String - , zfieldSyntax :: String - } + { zfieldName :: String + , zfieldAvailableSince :: String + , zfieldDeprecatedSince :: (String, String) + , zfieldRemovedIn :: (String, String) + , zfieldFormat :: String + , zfieldDefault :: String + , zfieldSyntax :: String + } deriving (Generic) data ZProduction = ZProduction - { zprodName :: String - , zprodSyntax :: String - , zprodDescription :: String - } + { zprodName :: String + , zprodSyntax :: String + , zprodDescription :: 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 instance Z.Zinza ZField where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP instance Z.Zinza ZProduction where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP - fromValue = Z.genericFromValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP ------------------------------------------------------------------------------- -- From reference @@ -161,26 +178,26 @@ instance Z.Zinza ZProduction where -- TODO: produce ZField fromReference :: Reference a a -> [ZField] fromReference (Reference m) = - [ ZField - { zfieldName = fromUTF8BS n - , zfieldAvailableSince = maybe "" showCabalSpecVersion (fdAvailableSince desc) - , zfieldDeprecatedSince = maybe ("", "") (first showCabalSpecVersion) (fdDeprecatedSince desc) - , zfieldRemovedIn = maybe ("", "") (first showCabalSpecVersion) (fdRemovedIn desc) - , zfieldFormat = fmt - , zfieldDefault = def - , zfieldSyntax = syntax - } - | (n, desc) <- Map.toList m - , let (fmt, def, syntax) = fromFieldDesc' (fdDescription desc) - ] + [ ZField + { zfieldName = fromUTF8BS n + , zfieldAvailableSince = maybe "" showCabalSpecVersion (fdAvailableSince desc) + , zfieldDeprecatedSince = maybe ("", "") (first showCabalSpecVersion) (fdDeprecatedSince desc) + , zfieldRemovedIn = maybe ("", "") (first showCabalSpecVersion) (fdRemovedIn desc) + , zfieldFormat = fmt + , zfieldDefault = def + , zfieldSyntax = syntax + } + | (n, desc) <- Map.toList m + , let (fmt, def, syntax) = fromFieldDesc' (fdDescription desc) + ] fromFieldDesc' :: FieldDesc' -> (String, String, String) -fromFieldDesc' (MonoidalFieldAla s) = ("Monoidal field", "", show s) -fromFieldDesc' (BooleanFieldDesc def) = ("Boolean field", show def, show $ describeDoc ([] :: [Bool])) -fromFieldDesc' (OptionalFieldAla s) = ("Optional field", "", show s) -fromFieldDesc' (OptionalFieldDefAla s def) = ("Optional field", show def, show s) -fromFieldDesc' FreeTextField = ("Free text field", "", "") -fromFieldDesc' (UniqueField s) = ("Required field", "", show s) +fromFieldDesc' (MonoidalFieldAla s) = ("Monoidal field", "", show s) +fromFieldDesc' (BooleanFieldDesc def) = ("Boolean field", show def, show $ describeDoc ([] :: [Bool])) +fromFieldDesc' (OptionalFieldAla s) = ("Optional field", "", show s) +fromFieldDesc' (OptionalFieldDefAla s def) = ("Optional field", show def, show s) +fromFieldDesc' FreeTextField = ("Free text field", "", "") +fromFieldDesc' (UniqueField s) = ("Required field", "", show s) ------------------------------------------------------------------------------- -- Reference @@ -191,84 +208,87 @@ newtype Reference a b = Reference (Map FieldName FieldDesc) referenceAvailableSince :: CabalSpecVersion -> Reference a b -> Reference a b referenceAvailableSince v (Reference m) = - Reference (fmap (fieldDescAvailableSince v) m) + Reference (fmap (fieldDescAvailableSince v) m) referenceRemovedIn :: CabalSpecVersion -> String -> Reference a b -> Reference a b referenceRemovedIn v desc (Reference m) = - Reference (fmap (fieldDescRemovedIn v desc) m) + Reference (fmap (fieldDescRemovedIn v desc) m) referenceDeprecatedSince :: CabalSpecVersion -> String -> Reference a b -> Reference a b referenceDeprecatedSince v desc (Reference m) = - Reference (fmap (fieldDescDeprecatedSince v desc) m) + Reference (fmap (fieldDescDeprecatedSince v desc) m) (//) :: Reference a b -> Reference c d -> Reference a b Reference ab // Reference cd = Reference $ Map.difference ab cd fieldDescAvailableSince :: CabalSpecVersion -> FieldDesc -> FieldDesc -fieldDescAvailableSince v d = d { fdAvailableSince = Just v } +fieldDescAvailableSince v d = d{fdAvailableSince = Just v} fieldDescRemovedIn :: CabalSpecVersion -> String -> FieldDesc -> FieldDesc -fieldDescRemovedIn v desc d = d { fdRemovedIn = Just (v, desc) } +fieldDescRemovedIn v desc d = d{fdRemovedIn = Just (v, desc)} fieldDescDeprecatedSince :: CabalSpecVersion -> String -> FieldDesc -> FieldDesc -fieldDescDeprecatedSince v desc d = d { fdDeprecatedSince = Just (v, desc) } +fieldDescDeprecatedSince v desc d = d{fdDeprecatedSince = Just (v, desc)} data FieldDesc = FieldDesc - { fdAvailableSince :: Maybe CabalSpecVersion - , fdRemovedIn :: Maybe (CabalSpecVersion, String) - , fdDeprecatedSince :: Maybe (CabalSpecVersion, String) - , fdDescription :: FieldDesc' - } - deriving Show + { fdAvailableSince :: Maybe CabalSpecVersion + , fdRemovedIn :: Maybe (CabalSpecVersion, String) + , fdDeprecatedSince :: Maybe (CabalSpecVersion, String) + , fdDescription :: FieldDesc' + } + deriving (Show) reference :: FieldName -> FieldDesc' -> Reference a b reference fn d = Reference $ Map.singleton fn $ FieldDesc Nothing Nothing Nothing d data FieldDesc' - = BooleanFieldDesc Bool - | UniqueField PP.Doc -- ^ not used in BuildInfo - | FreeTextField -- ^ not user in BuildInfo - | OptionalFieldAla PP.Doc - | OptionalFieldDefAla PP.Doc PP.Doc - | MonoidalFieldAla PP.Doc - deriving Show + = BooleanFieldDesc Bool + | -- | not used in BuildInfo + UniqueField PP.Doc + | -- | not user in BuildInfo + FreeTextField + | OptionalFieldAla PP.Doc + | OptionalFieldDefAla PP.Doc PP.Doc + | MonoidalFieldAla PP.Doc + deriving (Show) instance Applicative (Reference a) where - pure _ = Reference Map.empty - Reference f <*> Reference x = Reference (Map.union f x) + pure _ = Reference Map.empty + Reference f <*> Reference x = Reference (Map.union f x) instance FieldGrammar Described Reference where - blurFieldGrammar _ (Reference xs) = Reference xs + blurFieldGrammar _ (Reference xs) = Reference xs - uniqueFieldAla fn pack _l = - reference fn $ UniqueField (describeDoc pack) + uniqueFieldAla fn pack _l = + reference fn $ UniqueField (describeDoc pack) - booleanFieldDef fn _l def = - reference fn $ BooleanFieldDesc def + booleanFieldDef fn _l def = + reference fn $ BooleanFieldDesc def - optionalFieldAla fn pack _l = - reference fn $ OptionalFieldAla (describeDoc pack) + optionalFieldAla fn pack _l = + reference fn $ OptionalFieldAla (describeDoc pack) - optionalFieldDefAla fn pack _l def = - reference fn $ OptionalFieldDefAla - (describeDoc pack) - (pretty $ pack' pack def) + optionalFieldDefAla fn pack _l def = + reference fn $ + OptionalFieldDefAla + (describeDoc pack) + (pretty $ pack' pack def) - freeTextField fn _l = reference fn FreeTextField + freeTextField fn _l = reference fn FreeTextField - freeTextFieldDef fn _l = reference fn FreeTextField - freeTextFieldDefST fn _l = reference fn FreeTextField + freeTextFieldDef fn _l = reference fn FreeTextField + freeTextFieldDefST fn _l = reference fn FreeTextField - monoidalFieldAla fn pack _l = - reference fn (MonoidalFieldAla (describeDoc pack)) + monoidalFieldAla fn pack _l = + reference fn (MonoidalFieldAla (describeDoc pack)) - prefixedFields _pfx _l = Reference Map.empty + prefixedFields _pfx _l = Reference Map.empty - knownField _fn = Reference Map.empty -- TODO + knownField _fn = Reference Map.empty -- TODO - -- hidden fields are hidden from the reference. - hiddenField _ = Reference Map.empty + -- hidden fields are hidden from the reference. + hiddenField _ = Reference Map.empty - deprecatedSince = referenceDeprecatedSince - removedIn = referenceRemovedIn - availableSince v _ r = referenceAvailableSince v r + deprecatedSince = referenceDeprecatedSince + removedIn = referenceRemovedIn + availableSince v _ r = referenceAvailableSince v r diff --git a/cabal-benchmarks/bench/CabalBenchmarks.hs b/cabal-benchmarks/bench/CabalBenchmarks.hs index 39580898e86..96e57f955cb 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 Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) -import Distribution.Parsec (eitherParsec) +import Distribution.Parsec (eitherParsec) import Distribution.Version +import Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) 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 5d6f20bcd43..6b5f5cf8c3d 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 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 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 7ca0317fbe4..0d6b52cba54 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 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 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 = [ "{- FOURMOLU_DISABLE -}" @@ -91,30 +103,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 46ef779e2af..83f866b9126 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 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 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 = [ "{- FOURMOLU_DISABLE -}" @@ -85,20 +95,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 e41ed10bfee..0eba35bf750 100644 --- a/cabal-dev-scripts/src/GenSPDX.hs +++ b/cabal-dev-scripts/src/GenSPDX.hs @@ -1,33 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} + module Main (main) where -import Control.Lens (imap) -import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.!=), (.:), (.:?)) -import Data.List (sortOn) -import Data.Text (Text) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.!=), (.:), (.:?)) +import Data.List (sortOn) +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.23" <*> licenses "3.25" - 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 a9a08717818..b0a420c9e15 100644 --- a/cabal-dev-scripts/src/GenSPDXExc.hs +++ b/cabal-dev-scripts/src/GenSPDXExc.hs @@ -1,33 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} + module Main (main) where -import Control.Lens (imap) -import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) -import Data.List (sortOn) -import Data.Text (Text) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) +import Data.List (sortOn) +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" @@ -37,92 +42,104 @@ main = generate =<< O.execParser opts where <*> licenses "3.23" <*> licenses "3.25" - 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 3e6244ffe7f..f098f8f9955 100644 --- a/cabal-dev-scripts/src/GenUtils.hs +++ b/cabal-dev-scripts/src/GenUtils.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# 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.Char as C -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.Char as C +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 @@ -25,38 +26,38 @@ 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_23 - | SPDXLicenseListVersion_3_25 + = SPDXLicenseListVersion_3_0 + | SPDXLicenseListVersion_3_2 + | SPDXLicenseListVersion_3_6 + | SPDXLicenseListVersion_3_9 + | SPDXLicenseListVersion_3_10 + | SPDXLicenseListVersion_3_16 + | SPDXLicenseListVersion_3_23 + | SPDXLicenseListVersion_3_25 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_25 = "SPDX License List 3.25" prettyVer SPDXLicenseListVersion_3_23 = "SPDX License List 3.23" 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_25 = "_3_25" suffixVer SPDXLicenseListVersion_3_23 = "_3_23" 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 @@ -66,28 +67,29 @@ data PerV a = PerV a a 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 - index SPDXLicenseListVersion_3_23 (PerV _ _ _ _ _ _ x _) = x - index SPDXLicenseListVersion_3_25 (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) - (f SPDXLicenseListVersion_3_23) - (f SPDXLicenseListVersion_3_25) + 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 + index SPDXLicenseListVersion_3_23 (PerV _ _ _ _ _ _ x _) = x + index SPDXLicenseListVersion_3_25 (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) + (f SPDXLicenseListVersion_3_23) + (f SPDXLicenseListVersion_3_25) ------------------------------------------------------------------------------- -- Sorting @@ -96,11 +98,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 @@ -114,19 +116,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)) @@ -134,18 +136,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 @@ -153,7 +158,8 @@ textShow :: Text -> Text textShow = T.pack . show toConstructorName :: Text -> Text -toConstructorName t = t +toConstructorName t = + t & each %~ f & ix 0 %~ toUpper & special @@ -161,18 +167,21 @@ toConstructorName t = t f '.' = '_' f '-' = '_' f '+' = '\'' - f c = c + f c = c special :: Text -> Text special u | Just (c, _) <- T.uncons u - , C.isDigit c = "N_" <> u + , C.isDigit c = + "N_" <> u special u = u mkList :: [Text] -> Text -mkList [] = " []" -mkList (x:xs) = - " [ " <> x <> "\n" +mkList [] = " []" +mkList (x : xs) = + " [ " + <> x + <> "\n" <> foldMap (\x' -> " , " <> x' <> "\n") xs <> " ]" @@ -181,41 +190,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 61ed1eda13a..4907545c596 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 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 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 9111b2d78d0..cfd0058483c 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 - -> Maybe PkgConfigDb - -> (PN -> PackagePreferences) - -> Map PN [LabeledPackageConstraint] - -> Set PN - -> Progress String String (Assignment, RevDepMap) +solve' + :: SolverConfig + -> CompilerInfo + -> Index + -> Maybe 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 00cf15b466f..0c806e68579 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs @@ -4,15 +4,15 @@ -- -- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) -- > import qualified Distribution.Solver.Modular.ConflictSet as CS -module Distribution.Solver.Modular.ConflictSet ( - ConflictSet -- opaque - , Conflict(..) +module Distribution.Solver.Modular.ConflictSet + ( ConflictSet -- opaque + , Conflict (..) , ConflictMap - , OrderedVersionRange(..) + , OrderedVersionRange (..) , showConflictSet , showCSSortedByFrequency , showCSWithFrequency - -- Set-like operations + -- Set-like operations , toSet , toList , union @@ -29,13 +29,13 @@ module Distribution.Solver.Modular.ConflictSet ( , fromList ) where -import Prelude hiding (lookup) +import Data.Function (on) import Data.List (intercalate, sortBy) import Data.Map (Map) -import Data.Set (Set) -import Data.Function (on) import qualified Data.Map.Strict as M +import Data.Set (Set) import qualified Data.Set as S +import Prelude hiding (lookup) import Distribution.Solver.Modular.Var import Distribution.Solver.Modular.Version @@ -43,9 +43,9 @@ import Distribution.Solver.Types.PackagePath -- | The set of variables involved in a solver conflict, each paired with -- details about the conflict. -newtype ConflictSet = CS { - -- | The set of variables involved in the conflict - conflictSetToMap :: Map (Var QPN) (Set Conflict) +newtype ConflictSet = CS + { conflictSetToMap :: Map (Var QPN) (Set Conflict) + -- ^ The set of variables involved in the conflict } deriving (Eq, Show) @@ -54,28 +54,24 @@ newtype ConflictSet = CS { -- 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. @@ -97,13 +93,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 @@ -116,36 +112,42 @@ toList :: ConflictSet -> [Var QPN] toList = M.keys . conflictSetToMap union :: ConflictSet -> ConflictSet -> ConflictSet -union cs cs' = CS { - conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') +union cs cs' = + CS + { conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') } unions :: [ConflictSet] -> ConflictSet -unions css = CS { - conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) +unions css = + CS + { conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) } insert :: Var QPN -> ConflictSet -> ConflictSet -insert var cs = CS { - conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) +insert var cs = + CS + { conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) } delete :: Var QPN -> ConflictSet -> ConflictSet -delete var cs = CS { - conflictSetToMap = M.delete var (conflictSetToMap cs) +delete var cs = + CS + { conflictSetToMap = M.delete var (conflictSetToMap cs) } empty :: ConflictSet -empty = CS { - conflictSetToMap = M.empty +empty = + CS + { conflictSetToMap = M.empty } singleton :: Var QPN -> ConflictSet singleton var = singletonWithConflict var OtherConflict singletonWithConflict :: Var QPN -> Conflict -> ConflictSet -singletonWithConflict var conflict = CS { - conflictSetToMap = M.singleton var (S.singleton conflict) +singletonWithConflict var conflict = + CS + { conflictSetToMap = M.singleton var (S.singleton conflict) } size :: ConflictSet -> Int @@ -158,8 +160,9 @@ lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) lookup var = M.lookup var . conflictSetToMap fromList :: [Var QPN] -> ConflictSet -fromList vars = CS { - conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] +fromList vars = + CS + { conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] } type ConflictMap = Map (Var QPN) Int 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 3e4e2de3ee6..02d3bbe8497 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 2bc28286df0..2abf3884402 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -1,30 +1,35 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -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, isJust, mapMaybe) import Data.Set (Set) import qualified Data.Set as S -import Data.Maybe (catMaybes, mapMaybe, isJust) import Prelude hiding (pi) import Distribution.Pretty (prettyShow) -- from Cabal import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag ( QFN, QSN ) -import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool ) +import Distribution.Solver.Modular.Flag (QFN, QSN) +import qualified Distribution.Solver.Modular.Flag as Flag (showQFN, showQFNBool, showQSN, showQSNBool) 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 @@ -34,9 +39,11 @@ import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName import Text.PrettyPrint (nest, render) -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 @@ -56,34 +63,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 $ blurbQFNBool Rejecting qfn b ++ showFR c fr) (go l ms) + (atLevel l $ blurbQFNBool Rejecting 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 $ blurbQSNBool Rejecting 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 $ blurbOption Trying qpn' i ++ showGR gr) (go l ms) + (atLevel l $ blurbQSNBool Rejecting 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 $ blurbOption Trying 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 $ blurbOption Trying qpn i) (go l ms) - go !l (Step (TryF qfn b) ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms) - go !l (Step (TryS qsn b) ms) = (atLevel l $ blurbQSNBool Trying 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 $ blurbOption Trying qpn i) (go l ms) + go !l (Step (TryF qfn b) ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms) + go !l (Step (TryS qsn b) ms) = (atLevel l $ blurbQSNBool Trying 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 $ blurb 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 $ blurb 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 @@ -92,129 +99,146 @@ 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' = - -- By prepending (i : is) we reverse the order of the instances. - goPReject l qpn (i : is) c fr ms + -- By prepending (i : is) we reverse the order of the instances. + goPReject l qpn (i : is) c fr ms goPReject l qpn is c fr ms = - (atLevel l $ blurbOptions Rejecting qpn (reverse is) ++ showFR c fr) + (atLevel l $ blurbOptions Rejecting 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' = - -- By prepending (i : is) we reverse the order of the instances. - goPSkip l qpn (i : is) conflicts ms + -- By prepending (i : is) we reverse the order of the instances. + goPSkip l qpn (i : is) conflicts ms goPSkip l qpn is conflicts ms = let msg = blurbOptions Skipping qpn (reverse is) ++ showConflicts conflicts - in atLevel l msg (go l ms) + 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 } -data ProgressAction = - Trying +data ProgressAction + = Trying | Skipping | Rejecting @@ -239,7 +263,7 @@ blurbOptions a q ps = blurb a ++ showOptions q ps showOption :: QPN -> POption -> String showOption 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) -- | Shows a mixed list of instances and versions in a human-friendly way, @@ -263,57 +287,62 @@ showOption qpn@(Q _pp pn) (POption i linkedTo) = showOptions :: QPN -> [POption] -> String showOptions _ [] = "unexpected empty list of versions" showOptions q [x] = showOption q x -showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", " - [if isJust linkedTo - then showOption q x - else showI i -- Don't show the package, just the version - | x@(POption i linkedTo) <- xs - ]) +showOptions q xs = + showQPN q + ++ "; " + ++ ( L.intercalate + ", " + [ if isJust linkedTo + then showOption q x + else showI i -- Don't show the package, just the version + | x@(POption i linkedTo) <- xs + ] + ) 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 _ (MissingPkgconfigProgram pn vr) = " (pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ " is needed but no pkg-config executable was found or querying it failed)" +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 _ (MissingPkgconfigProgram pn vr) = " (pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ " is needed but no pkg-config executable was found or querying it failed)" 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 _ 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 _ 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 (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc) 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: " ++ Flag.showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")" -showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.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 @@ -322,14 +351,22 @@ 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 -- $setup -- >>> import Distribution.Solver.Types.PackagePath 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 a8c236a9d7b..0420012ddc9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs @@ -1,32 +1,33 @@ {-# 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 +43,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 +61,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 +75,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 +90,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 +104,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 +133,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 9e0d5fb4d22..22c6b9291f8 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -1,28 +1,29 @@ {-# 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 - , onlyConstrained - , sortGoals - , pruneAfterFirstSuccess - ) where + ( avoidReinstalls + , deferSetupExeChoices + , deferWeakFlagChoices + , enforceManualFlags + , enforcePackageConstraints + , enforceSingleInstanceRestriction + , firstGoal + , preferBaseGoalChoice + , preferLinked + , preferPackagePreferences + , preferReallyEasyGoalChoices + , 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 @@ -35,13 +36,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 @@ -60,13 +61,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] @@ -78,13 +83,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. -- @@ -100,17 +106,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. @@ -118,7 +124,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. @@ -128,19 +134,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. @@ -159,116 +165,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 @@ -295,27 +316,29 @@ 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 -- | Avoid reinstalls. -- @@ -334,43 +357,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 @@ -379,10 +404,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. @@ -394,8 +419,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 @@ -405,11 +431,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 @@ -417,12 +443,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 @@ -431,15 +457,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. -- @@ -451,7 +477,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 b57f55af1fc..87446cb56eb 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #endif +{- FOURMOLU_DISABLE -} + module Distribution.Solver.Modular.Solver ( SolverConfig(..) , solve diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index 36aef5ebac7..5e3416318a3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -1,22 +1,23 @@ {-# 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 +26,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 +50,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 +70,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 +95,37 @@ data Tree d c = data POption = POption I (Maybe PackagePath) deriving (Eq, Show) -data FailReason = UnsupportedExtension Extension - | UnsupportedLanguage Language - | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange - | MissingPkgconfigProgram 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 - | 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 + | MissingPkgconfigProgram 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 + | 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 +134,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 +194,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 4af149b31cf..0efba0c7075 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} + module Distribution.Solver.Modular.Validate (validateTree) where -- Validation of the tree. @@ -8,8 +9,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) @@ -19,7 +20,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 @@ -87,31 +88,26 @@ import Distribution.Types.PkgconfigVersionRange -- 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 :: Maybe (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 :: Maybe (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) @@ -143,8 +139,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. @@ -158,7 +154,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 @@ -166,41 +162,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 @@ -209,13 +209,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 @@ -223,26 +225,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. @@ -259,20 +268,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. @@ -289,41 +298,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 @@ -335,15 +349,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 @@ -355,19 +369,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. -- @@ -381,32 +395,37 @@ 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 - -> Maybe (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 + -> Maybe (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)) = + 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)) = case (\f -> f pn vr) <$> pkgPresent of Just True -> Right a Just False -> Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) Nothing -> Left (dependencyReasonToConflictSet dr, MissingPkgconfigProgram 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. @@ -418,14 +437,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 @@ -446,136 +468,161 @@ extendWithPackageChoice (PI qpn i) ppa = -- order in which we check the constraints. merge :: MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) - | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 + | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 | otherwise = - Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - + Left + ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 + , + ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) + , ConflictingDep vs2 (PkgComponent p comp2) ci + ) + ) merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i - | otherwise = - Left ( createConflictSetForVersionConflict p v vs1 vr vs2 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - + | otherwise = + Left + ( createConflictSetForVersionConflict p v vs1 vr vs2 + , + ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) + , ConflictingDep vs2 (PkgComponent p comp2) ci + ) + ) merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = - go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... + go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep go [] = Right (MergedDepFixed comp2 vs2 i) go ((vr, comp1, vs1) : vros) - | checkVR vr v = go vros - | otherwise = - Left ( createConflictSetForVersionConflict p v vs2 vr vs1 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - + | checkVR vr v = go vros + | otherwise = + Left + ( createConflictSetForVersionConflict p v vs2 vr vs1 + , + ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) + , ConflictingDep vs2 (PkgComponent p comp2) ci + ) + ) merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = - Right (MergedDepConstrained $ - - -- TODO: This line appends the new version range, to preserve the order used - -- before a refactoring. Consider prepending the version range, if there is - -- no negative performance impact. - vrOrigins ++ [(vr, comp2, vs2)]) + Right + ( MergedDepConstrained $ + -- TODO: This line appends the new version range, to preserve the order used + -- before a refactoring. Consider prepending the version range, if there is + -- no negative performance impact. + vrOrigins ++ [(vr, comp2, vs2)] + ) -- | 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 -> Maybe 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 94def7be196..dfb75983fe9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Distribution.Solver.Modular.WeightedPSQ ( - WeightedPSQ + +module Distribution.Solver.Modular.WeightedPSQ + ( WeightedPSQ , fromList , toList , keys @@ -36,9 +37,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 +63,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 +84,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 +100,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 3f171b3c6d7..6c1e0839d52 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -1,61 +1,49 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) - , showConstraintSource - ) where + ( ConstraintSource (..) + , showConstraintSource + ) where +import Distribution.Pretty (Pretty (pretty), prettyShow) import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath) -import Distribution.Pretty (Pretty(pretty), prettyShow) import Text.PrettyPrint (text) -- | Source of a 'PackageConstraint'. -data ConstraintSource = - - -- | Main config file, which is ~/.cabal/config by default. - ConstraintSourceMainConfig FilePath - - -- | Local cabal.project file - | ConstraintSourceProjectConfig ProjectConfigPath - - -- | 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. - | ConstraintSourceNonReinstallablePackage - - -- | 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 - - -- | Constraint introduced by --enable-profiling-shared, which requires features - -- from Cabal >= 3.13 - | ConstraintSourceProfiledDynamic - - -- | 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 ProjectConfigPath + | -- | 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. + ConstraintSourceNonReinstallablePackage + | -- | 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 + | -- | Constraint introduced by --enable-profiling-shared, which requires features + -- from Cabal >= 3.13 + ConstraintSourceProfiledDynamic + | -- | 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 (Show, Eq, Generic) instance Binary ConstraintSource @@ -71,7 +59,7 @@ instance Pretty ConstraintSource where text "main config" <+> text path (ConstraintSourceProjectConfig path) -> text "project config" <+> docProjectConfigPath path - (ConstraintSourceUserConfig path)-> text "user config " <+> text path + (ConstraintSourceUserConfig path) -> text "user config " <+> text path ConstraintSourceCommandlineFlag -> text "command line flag" ConstraintSourceUserTarget -> text "user target" ConstraintSourceNonReinstallablePackage -> diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 139a6d2b33d..faf54125809 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) - -> Maybe PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> Set PackageName - -> Progress String String [ResolverPackage loc] +type DependencyResolver loc = + Platform + -> CompilerInfo + -> InstalledPackageIndex + -> PackageIndex (SourcePackage loc) + -> Maybe 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 06c5ae169fa..c71e9c028dd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -4,54 +4,52 @@ -- 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(..), - PackageConstraint(..), - showPackageConstraint, - packageConstraintToDependency +module Distribution.Solver.Types.PackageConstraint + ( ConstraintScope (..) + , scopeToplevel + , scopeToPackageName + , constraintScopeMatches + , PackageProperty (..) + , PackageConstraint (..) + , showPackageConstraint + , packageConstraintToDependency ) where import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package (PackageName) -import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, Pretty(pretty)) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Pretty (Pretty (pretty), flatStyle) 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 @@ -71,13 +69,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' instance Pretty ConstraintScope where @@ -88,11 +86,11 @@ instance Pretty ConstraintScope where -- | 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 @@ -100,10 +98,10 @@ instance Structured PackageProperty instance Pretty PackageProperty where pretty (PackagePropertyVersion verrange) = pretty verrange - pretty PackagePropertyInstalled = Disp.text "installed" - pretty PackagePropertySource = Disp.text "source" - pretty (PackagePropertyFlags flags) = dispFlagAssignment flags - pretty (PackagePropertyStanzas stanzas) = + pretty PackagePropertyInstalled = Disp.text "installed" + pretty PackagePropertySource = Disp.text "source" + pretty (PackagePropertyFlags flags) = dispFlagAssignment flags + pretty (PackagePropertyStanzas stanzas) = Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property @@ -118,7 +116,6 @@ instance Pretty PackageConstraint where -- | 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 $ pretty pc2 @@ -137,7 +134,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 13322d00f65..6dfeed6774f 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,40 +14,47 @@ -- 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 Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Control.Exception (handle) +import Control.Monad (mapM) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T -import System.FilePath (splitSearchPath) +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) + ( ConfiguredProgram + , ProgramDb + , getProgramOutput + , needProgram + , pkgConfigProgram + ) import Distribution.Simple.Program.Run - (getProgramInvocationOutputAndErrors, programInvocation, getProgramInvocationLBSAndErrors) -import Distribution.Simple.Utils (info) + ( getProgramInvocationLBSAndErrors + , 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@. @@ -52,7 +63,7 @@ import Distribution.Verbosity (Verbosity) -- but we don't know the exact version (because parsing of the version number -- failed). newtype PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) - deriving (Show, Generic, Typeable) + deriving (Show, Generic, Typeable) instance Binary PkgConfigDb instance Structured PkgConfigDb @@ -62,32 +73,34 @@ instance Structured PkgConfigDb -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO (Maybe 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 - -- To prevent malformed Unicode in the descriptions from crashing cabal, - -- read without interpreting any encoding first. (#9608) - (listAllOutput, listAllErrs, listAllExitcode) <- - getProgramInvocationLBSAndErrors verbosity (programInvocation pkgConfig ["--list-all"]) - when (listAllExitcode /= ExitSuccess) $ - ioError (userError ("pkg-config --list-all failed: " ++ listAllErrs)) - let pkgList = LBS.split (fromIntegral (ord '\n')) listAllOutput - -- Now decode the package *names* to a String. The ones where decoding - -- failed end up in 'failedPkgNames'. - let (failedPkgNames, pkgNames) = - partitionEithers + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "cannot find pkg-config program" + Just (pkgConfig, _) -> do + -- To prevent malformed Unicode in the descriptions from crashing cabal, + -- read without interpreting any encoding first. (#9608) + (listAllOutput, listAllErrs, listAllExitcode) <- + getProgramInvocationLBSAndErrors verbosity (programInvocation pkgConfig ["--list-all"]) + when (listAllExitcode /= ExitSuccess) $ + ioError (userError ("pkg-config --list-all failed: " ++ listAllErrs)) + let pkgList = LBS.split (fromIntegral (ord '\n')) listAllOutput + -- Now decode the package *names* to a String. The ones where decoding + -- failed end up in 'failedPkgNames'. + let (failedPkgNames, pkgNames) = + partitionEithers -- Drop empty package names. This will handle empty lines -- in pkg-config's output, including the spurious one -- after the last newline (because of LBS.split). . filter (either (const True) (not . null)) -- Try decoding strictly; if it fails, put the lenient -- decoding in a Left for later reporting. - . map (\bsname -> - let sbsname = LBS.toStrict bsname - in case T.decodeUtf8' sbsname of - Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname)) - Right name -> Right (T.unpack name)) + . map + ( \bsname -> + let sbsname = LBS.toStrict bsname + in case T.decodeUtf8' sbsname of + Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname)) + Right name -> Right (T.unpack name) + ) -- The output of @pkg-config --list-all@ also includes a -- description for each package, which we do not need. -- We don't use Data.Char.isSpace because that would also @@ -95,44 +108,48 @@ readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do -- in multi-byte UTF-8 sequences. . map (LBS.takeWhile (not . isAsciiSpace)) $ pkgList - when (not (null failedPkgNames)) $ - info verbosity ("Some pkg-config packages have names containing invalid unicode: " ++ intercalate ", " failedPkgNames) - (outs, _errs, exitCode) <- - getProgramInvocationOutputAndErrors verbosity - (programInvocation pkgConfig ("--modversion" : pkgNames)) - let pkgVersions = lines outs - if exitCode == ExitSuccess && length pkgVersions == length pkgNames - then (return . Just . pkgConfigDbFromList . zip pkgNames) pkgVersions - else - -- if there's a single broken pc file the above fails, so we fall back - -- into calling it individually - -- - -- Also some implementations of @pkg-config@ do not provide more than - -- one package version, so if the returned list is shorter than the - -- requested one, we fall back to querying one by one. - do - info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") - Just . pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames + when (not (null failedPkgNames)) $ + info verbosity ("Some pkg-config packages have names containing invalid unicode: " ++ intercalate ", " failedPkgNames) + (outs, _errs, exitCode) <- + getProgramInvocationOutputAndErrors + verbosity + (programInvocation pkgConfig ("--modversion" : pkgNames)) + let pkgVersions = lines outs + if exitCode == ExitSuccess && length pkgVersions == length pkgNames + then (return . Just . pkgConfigDbFromList . zip pkgNames) pkgVersions + else -- if there's a single broken pc file the above fails, so we fall back + -- into calling it individually + -- + -- Also some implementations of @pkg-config@ do not provide more than + -- one package version, so if the returned list is shorter than the + -- requested one, we fall back to querying one by one. + do + info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") + Just . 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 ("Warning: Failed to query pkg-config, Cabal will backtrack " - ++ "if a package from pkg-config is requested. Error message: " - ++ extra) - return Nothing + info + verbosity + ( "Warning: Failed to query pkg-config, Cabal will backtrack " + ++ "if a package from pkg-config is requested. Error message: " + ++ extra + ) + return Nothing ioErrorHandler :: IOException -> IO (Maybe 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 isAsciiSpace :: Word8 -> Bool isAsciiSpace c = c `elem` map (fromIntegral . ord) " \t" @@ -146,18 +163,18 @@ readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do -- | 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 -- | Query the version of a package in the @pkg-config@ database. -- @Nothing@ indicates the package is not in the database, while @@ -168,11 +185,10 @@ pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db -- | 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 @@ -180,8 +196,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@: -- @@ -194,13 +211,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/ProjectConfigPath.hs b/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs index 84375b0f4de..80e8eead5e3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs @@ -2,25 +2,24 @@ {-# LANGUAGE ViewPatterns #-} module Distribution.Solver.Types.ProjectConfigPath - ( - -- * Project Config Path Manipulation - ProjectConfigPath(..) - , projectConfigPathRoot - , nullProjectConfigPath - , consProjectConfigPath - , unconsProjectConfigPath + ( -- * Project Config Path Manipulation + ProjectConfigPath (..) + , projectConfigPathRoot + , nullProjectConfigPath + , consProjectConfigPath + , unconsProjectConfigPath -- * Messages - , docProjectConfigPath - , docProjectConfigFiles - , cyclicalImportMsg - , docProjectConfigPathFailReason + , docProjectConfigPath + , docProjectConfigFiles + , cyclicalImportMsg + , docProjectConfigPathFailReason -- * Checks and Normalization - , isCyclicConfigPath - , isTopLevelConfigPath - , canonicalizeConfigPath - ) where + , isCyclicConfigPath + , isTopLevelConfigPath + , canonicalizeConfigPath + ) where import Distribution.Solver.Compat.Prelude hiding (toList, (<>)) import qualified Distribution.Solver.Compat.Prelude as P ((<>)) @@ -28,14 +27,14 @@ import Prelude (sequence) import Data.Coerce (coerce) import Data.List.NonEmpty ((<|)) -import Network.URI (parseURI, parseAbsoluteURI) -import System.Directory -import System.FilePath import qualified Data.List.NonEmpty as NE -import Distribution.Solver.Modular.Version (VR) import Distribution.Pretty (prettyShow) -import Text.PrettyPrint import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Modular.Version (VR) +import Network.URI (parseAbsoluteURI, parseURI) +import System.Directory +import System.FilePath +import Text.PrettyPrint -- | Path to a configuration file, either a singleton project root, or a longer -- list representing a path to an import. The path is a non-empty list that we @@ -49,7 +48,7 @@ import Distribution.Simple.Utils (ordNub) -- List elements are relative to each other but once canonicalized, elements are -- relative to the directory of the project root. newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic) -- | Sorts URIs after local file paths and longer file paths after shorter ones -- as measured by the number of path segments. If still equal, then sorting is @@ -59,31 +58,30 @@ newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath) -- configuration paths it imports, should always sort first. Comparing one -- project root path against another is done lexically. instance Ord ProjectConfigPath where - compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) = - case (as, bs) of - -- There should only ever be one root project path, only one path - -- with length 1. Comparing it to itself should be EQ. Don't assume - -- this though, do a comparison anyway when both sides have length - -- 1. The root path, the project itself, should always be the first - -- path in a sorted listing. - ([a], [b]) -> compare a b - ([_], _) -> LT - (_, [_]) -> GT - - (a:_, b:_) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of - (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters - (Just _, Nothing) -> GT - (Nothing, Just _) -> LT - (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters - _ -> - compare (length as) (length bs) - P.<> compare (length aPaths) (length bPaths) - P.<> compare aPaths bPaths - where - aPaths = splitPath <$> as - bPaths = splitPath <$> bs - aImporters = snd $ unconsProjectConfigPath pa - bImporters = snd $ unconsProjectConfigPath pb + compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) = + case (as, bs) of + -- There should only ever be one root project path, only one path + -- with length 1. Comparing it to itself should be EQ. Don't assume + -- this though, do a comparison anyway when both sides have length + -- 1. The root path, the project itself, should always be the first + -- path in a sorted listing. + ([a], [b]) -> compare a b + ([_], _) -> LT + (_, [_]) -> GT + (a : _, b : _) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of + (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters + (Just _, Nothing) -> GT + (Nothing, Just _) -> LT + (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters + _ -> + compare (length as) (length bs) + P.<> compare (length aPaths) (length bPaths) + P.<> compare aPaths bPaths + where + aPaths = splitPath <$> as + bPaths = splitPath <$> bs + aImporters = snd $ unconsProjectConfigPath pa + bImporters = snd $ unconsProjectConfigPath pb instance Binary ProjectConfigPath instance Structured ProjectConfigPath @@ -99,8 +97,9 @@ instance Structured ProjectConfigPath -- "D.config\n imported by: C.config\n imported by: B.config\n imported by: A.project" docProjectConfigPath :: ProjectConfigPath -> Doc docProjectConfigPath (ProjectConfigPath (p :| [])) = text p -docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ - text p : [ text " " <+> text "imported by:" <+> text l | l <- ps ] +docProjectConfigPath (ProjectConfigPath (p :| ps)) = + vcat $ + text p : [text " " <+> text "imported by:" <+> text l | l <- ps] -- | Renders the paths as a list without showing which path imports another, -- like this; @@ -137,30 +136,32 @@ docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ -- :} -- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config" docProjectConfigFiles :: [ProjectConfigPath] -> Doc -docProjectConfigFiles ps = vcat +docProjectConfigFiles ps = + vcat [ text "-" <+> text p - | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ] + | p <- ordNub [p | ProjectConfigPath (p :| _) <- ps] ] -- | A message for a cyclical import, a "cyclical import of". cyclicalImportMsg :: ProjectConfigPath -> Doc cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) = - vcat + vcat [ text "cyclical import of" <+> text duplicate <> semi , nest 2 (docProjectConfigPath path) ] docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc docProjectConfigPathFailReason vr pcp - | ProjectConfigPath (p :| []) <- pcp = - constraint p - | ProjectConfigPath (p :| ps) <- pcp = vcat + | ProjectConfigPath (p :| []) <- pcp = + constraint p + | ProjectConfigPath (p :| ps) <- pcp = + vcat [ constraint p - , cat [nest 2 $ text "imported by:" <+> text l | l <- ps ] + , cat [nest 2 $ text "imported by:" <+> text l | l <- ps] ] - where - pathRequiresVersion p = text p <+> text "requires" <+> text (prettyShow vr) - constraint p = parens $ text "constraint from" <+> pathRequiresVersion p + where + pathRequiresVersion p = text p <+> text "requires" <+> text (prettyShow vr) + constraint p = parens $ text "constraint from" <+> pathRequiresVersion p -- | The root of the path, the project itself. projectConfigPathRoot :: ProjectConfigPath -> FilePath @@ -195,9 +196,9 @@ unconsProjectConfigPath ps = fmap ProjectConfigPath <$> NE.uncons (coerce ps) -- relative to the file they were imported from. makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath makeRelativeConfigPath dir (ProjectConfigPath p) = - ProjectConfigPath - $ (\segment -> (if isURI segment then segment else makeRelative dir segment)) - <$> p + ProjectConfigPath $ + (\segment -> (if isURI segment then segment else makeRelative dir segment)) + <$> p -- | Normalizes and canonicalizes a path removing '.' and '..' indirections. -- Makes the path relative to the given directory (typically the project root) @@ -275,12 +276,20 @@ makeRelativeConfigPath dir (ProjectConfigPath p) = -- True canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath canonicalizeConfigPath d (ProjectConfigPath p) = do - xs <- sequence $ NE.scanr (\importee -> (>>= \importer -> - if isURI importee - then pure importee - else canonicalizePath $ d takeDirectory importer importee)) - (pure ".") p - return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs + xs <- + sequence $ + NE.scanr + ( \importee -> + ( >>= + \importer -> + if isURI importee + then pure importee + else canonicalizePath $ d takeDirectory importer importee + ) + ) + (pure ".") + p + return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs isURI :: FilePath -> Bool isURI = isJust . parseURI 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 c72c8b5aa6f..cfd2850ebf7 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 erroneousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erroneousElement suggestion) where suggestion = mostSimilarElement erroneousElement elems diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index a732fda6d48..a559f7d4f40 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -1,49 +1,48 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -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.Program -import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Simple.Utils (getDirectoryContentsRecursive) +import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity (Verbosity, normal, verbose) -import Options.Applicative -import Control.Concurrent.MVar import Control.Concurrent import Control.Concurrent.Async +import Control.Concurrent.MVar import Control.Exception import Control.Monad -import GHC.Conc (numCapabilities) import Data.List -import Data.Proxy (Proxy(Proxy)) +import Data.Maybe +import Data.Proxy (Proxy (Proxy)) import qualified Data.Sequence as Seq (fromList) -import Text.Printf +import Distribution.Pretty +import GHC.Conc (numCapabilities) +import Options.Applicative +import qualified System.Clock as Clock +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process (readProcessWithExitCode, showCommandForUser) import qualified Test.Tasty.Options as Tasty - ( OptionSet - , OptionDescription (Option) + ( OptionDescription (Option) + , OptionSet , lookupOption ) import qualified Test.Tasty.Runners as Tasty - ( optionParser - , TestPattern + ( TestPattern + , optionParser , testPatternMatches ) -import qualified System.Clock as Clock -import System.IO -import System.FilePath -import System.Exit -import System.Process (readProcessWithExitCode, showCommandForUser) -import System.Directory -import Distribution.Pretty -import Data.Maybe - +import Text.Printf {- Note [Testsuite package environments] @@ -75,17 +74,17 @@ package databases (yet). -} -- | 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, - mainArgCabalSpec :: Maybe CabalLibSpec, - mainCommonArgs :: CommonArgs, - mainTastyArgs :: Tasty.OptionSet - } +data MainArgs = MainArgs + { mainArgThreads :: Int + , mainArgTestPaths :: [String] + , mainArgHideSuccesses :: Bool + , mainArgVerbose :: Bool + , mainArgQuiet :: Bool + , mainArgDistDir :: Maybe FilePath + , mainArgCabalSpec :: Maybe CabalLibSpec + , mainCommonArgs :: CommonArgs + , mainTastyArgs :: Tasty.OptionSet + } data CabalLibSpec = BootCabalLib | InTreeCabalLib FilePath FilePath | SpecificCabalLib String FilePath @@ -93,40 +92,50 @@ cabalLibSpecParser :: Parser CabalLibSpec cabalLibSpecParser = bootParser <|> intreeParser <|> specificParser where bootParser = flag' BootCabalLib (long "boot-cabal-lib") - intreeParser = InTreeCabalLib <$> strOption (long "intree-cabal-lib" <> metavar "ROOT") - <*> option str ( help "Test TMP" <> long "test-tmp" ) - specificParser = SpecificCabalLib <$> strOption (long "specific-cabal-lib" <> metavar "VERSION") - <*> option str ( help "Test TMP" <> long "test-tmp" ) - + intreeParser = + InTreeCabalLib + <$> strOption (long "intree-cabal-lib" <> metavar "ROOT") + <*> option str (help "Test TMP" <> long "test-tmp") + specificParser = + SpecificCabalLib + <$> strOption (long "specific-cabal-lib" <> metavar "VERSION") + <*> option str (help "Test TMP" <> long "test-tmp") -- | 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" + ) + ) <*> optional cabalLibSpecParser <*> commonArgParser <*> tastyArgParser @@ -138,13 +147,13 @@ tastyArgParser = [ Tasty.Option (Proxy @Tasty.TestPattern) ] in if null warnings - then parser - else error $ unlines ("Failed to create parser for Tasty CLI options:" : warnings) + then parser + else error $ unlines ("Failed to create parser for Tasty CLI options:" : warnings) -- Unpack and build a specific released version of Cabal and Cabal-syntax libraries buildCabalLibsProject :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath] buildCabalLibsProject projString verb mbGhc dir = do - let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc] ] defaultProgramDb + let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc]] defaultProgramDb (cabal, _) <- requireProgram verb (simpleProgram "cabal") prog_db (ghc, _) <- requireProgram verb ghcProgram prog_db @@ -154,42 +163,49 @@ buildCabalLibsProject projString verb mbGhc dir = do createDirectoryIfMissing True dir writeFile (dir "cabal.project-test") projString - runProgramInvocation verb - ((programInvocation cabal - ["--store-dir", storeRoot - , "--project-file=" ++ dir "cabal.project-test" - , "build" - , "-w", programPath ghc - , "Cabal", "Cabal-syntax", "Cabal-hooks" - ] ) { progInvokeCwd = Just dir }) + runProgramInvocation + verb + ( ( programInvocation + cabal + [ "--store-dir" + , storeRoot + , "--project-file=" ++ dir "cabal.project-test" + , "build" + , "-w" + , programPath ghc + , "Cabal" + , "Cabal-syntax" + , "Cabal-hooks" + ] + ) + { progInvokeCwd = Just dir + } + ) -- Determine the path to the packagedb in the store for this ghc version storesByGhc <- getDirectoryContents storeRoot case filter (prettyShow pv `isInfixOf`) storesByGhc of [] -> return [final_package_db] - storeForGhc:_ -> do + storeForGhc : _ -> do let storePackageDB = (storeRoot storeForGhc "package.db") return [storePackageDB, final_package_db] - - buildCabalLibsSpecific :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath] buildCabalLibsSpecific ver verb mbGhc builddir_rel = do - let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc] ] defaultProgramDb + let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc]] defaultProgramDb (cabal, _) <- requireProgram verb (simpleProgram "cabal") prog_db dir <- canonicalizePath (builddir_rel "specific" ver) cgot <- doesDirectoryExist (dir "Cabal-" ++ ver) unless cgot $ - runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-" ++ ver]) { progInvokeCwd = Just dir }) + runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-" ++ ver]){progInvokeCwd = Just dir}) csgot <- doesDirectoryExist (dir "Cabal-syntax-" ++ ver) unless csgot $ - runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-syntax-" ++ ver]) { progInvokeCwd = Just dir }) + runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-syntax-" ++ ver]){progInvokeCwd = Just dir}) chgot <- doesDirectoryExist (dir "Cabal-hooks-" ++ ver) unless chgot $ - runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-hooks-" ++ ver]) { progInvokeCwd = Just dir }) + runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-hooks-" ++ ver]){progInvokeCwd = Just dir}) buildCabalLibsProject ("packages: Cabal-" ++ ver ++ " Cabal-syntax-" ++ ver ++ " Cabal-hooks-" ++ ver) verb mbGhc dir - buildCabalLibsIntree :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath] buildCabalLibsIntree root verb mbGhc builddir_rel = do dir <- canonicalizePath (builddir_rel "intree") @@ -197,208 +213,230 @@ buildCabalLibsIntree root verb mbGhc builddir_rel = do 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 - testPattern = Tasty.lookupOption @Tasty.TestPattern (mainTastyArgs args) - - pkg_dbs <- - -- Not path to cabal-install so we're not going to run cabal-install tests so we - -- can skip setting up a Cabal library to use with cabal-install. - case argCabalInstallPath (mainCommonArgs args) of - Nothing -> do - when (isJust $ mainArgCabalSpec args) - (putStrLn "Ignoring Cabal library specification as cabal-install tests are not running") - return [] - -- Path to cabal-install is passed, so need to install the requested relevant version of Cabal - -- library. - Just {} -> - case mainArgCabalSpec args of - Nothing -> do - putStrLn "No Cabal library specified, using boot Cabal library with cabal-install tests" - return [] - Just BootCabalLib -> return [] - Just (InTreeCabalLib root build_dir) -> - buildCabalLibsIntree root verbosity (argGhcPath (mainCommonArgs args)) build_dir - Just (SpecificCabalLib ver build_dir) -> - buildCabalLibsSpecific ver verbosity (argGhcPath (mainCommonArgs args)) build_dir - - -- 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 -> getSymbolicPath <$> guessDistDir - when (verbosity >= verbose) $ - hPutStrLn stderr $ "Using dist dir: " ++ dist_dir - -- Get ready to go! - senv <- mkScriptEnv verbosity - - let runTest :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result) - -> FilePath - -> IO result - runTest runner path - = runner Nothing [] path $ - ["--builddir", dist_dir, path] ++ ["--extra-package-db=" ++ pkg_db | pkg_db <- pkg_dbs] ++ renderCommonArgs (mainCommonArgs args) - - case mainArgTestPaths args of - [path] -> do - -- Simple runner - (real_path, real_args) <- runTest (runnerCommand senv) path - hPutStrLn stderr $ showCommandForUser real_path real_args - -- If the test was reported flaky, the `runghc` call will exit - -- with exit code 1, and report `TestCodeFlaky` on the stderr output - -- - -- This seems to be the only way to catch this case. - -- - -- Sadly it means that stdout and stderr are not interleaved - -- directly anymore. - (e, out, err) <- readProcessWithExitCode real_path real_args "" - putStrLn "# STDOUT:" - putStrLn out - putStrLn "# STDERR:" - putStrLn err - if "TestCodeFlaky" `isInfixOf` err - then pure () - else throwIO e - hPutStrLn stderr "OK" - user_paths -> do - -- Read out tests from filesystem - hPutStrLn stderr $ "threads: " ++ show (mainArgThreads 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 testPattern 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) - - -- 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 [] - flaky_pass_var <- newMVar [] - flaky_fail_var <- newMVar [] - - 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) - - -- 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 "" - - 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 (isJust $ isTestCodeUnexpectedSuccess code) $ - modifyMVar_ unexpected_passes_var $ \paths -> - return (path:paths) - - when (isTestCodeSkip code) $ - modifyMVar_ skipped_var $ \paths -> - return (path:paths) - - case isTestCodeFlaky code of - NotFlaky -> pure () - Flaky b _ -> - modifyMVar_ (if b then flaky_pass_var else flaky_fail_var) $ \paths -> - return (path:paths) - - 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) - - unexpected_fails <- takeMVar unexpected_fails_var - unexpected_passes <- takeMVar unexpected_passes_var - skipped <- takeMVar skipped_var - flaky_passes <- takeMVar flaky_pass_var - flaky_fails <- takeMVar flaky_fail_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, " - ++ sl flaky_passes ++ " flaky passes, " - ++ sl flaky_fails ++ " flaky 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 + -- 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 + testPattern = Tasty.lookupOption @Tasty.TestPattern (mainTastyArgs args) + + pkg_dbs <- + -- Not path to cabal-install so we're not going to run cabal-install tests so we + -- can skip setting up a Cabal library to use with cabal-install. + case argCabalInstallPath (mainCommonArgs args) of + Nothing -> do + when + (isJust $ mainArgCabalSpec args) + (putStrLn "Ignoring Cabal library specification as cabal-install tests are not running") + return [] + -- Path to cabal-install is passed, so need to install the requested relevant version of Cabal + -- library. + Just{} -> + case mainArgCabalSpec args of + Nothing -> do + putStrLn "No Cabal library specified, using boot Cabal library with cabal-install tests" + return [] + Just BootCabalLib -> return [] + Just (InTreeCabalLib root build_dir) -> + buildCabalLibsIntree root verbosity (argGhcPath (mainCommonArgs args)) build_dir + Just (SpecificCabalLib ver build_dir) -> + buildCabalLibsSpecific ver verbosity (argGhcPath (mainCommonArgs args)) build_dir + + -- 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 -> getSymbolicPath <$> guessDistDir + when (verbosity >= verbose) $ + hPutStrLn stderr $ + "Using dist dir: " ++ dist_dir + -- Get ready to go! + senv <- mkScriptEnv verbosity + + let runTest + :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result) + -> FilePath + -> IO result + runTest runner path = + runner Nothing [] path $ + ["--builddir", dist_dir, path] ++ ["--extra-package-db=" ++ pkg_db | pkg_db <- pkg_dbs] ++ renderCommonArgs (mainCommonArgs args) + + case mainArgTestPaths args of + [path] -> do + -- Simple runner + (real_path, real_args) <- runTest (runnerCommand senv) path + hPutStrLn stderr $ showCommandForUser real_path real_args + -- If the test was reported flaky, the `runghc` call will exit + -- with exit code 1, and report `TestCodeFlaky` on the stderr output + -- + -- This seems to be the only way to catch this case. + -- + -- Sadly it means that stdout and stderr are not interleaved + -- directly anymore. + (e, out, err) <- readProcessWithExitCode real_path real_args "" + putStrLn "# STDOUT:" + putStrLn out + putStrLn "# STDERR:" + putStrLn err + if "TestCodeFlaky" `isInfixOf` err + then pure () + else throwIO e + hPutStrLn stderr "OK" + user_paths -> do + -- Read out tests from filesystem + hPutStrLn stderr $ "threads: " ++ show (mainArgThreads 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 testPattern 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) + + -- 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 [] + flaky_pass_var <- newMVar [] + flaky_fail_var <- newMVar [] + + 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) + + -- 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 "" + + 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 (isJust $ isTestCodeUnexpectedSuccess code) $ + modifyMVar_ unexpected_passes_var $ \paths -> + return (path : paths) + + when (isTestCodeSkip code) $ + modifyMVar_ skipped_var $ \paths -> + return (path : paths) + + case isTestCodeFlaky code of + NotFlaky -> pure () + Flaky b _ -> + modifyMVar_ (if b then flaky_pass_var else flaky_fail_var) $ \paths -> + return (path : paths) + + 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) + + unexpected_fails <- takeMVar unexpected_fails_var + unexpected_passes <- takeMVar unexpected_passes_var + skipped <- takeMVar skipped_var + flaky_passes <- takeMVar flaky_pass_var + flaky_fails <- takeMVar flaky_fail_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, " + ++ sl flaky_passes + ++ " flaky passes, " + ++ sl flaky_fails + ++ " flaky 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 findTests :: IO [FilePath] findTests = getDirectoryContentsRecursive "." @@ -416,51 +454,52 @@ partitionTests testPattern paths = toTastyPath path = Seq.fromList $ splitDirectories path go ts ms [] = (keepPatternMatches ts, keepPatternMatches 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 e335d6b93db..8b93225eb49 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 = noCabalPackageDb $ cabal "build" ("--enable-build-info":args) +runShowBuildInfo args = noCabalPackageDb $ 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 31e1e07bf52..02f8b0c8bad 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -2,194 +2,229 @@ {-# 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, - requireSuccess, - initWorkDir, - recordLog, + , programPathM + , requireProgramM + , isAvailableProgram + , hackageRepoToolProgram + , gitProgram + , cabalProgram + , diffProgram + , python3Program + , requireSuccess + , initWorkDir + , recordLog + -- * The test environment - TestEnv(..), - getTestEnv, + , TestEnv (..) + , getTestEnv + -- * Recording mode - RecordMode(..), - testRecordMode, + , RecordMode (..) + , testRecordMode + -- * Derived values from 'TestEnv' - testCurrentDir, - testWorkDir, - testPrefixDir, - testLibInstallDir, - testDistDir, - testPackageDbDir, - testRepoDir, - testKeysDir, - testSourceCopyDir, - testCabalDir, - testStoreDir, - testUserCabalConfigFile, - testActualFile, + , testCurrentDir + , testWorkDir + , testPrefixDir + , testLibInstallDir + , testDistDir + , testPackageDbDir + , testRepoDir + , testKeysDir + , testSourceCopyDir + , testCabalDir + , testStoreDir + , testUserCabalConfigFile + , testActualFile + -- * Skipping tests - skip, - skipIO, - skipIf, - skipIfIO, - skipUnless, - skipUnlessIO, + , skip + , skipIO + , skipIf + , skipIfIO + , skipUnless + , skipUnlessIO + -- * Known broken tests - expectBroken, - expectBrokenIf, - expectBrokenUnless, + , expectBroken + , expectBrokenIf + , expectBrokenUnless + -- * Flaky tests - flaky, - flakyIf, + , flaky + , flakyIf + -- * Arguments (TODO: move me) - CommonArgs(..), - renderCommonArgs, - commonArgParser, - -- * Version Constants - cabalVersionLibrary, + , CommonArgs (..) + , renderCommonArgs + , commonArgParser -) where + -- * Version Constants + , 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.Pretty (prettyShow) import Distribution.Simple.Compiler - ( PackageDBStackCWD, PackageDBX(..), compilerFlavor - , Compiler, compilerVersion, showCompilerIdWithAbi ) -import Distribution.System -import Distribution.Simple.Program.Db -import Distribution.Simple.Program + ( Compiler + , PackageDBStackCWD + , PackageDBX (..) + , compilerFlavor + , compilerVersion + , showCompilerIdWithAbi + ) 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 Test.Utils.TempTestDir (removeDirectoryRecursiveHack, withTestDir') import Distribution.Verbosity import Distribution.Version +import Test.Utils.TempTestDir (removeDirectoryRecursiveHack, withTestDir') import Control.Concurrent.Async #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 qualified Data.ByteString.Char8 as C +import Data.List import Data.Maybe -import Control.Applicative +import Data.Monoid (mempty) +import Distribution.Simple.Utils hiding (info) +import GHC.Stack +import Options.Applicative import System.Directory import System.Exit import System.FilePath import System.IO import System.IO.Error (isDoesNotExistError) -import Distribution.Simple.Utils hiding (info) import System.Process hiding (env) -import Options.Applicative import Test.Cabal.Run -import qualified Data.ByteString.Char8 as C -import Data.List -import GHC.Stack -data CommonArgs = CommonArgs { - argCabalInstallPath :: Maybe FilePath, - argGhcPath :: Maybe FilePath, - argHackageRepoToolPath :: Maybe FilePath, - argHaddockPath :: Maybe FilePath, - argKeepTmpFiles :: Bool, - argAccept :: Bool, - argSkipSetupTests :: Bool - } +data CommonArgs = CommonArgs + { argCabalInstallPath :: Maybe FilePath + , argGhcPath :: Maybe FilePath + , argHackageRepoToolPath :: Maybe FilePath + , argHaddockPath :: Maybe FilePath + , argKeepTmpFiles :: Bool + , 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 "keep-tmp-files" - <> help "Keep temporary files" - ) + ( long "keep-tmp-files" + <> help "Keep temporary files" + ) <*> 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 argKeepTmpFiles args then ["--keep-tmp-files"] else []) ++ - (if argSkipSetupTests args then ["--skip-setup-tests"] else []) - -data TestArgs = TestArgs { - testArgDistDir :: FilePath, - testArgPackageDb :: [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 argKeepTmpFiles args then ["--keep-tmp-files"] else []) + ++ (if argSkipSetupTests args then ["--skip-setup-tests"] else []) + +data TestArgs = TestArgs + { testArgDistDir :: FilePath + , testArgPackageDb :: [FilePath] + , testArgScriptPath :: FilePath + , testCommonArgs :: CommonArgs + } testArgParser :: Parser TestArgs -testArgParser = TestArgs - <$> option str - ( help "Build directory of cabal-testsuite" - <> long "builddir" - <> metavar "DIR") - <*> many (option str - ( help "Package DB which contains Cabal and Cabal-syntax" - <> long "extra-package-db" - <> metavar "DIR")) - <*> argument str ( metavar "FILE") +testArgParser = + TestArgs + <$> option + str + ( help "Build directory of cabal-testsuite" + <> long "builddir" + <> metavar "DIR" + ) + <*> many + ( option + str + ( help "Package DB which contains Cabal and Cabal-syntax" + <> long "extra-package-db" + <> metavar "DIR" + ) + ) + <*> argument str (metavar "FILE") <*> commonArgParser -- * skip tests skipIO :: String -> IO () skipIO reason = do - putStrLn $ "SKIP (" <> reason <> ")" - E.throwIO (TestCodeSkip reason) + putStrLn $ "SKIP (" <> reason <> ")" + E.throwIO (TestCodeSkip reason) skip :: String -> TestM () skip = liftIO . skipIO @@ -210,16 +245,16 @@ skipUnless reason b = unless b (skip reason) expectBroken :: IssueID -> TestM a -> TestM a 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 - throwExpectedBroken ticket - Right _ -> do - throwUnexpectedSuccess ticket + 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 + throwExpectedBroken ticket + Right _ -> do + throwUnexpectedSuccess ticket expectBrokenIf :: Bool -> IssueID -> TestM a -> TestM a expectBrokenIf True ticket m = expectBroken ticket m @@ -230,29 +265,29 @@ expectBrokenUnless b = expectBrokenIf (not b) throwExpectedBroken :: IssueID -> IO a throwExpectedBroken ticket = do - putStrLn $ "EXPECTED FAIL (#" <> show ticket <> ")" - E.throwIO (TestCodeKnownFail ticket) + putStrLn $ "EXPECTED FAIL (#" <> show ticket <> ")" + E.throwIO (TestCodeKnownFail ticket) throwUnexpectedSuccess :: IssueID -> IO a throwUnexpectedSuccess ticket = do - putStrLn $ "UNEXPECTED OK (#" <> show ticket <> ")" - E.throwIO (TestCodeUnexpectedOk ticket) + putStrLn $ "UNEXPECTED OK (#" <> show ticket <> ")" + E.throwIO (TestCodeUnexpectedOk ticket) -- * Flaky tests flaky :: IssueID -> TestM a -> TestM a flaky 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 flaky, and it failed, see #" ++ show ticket ++ ":" - print e - throwFlakyFail ticket - Right _ -> do - putStrLn $ "This test is known flaky, but it passed, see #" ++ show ticket ++ ":" - throwFlakyPass ticket + env <- getTestEnv + liftIO . withAsync (runReaderT m env) $ \a -> do + r <- waitCatch a + case r of + Left e -> do + putStrLn $ "This test is known flaky, and it failed, see #" ++ show ticket ++ ":" + print e + throwFlakyFail ticket + Right _ -> do + putStrLn $ "This test is known flaky, but it passed, see #" ++ show ticket ++ ":" + throwFlakyPass ticket flakyIf :: Bool -> IssueID -> TestM a -> TestM a flakyIf True ticket m = flaky ticket m @@ -260,40 +295,41 @@ flakyIf False _ m = m throwFlakyFail :: IssueID -> IO a throwFlakyFail ticket = do - putStrLn $ "FLAKY FAIL (#" <> show ticket <> ")" - E.throwIO (TestCodeFlakyFailed ticket) + putStrLn $ "FLAKY FAIL (#" <> show ticket <> ")" + E.throwIO (TestCodeFlakyFailed ticket) throwFlakyPass :: IssueID -> IO a throwFlakyPass ticket = do - putStrLn $ "FLAKY OK (#" <> show ticket <> ")" - E.throwIO (TestCodeFlakyPassed ticket) + putStrLn $ "FLAKY OK (#" <> show ticket <> ")" + E.throwIO (TestCodeFlakyPassed ticket) 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 @@ -304,10 +340,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 @@ -319,197 +356,209 @@ python3Program = simpleProgram "python3" -- | Run a test in the test monad according to program's arguments. runTestM :: String -> TestM () -> IO () runTestM mode m = - execParser (info testArgParser Data.Monoid.mempty) >>= \args -> - withTestDir' verbosity (defaultTempFileOptions { optKeepTempFiles = argKeepTmpFiles (testCommonArgs args) }) - "cabal-testsuite" $ \tmp_dir -> do - let dist_dir = testArgDistDir args - (script_dir0, script_filename) = splitFileName (testArgScriptPath args) - - stripped = stripExtension ".test.hs" script_filename - <|> stripExtension ".multitest.hs" script_filename - script_base = fromMaybe (dropExtensions script_filename) stripped - - -- Canonicalize this so that it is stable across working directory changes - script_dir <- canonicalizePath script_dir0 - senv <- mkScriptEnv verbosity - -- Add test suite specific programs - let program_db0 = - addKnownPrograms + execParser (info testArgParser Data.Monoid.mempty) >>= \args -> + withTestDir' + verbosity + (defaultTempFileOptions{optKeepTempFiles = argKeepTmpFiles (testCommonArgs args)}) + "cabal-testsuite" + $ \tmp_dir -> do + let dist_dir = testArgDistDir args + (script_dir0, script_filename) = splitFileName (testArgScriptPath args) + + stripped = + stripExtension ".test.hs" script_filename + <|> stripExtension ".multitest.hs" script_filename + script_base = fromMaybe (dropExtensions script_filename) stripped + + -- Canonicalize this so that it is stable across working directory changes + script_dir <- canonicalizePath script_dir0 + 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 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 + -- 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 + 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 - - (configuredGhcProg, _) <- requireProgram verbosity ghcProgram program_db2 - - program_db3 <- - reconfigurePrograms verbosity - ([("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] ++ - [("hackage-repo-tool", p) - | p <- maybeToList (argHackageRepoToolPath cargs)] ++ - [("haddock", p) | p <- maybeToList (argHaddockPath cargs)]) + (Just (compilerFlavor (runnerCompiler senv))) + (Just ghc_path) + Nothing + program_db1 + verbosity + + (configuredGhcProg, _) <- requireProgram verbosity ghcProgram program_db2 + + 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 db_stack = [GlobalPackageDB] - env = TestEnv { - testSourceDir = script_dir, - testTmpDir = tmp_dir, - testSubName = script_base, - testMode = mode, - testProgramDb = program_db, - testPlatform = platform, - testCompiler = comp, - testCompilerPath = programPath configuredGhcProg, - testPackageDBStack = db_stack, - testVerbosity = verbosity, - testMtimeChangeDelay = Nothing, - testScriptEnv = senv, - testSetupPath = dist_dir "build" "setup" "setup", - testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs, - testSkipSetupTests = argSkipSetupTests (testCommonArgs args), - testHaveCabalShared = runnerWithSharedLib senv, - testEnvironment = - -- Use UTF-8 output on all platforms. - [ ("LC_ALL", Just "en_US.UTF-8") - -- 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 (testUserCabalConfigFile env)) - -- Set `TMPDIR` so that temporary files aren't created in the global `TMPDIR`. - , ("TMPDIR", Just tmp_dir) - -- Windows uses `TMP` for the `TMPDIR`. - , ("TMP", Just tmp_dir) - ], - testShouldFail = False, - testRelativeCurrentDir = ".", - testHavePackageDb = False, - testHaveRepo = False, - testCabalInstallAsSetup = False, - testCabalProjectFile = Nothing, - testPlan = Nothing, - testRecordDefaultMode = DoNotRecord, - testRecordUserMode = Nothing, - testMaybeStoreDir = Nothing + -- configCompilerEx only marks some programs as known, so to pick + -- them up we must configure them + program_db <- configureAllKnownPrograms verbosity program_db3 + + let db_stack = [GlobalPackageDB] + env = + TestEnv + { testSourceDir = script_dir + , testTmpDir = tmp_dir + , testSubName = script_base + , testMode = mode + , testProgramDb = program_db + , testPlatform = platform + , testCompiler = comp + , testCompilerPath = programPath configuredGhcProg + , testPackageDBStack = db_stack + , testVerbosity = verbosity + , testMtimeChangeDelay = Nothing + , testScriptEnv = senv + , testSetupPath = dist_dir "build" "setup" "setup" + , testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs + , testSkipSetupTests = argSkipSetupTests (testCommonArgs args) + , testHaveCabalShared = runnerWithSharedLib senv + , testEnvironment = + -- Use UTF-8 output on all platforms. + [ ("LC_ALL", Just "en_US.UTF-8") + , -- 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 (testUserCabalConfigFile env)) + , -- Set `TMPDIR` so that temporary files aren't created in the global `TMPDIR`. + ("TMPDIR", Just tmp_dir) + , -- Windows uses `TMP` for the `TMPDIR`. + ("TMP", Just tmp_dir) + ] + , testShouldFail = False + , testRelativeCurrentDir = "." + , testHavePackageDb = False + , testHaveRepo = False + , testCabalInstallAsSetup = False + , testCabalProjectFile = Nothing + , testPlan = Nothing + , testRecordDefaultMode = DoNotRecord + , testRecordUserMode = Nothing + , testMaybeStoreDir = Nothing } - runReaderT cleanup env - join $ E.catch (runReaderT - (do + runReaderT cleanup env + join $ + E.catch + ( runReaderT + ( do withSourceCopy m check_expect (argAccept (testCommonArgs args)) Nothing ) env - ) - (\(e :: TestCode) -> do - -- A test that resulted in unexpected success should check its output - -- because maybe it is the output the one that makes it fail! - case isTestCodeUnexpectedSuccess e of - Just t -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, False))) env - Nothing -> + ) + ( \(e :: TestCode) -> do + -- A test that resulted in unexpected success should check its output + -- because maybe it is the output the one that makes it fail! + case isTestCodeUnexpectedSuccess e of + Just t -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, False))) env + Nothing -> -- A test that is reported flaky but passed might fail because of the output case isTestCodeFlaky e of - Flaky True t -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, True))) env - _ -> E.throwIO e - ) - + Flaky True t -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, True))) env + _ -> E.throwIO e + ) where verbosity = normal -- TODO: configurable - cleanup = do - env <- getTestEnv - onlyIfExists . removeDirectoryRecursiveHack verbosity $ 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 . removeDirectoryRecursiveHack verbosity $ 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 was_expected_to_fail = do - env <- getTestEnv - actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) - expect <- liftIO $ readFileOrEmpty (testExpectFile env) - norm_env <- mkNormalizerEnv - let actual = normalizeOutput norm_env actual_raw - case (was_expected_to_fail, words actual /= words expect) of - -- normal test, output doesn't match - (Nothing, True) -> 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 $ "Writing actual test output to " <> testExpectAcceptFile env - liftIO $ writeFileNoCR (testExpectAcceptFile env) actual - pure (pure ()) - else pure (E.throwIO TestCodeFail) - -- normal test, output matches - (Nothing, False) -> pure (pure ()) - -- expected fail, output matches - (Just (t, was_flaky), False) -> pure (E.throwIO $ if was_flaky then TestCodeFlakyPassed t else TestCodeUnexpectedOk t) - -- expected fail, output doesn't match - (Just (t, was_flaky), True) -> 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 - pure (E.throwIO $ if was_flaky then TestCodeFlakyFailed t else TestCodeKnownFail t) + env <- getTestEnv + actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) + expect <- liftIO $ readFileOrEmpty (testExpectFile env) + norm_env <- mkNormalizerEnv + let actual = normalizeOutput norm_env actual_raw + case (was_expected_to_fail, words actual /= words expect) of + -- normal test, output doesn't match + (Nothing, True) -> 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 $ "Writing actual test output to " <> testExpectAcceptFile env + liftIO $ writeFileNoCR (testExpectAcceptFile env) actual + pure (pure ()) + else pure (E.throwIO TestCodeFail) + -- normal test, output matches + (Nothing, False) -> pure (pure ()) + -- expected fail, output matches + (Just (t, was_flaky), False) -> pure (E.throwIO $ if was_flaky then TestCodeFlakyPassed t else TestCodeUnexpectedOk t) + -- expected fail, output doesn't match + (Just (t, was_flaky), True) -> 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 + pure (E.throwIO $ if was_flaky then TestCodeFlakyFailed t else TestCodeKnownFail t) 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 -- | 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 -- | Make a hermetic copy of the test directory. -- @@ -518,299 +567,329 @@ onlyIfExists m = -- hermetic copy. withSourceCopy :: TestM a -> TestM a withSourceCopy m = do - env <- getTestEnv - initWorkDir - let curdir = testSourceDir env - dest = testSourceCopyDir env - fs <- getSourceFiles - when (null fs) - (error (unlines [ "withSourceCopy: No files to copy from " ++ curdir - , "You need to \"git add\" any files before they are copied by the testsuite."])) - forM_ fs $ \f -> do - unless (isTestFile f) $ liftIO $ do - putStrLn ("Copying " ++ (curdir f) ++ " to " ++ (dest f)) - createDirectoryIfMissing True (takeDirectory (dest f)) - d <- liftIO $ doesDirectoryExist (curdir f) - if d - then - copyDirectoryRecursive normal (curdir f) (dest f) - else - copyFile (curdir f) (dest f) - m - + env <- getTestEnv + initWorkDir + let curdir = testSourceDir env + dest = testSourceCopyDir env + fs <- getSourceFiles + when + (null fs) + ( error + ( unlines + [ "withSourceCopy: No files to copy from " ++ curdir + , "You need to \"git add\" any files before they are copied by the testsuite." + ] + ) + ) + forM_ fs $ \f -> do + unless (isTestFile f) $ liftIO $ do + putStrLn ("Copying " ++ (curdir f) ++ " to " ++ (dest f)) + createDirectoryIfMissing True (takeDirectory (dest f)) + d <- liftIO $ doesDirectoryExist (curdir f) + if d + then copyDirectoryRecursive normal (curdir f) (dest f) + else copyFile (curdir f) (dest f) + m -- 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 initWorkDir :: TestM () initWorkDir = do - env <- getTestEnv - liftIO $ createDirectoryIfMissing True (testWorkDir env) - - + env <- getTestEnv + liftIO $ createDirectoryIfMissing True (testWorkDir env) getSourceFiles :: TestM [FilePath] getSourceFiles = do - env <- getTestEnv - configured_prog <- requireProgramM gitProgram - r <- liftIO $ run (testVerbosity env) - (Just $ testSourceDir env) - (testEnvironment env) - (programPath configured_prog) - ["ls-files", "--cached", "--modified"] - Nothing - recordLog r - _ <- requireSuccess r - return (lines $ resultOutput r) + env <- getTestEnv + configured_prog <- requireProgramM gitProgram + r <- + liftIO $ + run + (testVerbosity env) + (Just $ testSourceDir env) + (testEnvironment env) + (programPath configured_prog) + ["ls-files", "--cached", "--modified"] + Nothing + recordLog r + _ <- requireSuccess r + return (lines $ resultOutput r) 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 -> "" ------------------------------------------------------------------------ + -- * 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 assertFailure :: String -> m () assertFailure msg = withFrozenCallStack $ error msg - - -- | 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 - - canonicalizedTestTmpDir <- liftIO $ canonicalizePath (testTmpDir env) - canonicalizedGblDir <- liftIO $ canonicalizePath tmpDir - - -- 'cabal' is configured in the package-db, but doesn't specify how to find the program version - -- Thus we find the program location, if it exists, and query for the program version for - -- output normalisation. - cabalVersionM <- do - cabalProgM <- needProgramM "cabal" - case cabalProgM of - Nothing -> pure Nothing - Just cabalProg -> do - liftIO (findProgramVersion "--numeric-version" id (testVerbosity env) (programPath cabalProg)) - - return NormalizerEnv { - normalizerTmpDir - = (if buildOS == Windows + 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 + + canonicalizedTestTmpDir <- liftIO $ canonicalizePath (testTmpDir env) + canonicalizedGblDir <- liftIO $ canonicalizePath tmpDir + + -- 'cabal' is configured in the package-db, but doesn't specify how to find the program version + -- Thus we find the program location, if it exists, and query for the program version for + -- output normalisation. + cabalVersionM <- do + cabalProgM <- needProgramM "cabal" + case cabalProgM of + Nothing -> pure Nothing + Just cabalProg -> do + liftIO (findProgramVersion "--numeric-version" id (testVerbosity env) (programPath cabalProg)) + + return + NormalizerEnv + { normalizerTmpDir = + ( if buildOS == Windows then joinDrive "\\" . dropDrive - else id) - $ addTrailingPathSeparator (testTmpDir env), - normalizerCanonicalTmpDir - = (if buildOS == Windows + else id + ) + $ addTrailingPathSeparator (testTmpDir env) + , normalizerCanonicalTmpDir = + ( if buildOS == Windows then joinDrive "\\" . dropDrive - else id) - $ addTrailingPathSeparator canonicalizedTestTmpDir, - normalizerGblTmpDir - = (if buildOS == Windows + else id + ) + $ addTrailingPathSeparator canonicalizedTestTmpDir + , normalizerGblTmpDir = + ( if buildOS == Windows then joinDrive "\\" . dropDrive - else id) - $ addTrailingPathSeparator tmpDir, - normalizerCanonicalGblTmpDir - = (if buildOS == Windows + else id + ) + $ addTrailingPathSeparator tmpDir + , normalizerCanonicalGblTmpDir = + ( if buildOS == Windows then joinDrive "\\" . dropDrive - else id) - $ addTrailingPathSeparator canonicalizedGblDir, - normalizerGhcVersion - = compilerVersion (testCompiler env), - normalizerGhcPath - = testCompilerPath env, - normalizerKnownPackages - = mapMaybe simpleParse (words list_out), - normalizerPlatform - = testPlatform env, - normalizerCabalVersion - = cabalVersionLibrary, - normalizerCabalInstallVersion - = cabalVersionM - } + else id + ) + $ addTrailingPathSeparator canonicalizedGblDir + , normalizerGhcVersion = + compilerVersion (testCompiler env) + , normalizerGhcPath = + testCompilerPath env + , normalizerKnownPackages = + mapMaybe simpleParse (words list_out) + , normalizerPlatform = + testPlatform env + , normalizerCabalVersion = + cabalVersionLibrary + , normalizerCabalInstallVersion = + cabalVersionM + } 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 needProgramM :: String -> TestM (Maybe ConfiguredProgram) needProgramM program = do - env <- getTestEnv - return $ lookupProgramByName program (testProgramDb env) + env <- getTestEnv + return $ lookupProgramByName program (testProgramDb env) 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 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 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 - , testCompilerPath :: FilePath - -- | Platform we are running tests on - , testPlatform :: Platform - -- | Package database stack (actually this changes lol) - , testPackageDBStack :: PackageDBStackCWD - -- | 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 - -- | Setup package-db path which contains Cabal and Cabal-syntax for cabal-install to - -- use when compiling custom setups, plus the store with possible dependencies of those setup packages. - , testPackageDbPath :: Maybe [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're testing cabal-install as setup - , testCabalInstallAsSetup :: Bool - -- | Says what cabal.project file to use (probed) - , testCabalProjectFile :: Maybe 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 - -- | Path to the storedir used by the test, if not the default - , testMaybeStoreDir :: Maybe 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 + , testCompilerPath :: FilePath + , testPlatform :: Platform + -- ^ Platform we are running tests on + , testPackageDBStack :: PackageDBStackCWD + -- ^ 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 + , testPackageDbPath :: Maybe [FilePath] + -- ^ Setup package-db path which contains Cabal and Cabal-syntax for cabal-install to + -- use when compiling custom setups, plus the store with possible dependencies of those setup packages. + , 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 + , testCabalInstallAsSetup :: Bool + -- ^ Says if we're testing cabal-install as setup + , testCabalProjectFile :: Maybe 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. + , testMaybeStoreDir :: Maybe FilePath + -- ^ Path to the storedir used by the test, if not the default + } + 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 @@ -875,8 +954,8 @@ testCabalDir env = testHomeDir env ".cabal" testStoreDir :: TestEnv -> FilePath testStoreDir env = case testMaybeStoreDir env of - Just dir -> dir - Nothing -> testCabalDir env "store" + Just dir -> dir + Nothing -> testCabalDir env "store" -- | The user cabal config file testUserCabalConfigFile :: TestEnv -> FilePath diff --git a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs index fb2840be9e6..f9f5e96d8cf 100644 --- a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs +++ b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs @@ -1,115 +1,134 @@ -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 = - -- Normalize backslashes to forward slashes to normalize - -- file paths - map (\c -> if c == '\\' then '/' else c) + -- Normalize backslashes to forward slashes to normalize + -- file paths + 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 - . (if buildOS == Windows - then resub "\\\\(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}\\\\" - "\\\\-\\\\" - else id) - . resub "/(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}/" - "/-/" + . ( if buildOS == Windows + then + resub + "\\\\(([A-Za-z0-9_]+)(-[A-Za-z0-9\\._]+)*)-[0-9a-f]{4,64}\\\\" + "\\\\-\\\\" + else id + ) + . 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\\.-]+") "" - . resub (posixRegexEscape (normalizerCanonicalGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" + . resub (posixRegexEscape (normalizerGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" + . resub (posixRegexEscape (normalizerCanonicalGblTmpDir nenv) ++ "[a-z0-9\\.-]+") "" -- Munge away .exe suffix on filenames (Windows) - . (if buildOS == Windows then resub "([A-Za-z0-9.-]+)\\.exe" "\\1" else id) + . (if buildOS == Windows then resub "([A-Za-z0-9.-]+)\\.exe" "\\1" else id) -- tmp/src-[0-9]+ is tmp\src-[0-9]+ in Windows - . (if buildOS == Windows then resub (posixRegexEscape "tmp\\src-" ++ "[0-9]+") "" else id) - . resub (posixRegexEscape "tmp/src-" ++ "[0-9]+") "" - . resub (posixRegexEscape (normalizerTmpDir nenv) ++ sameDir) "/" - . resub (posixRegexEscape (normalizerCanonicalTmpDir nenv) ++ sameDir) "/" - -- Munge away C: prefix on filenames (Windows). We convert C:\\ to \\. - . (if buildOS == Windows then resub "([A-Z]):\\\\" "\\\\" else id) - . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv))) + . (if buildOS == Windows then resub (posixRegexEscape "tmp\\src-" ++ "[0-9]+") "" else id) + . resub (posixRegexEscape "tmp/src-" ++ "[0-9]+") "" + . resub (posixRegexEscape (normalizerTmpDir nenv) ++ sameDir) "/" + . resub (posixRegexEscape (normalizerCanonicalTmpDir nenv) ++ sameDir) "/" + -- Munge away C: prefix on filenames (Windows). We convert C:\\ to \\. + . (if buildOS == Windows then resub "([A-Z]):\\\\" "\\\\" else id) + . 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 - . (if buildOS == Windows then resub "\\\\incoming\\\\new-[0-9]+" - "\\\\incoming\\\\new-" - else id) + . ( if buildOS == Windows + then + resub + "\\\\incoming\\\\new-[0-9]+" + "\\\\incoming\\\\new-" + else id + ) -- 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))) "" + . resub (posixRegexEscape (display (normalizerPlatform nenv))) "" -- 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]+)?" - -- Also glob the ABI hash, for GHCs which support it - ++ "(-[a-z0-9]+)?") - "" - else id) - . normalizeBuildInfoJson - . maybe id normalizePathCmdOutput (normalizerCabalInstallVersion nenv) - -- hackage-security locks occur non-deterministically - . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" "" - . resub "installed: [0-9]+(\\.[0-9]+)*" "installed: " + . ( if normalizerGhcVersion nenv /= nullVersion + then + resub + ( posixRegexEscape (display (normalizerGhcVersion nenv)) + -- Also glob the date, for nightly GHC builds + ++ "(\\.[0-9]+)?" + -- Also glob the ABI hash, for GHCs which support it + ++ "(-[a-z0-9]+)?" + ) + "" + else id + ) + . normalizeBuildInfoJson + . maybe id normalizePathCmdOutput (normalizerCabalInstallVersion nenv) + -- hackage-security locks occur non-deterministically + . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" "" + . resub "installed: [0-9]+(\\.[0-9]+)*" "installed: " where sameDir = "(\\.((\\\\)+|\\/))*" packageIdRegex pid = - resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") - (prettyShow (packageName pid) ++ "-") + resub + (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") + (prettyShow (packageName pid) ++ "-") normalizePathCmdOutput cabalInstallVersion = -- clear the ghc path out of all supported output formats - resub ("compiler-path: " <> posixRegexEscape (normalizerGhcPath nenv)) - "compiler-path: " - -- ghc compiler path is already covered by 'normalizeBuildInfoJson' - . resub ("{\"cabal-version\":\"" ++ posixRegexEscape (display cabalInstallVersion) ++ "\"") + resub + ("compiler-path: " <> posixRegexEscape (normalizerGhcPath nenv)) + "compiler-path: " + -- ghc compiler path is already covered by 'normalizeBuildInfoJson' + . resub + ("{\"cabal-version\":\"" ++ posixRegexEscape (display cabalInstallVersion) ++ "\"") "{\"cabal-version\":\"\"" - -- Replace windows filepaths that contain `\\` in the json output. - -- since we need to escape each '\' ourselves, these 8 backslashes match on exactly 2 backslashes - -- in the test output. - -- As the json output is escaped, we need to re-escape the path. - . resub "\\\\\\\\" "\\" + -- Replace windows filepaths that contain `\\` in the json output. + -- since we need to escape each '\' ourselves, these 8 backslashes match on exactly 2 backslashes + -- in the test output. + -- As the json output is escaped, we need to re-escape the path. + . resub "\\\\\\\\" "\\" -- '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\":\"" <> posixRegexEscape (normalizerGhcPath nenv) <> "\"") - "\"path\":\"\"" + -- Remove ghc path from show-build-info output + resub + ("\"path\":\"" <> posixRegexEscape (normalizerGhcPath nenv) <> "\"") + "\"path\":\"\"" -- Remove cabal version output from show-build-info output - . resub ("{\"cabal-lib-version\":\"" ++ posixRegexEscape (display (normalizerCabalVersion nenv)) ++ "\"") - "{\"cabal-lib-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: @@ -121,32 +140,33 @@ 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 - { normalizerTmpDir :: FilePath - , normalizerCanonicalTmpDir :: FilePath - -- ^ May differ from 'normalizerTmpDir', especially e.g. on macos, where - -- `/var` is a symlink for `/private/var`. - , normalizerGblTmpDir :: FilePath - -- ^ The global temp directory: @/tmp@ on Linux, @/var/folders/...@ on macos - -- and @\\msys64\\tmp@ on Windows. - -- - -- Note that on windows the actual path would be @C:\\msys64\\tmp@ but we - -- drop the @C:@ prefix because this path appears sometimes - -- twice in the same path in some tests, and the second time it doesn't have a @C:@, so - -- the logic fails to catch it. - , normalizerCanonicalGblTmpDir :: FilePath - -- ^ The canonical version of 'normalizerGblTmpDir', might differ in the same - -- way as above on macos - , normalizerGhcVersion :: Version - , normalizerGhcPath :: FilePath - , normalizerKnownPackages :: [PackageId] - , normalizerPlatform :: Platform - , normalizerCabalVersion :: Version - , normalizerCabalInstallVersion :: Maybe Version - } + { normalizerTmpDir :: FilePath + , normalizerCanonicalTmpDir :: FilePath + -- ^ May differ from 'normalizerTmpDir', especially e.g. on macos, where + -- `/var` is a symlink for `/private/var`. + , normalizerGblTmpDir :: FilePath + -- ^ The global temp directory: @/tmp@ on Linux, @/var/folders/...@ on macos + -- and @\\msys64\\tmp@ on Windows. + -- + -- Note that on windows the actual path would be @C:\\msys64\\tmp@ but we + -- drop the @C:@ prefix because this path appears sometimes + -- twice in the same path in some tests, and the second time it doesn't have a @C:@, so + -- the logic fails to catch it. + , normalizerCanonicalGblTmpDir :: FilePath + -- ^ The canonical version of 'normalizerGblTmpDir', might differ in the same + -- way as above on macos + , normalizerGhcVersion :: Version + , normalizerGhcPath :: FilePath + , normalizerKnownPackages :: [PackageId] + , normalizerPlatform :: Platform + , normalizerCabalVersion :: Version + , normalizerCabalInstallVersion :: Maybe Version + } posixSpecialChars :: [Char] posixSpecialChars = ".^$*+?()[{\\|" @@ -160,35 +180,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 d8cee954d83..b496ef0c9fb 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -1,86 +1,92 @@ -{-# 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 Distribution.Utils.Path, - 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 Distribution.Utils.Path + , 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 Test.Cabal.TestCode import Distribution.Compat.Time (calibrateMtimeChangeDelay) -import Distribution.Simple.Compiler (PackageDBStackCWD, PackageDBCWD, PackageDBX(..)) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec (eitherParsec, simpleParsec) +import Distribution.Simple.Compiler (PackageDBCWD, PackageDBStackCWD, PackageDBX (..)) +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.Configure - ( getPersistBuildConfig ) +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Types import Distribution.Simple.Utils - ( withFileContents, tryFindPackageDesc ) -import Distribution.Version -import Distribution.Package -import Distribution.Parsec (eitherParsec, simpleParsec) -import Distribution.Types.UnqualComponentName + ( tryFindPackageDesc + , withFileContents + ) +import Distribution.System (Arch (JavaScript), OS (Linux, OSX, Windows), buildArch, buildOS) import Distribution.Types.LocalBuildInfo -import Distribution.PackageDescription -import Test.Utils.TempTestDir (withTestDir) -import Distribution.Verbosity (normal) +import Distribution.Types.UnqualComponentName import Distribution.Utils.Path - ( makeSymbolicPath, relativeSymbolicPath, interpretSymbolicPathCWD ) + ( interpretSymbolicPathCWD + , makeSymbolicPath + , relativeSymbolicPath + ) +import Distribution.Verbosity (normal) +import Distribution.Version +import Test.Utils.TempTestDir (withTestDir) import Distribution.Compat.Stack import Text.Regex.TDFA ((=~)) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (withAsync) -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as BSL -import Control.Monad (unless, when, void, forM_, foldM, liftM2, liftM4) -import Control.Monad.Catch ( bracket_ ) -import Control.Monad.Trans.Reader (asks, withReaderT, runReaderT) +import Control.Monad (foldM, forM_, liftM2, liftM4, unless, void, when) +import Control.Monad.Catch (bracket_) import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Reader (asks, runReaderT, withReaderT) +import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Aeson as JSON import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as C -import Data.List (isInfixOf, stripPrefix, isPrefixOf, intercalate) -import Data.Maybe (isJust, mapMaybe, fromMaybe) -import System.Exit (ExitCode (..)) -import System.FilePath -import Control.Concurrent (threadDelay) +import qualified Data.ByteString.Lazy as BSL import qualified Data.Char as Char -import System.Directory -import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) +import Data.List (intercalate, isInfixOf, isPrefixOf, stripPrefix) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Network.Wait (waitTcpVerbose) +import System.Directory import System.Environment -import qualified System.FilePath.Glob as Glob (globDir1, compile) -import System.Process +import System.Exit (ExitCode (..)) +import System.FilePath +import qualified System.FilePath.Glob as Glob (compile, globDir1) import System.IO +import System.Process #ifndef mingw32_HOST_OS import System.Posix.Resource #endif ------------------------------------------------------------------------ --- * Utilities +-- * Utilities runM :: FilePath -> [String] -> Maybe String -> TestM Result runM path args input = do @@ -89,48 +95,53 @@ runM path args input = do runM' :: Maybe FilePath -> FilePath -> [String] -> Maybe String -> TestM Result runM' run_dir path args input = do - env <- getTestEnv - r <- liftIO $ run (testVerbosity env) - run_dir - (testEnvironment env) - path - args - input - recordLog r - requireSuccess r - -runProgramM :: Program -> [String] -> Maybe String -> TestM Result + env <- getTestEnv + r <- + liftIO $ + run + (testVerbosity env) + run_dir + (testEnvironment env) + path + args + input + recordLog r + requireSuccess r + +runProgramM :: Program -> [String] -> Maybe String -> TestM Result runProgramM prog args input = do env <- getTestEnv runProgramM' (Just $ testCurrentDir env) prog args input runProgramM' :: Maybe FilePath -> Program -> [String] -> Maybe String -> TestM Result runProgramM' run_dir prog args input = do - configured_prog <- requireProgramM prog - -- TODO: Consider also using other information from - -- ConfiguredProgram, e.g., env and args - runM' run_dir (programPath configured_prog) args input + configured_prog <- requireProgramM prog + -- TODO: Consider also using other information from + -- ConfiguredProgram, e.g., env and args + runM' run_dir (programPath configured_prog) args input getLocalBuildInfoM :: TestM LocalBuildInfo getLocalBuildInfoM = do - env <- getTestEnv - liftIO $ getPersistBuildConfig Nothing (makeSymbolicPath $ testDistDir env) + env <- getTestEnv + liftIO $ getPersistBuildConfig Nothing (makeSymbolicPath $ 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}) withStoreDir :: FilePath -> TestM a -> TestM a withStoreDir fp = - withReaderT (\env -> env { testMaybeStoreDir = Just fp }) + withReaderT (\env -> env{testMaybeStoreDir = Just fp}) -- 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}) -- | Prepend a directory to the PATH addToPath :: FilePath -> TestM a -> TestM a @@ -141,12 +152,12 @@ addToPath exe_dir action = do let new_env = (("PATH", Just newpath) : (testEnvironment env)) withEnv new_env action - -- 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 @@ -167,41 +178,44 @@ setup'' -- ^ Arguments -> TestM Result setup'' prefix cmd args = do - env <- getTestEnv - let work_dir = if testRelativeCurrentDir env == "." then Nothing else Just (testRelativeCurrentDir env) - 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) - work_dir_arg = case work_dir of - Nothing -> [] - Just wd -> ["--working-dir", wd] - full_args = work_dir_arg ++ (cmd : [marked_verbose, "--distdir", rel_dist_dir] ++ args') - defaultRecordMode RecordMarked $ do + env <- getTestEnv + let work_dir = if testRelativeCurrentDir env == "." then Nothing else Just (testRelativeCurrentDir env) + 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) + work_dir_arg = case work_dir of + Nothing -> [] + Just wd -> ["--working-dir", wd] + full_args = work_dir_arg ++ (cmd : [marked_verbose, "--distdir", rel_dist_dir] ++ args') + defaultRecordMode RecordMarked $ do recordHeader ["Setup", cmd] -- We test `cabal act-as-setup` when running cabal-tests. @@ -212,84 +226,90 @@ setup'' prefix cmd args = do pdfile <- liftIO $ tryFindPackageDesc (testVerbosity env) (Just pkgDir) pdesc <- liftIO $ readGenericPackageDescription (testVerbosity env) (Just pkgDir) $ relativeSymbolicPath pdfile if testCabalInstallAsSetup env - then if buildType (packageDescription pdesc) == Simple - then runProgramM' (Just (testTmpDir env)) cabalProgram ("act-as-setup" : "--" : full_args) Nothing - else fail "Using act-as-setup for not 'build-type: Simple' package" - else do + then if buildType (packageDescription pdesc) == Simple - then runM' (Just $ testTmpDir env) (testSetupPath env) (full_args) Nothing - -- Run the Custom script! - else do - r <- liftIO $ runghc (testScriptEnv env) - (Just $ testTmpDir env) - (testEnvironment env) - (testRelativeCurrentDir env prefix "Setup.hs") - (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 runProgramM' (Just (testTmpDir env)) cabalProgram ("act-as-setup" : "--" : full_args) Nothing + else fail "Using act-as-setup for not 'build-type: Simple' package" + else do + if buildType (packageDescription pdesc) == Simple + then runM' (Just $ testTmpDir env) (testSetupPath env) (full_args) Nothing + else -- Run the Custom script! + do + r <- + liftIO $ + runghc + (testScriptEnv env) + (Just $ testTmpDir env) + (testEnvironment env) + (testRelativeCurrentDir env prefix "Setup.hs") + (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 :: PackageDBStackCWD -> [String] -packageDBParams dbs = "--package-db=clear" - : map (("--package-db=" ++) . convert) dbs +packageDBParams dbs = + "--package-db=clear" + : map (("--package-db=" ++) . convert) dbs where convert :: PackageDBCWD -> String - convert GlobalPackageDB = "global" - convert UserPackageDB = "user" + convert GlobalPackageDB = "global" + convert UserPackageDB = "user" convert (SpecificPackageDB path) = path ------------------------------------------------------------------------ + -- * Running cabal -- cabal cmd args @@ -311,57 +331,58 @@ 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 - let extra_args - | cmd `elem` - [ "v1-update" - , "outdated" - , "user-config" - , "man" - , "v1-freeze" - , "check" - , "gen-bounds" - , "get", "unpack" - , "info" - , "init" - , "haddock-project" - ] - = [ ] - - -- new-build commands are affected by testCabalProjectFile - | cmd `elem` ["v2-sdist", "path"] - = [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ] - - | cmd == "v2-clean" || cmd == "clean" - = [ "--builddir", testDistDir env ] - ++ [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ] - - | "v2-" `isPrefixOf` cmd - = [ "--builddir", testDistDir env - , "-j1" ] - ++ [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ] - ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs] - | "v1-" `isPrefixOf` cmd - = [ "--builddir", testDistDir env ] - ++ install_args - | otherwise - = [ "--builddir", testDistDir env ] - ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs] - ++ install_args - - install_args - | cmd == "v1-install" || cmd == "v1-build" = [ "-j1" ] - | otherwise = [] - - global_args' = - [ "--store-dir=" ++ storeDir | Just storeDir <- [testMaybeStoreDir env] ] - ++ global_args - - cabal_args = global_args' - ++ [ cmd, marked_verbose ] - ++ extra_args - ++ args - defaultRecordMode RecordMarked $ do + env <- getTestEnv + let extra_args + | cmd + `elem` [ "v1-update" + , "outdated" + , "user-config" + , "man" + , "v1-freeze" + , "check" + , "gen-bounds" + , "get" + , "unpack" + , "info" + , "init" + , "haddock-project" + ] = + [] + -- new-build commands are affected by testCabalProjectFile + | cmd `elem` ["v2-sdist", "path"] = + ["--project-file=" ++ fp | Just fp <- [testCabalProjectFile env]] + | cmd == "v2-clean" || cmd == "clean" = + ["--builddir", testDistDir env] + ++ ["--project-file=" ++ fp | Just fp <- [testCabalProjectFile env]] + | "v2-" `isPrefixOf` cmd = + [ "--builddir" + , testDistDir env + , "-j1" + ] + ++ ["--project-file=" ++ fp | Just fp <- [testCabalProjectFile env]] + ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs] + | "v1-" `isPrefixOf` cmd = + ["--builddir", testDistDir env] + ++ install_args + | otherwise = + ["--builddir", testDistDir env] + ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs] + ++ install_args + + install_args + | cmd == "v1-install" || cmd == "v1-build" = ["-j1"] + | otherwise = [] + + global_args' = + ["--store-dir=" ++ storeDir | Just storeDir <- [testMaybeStoreDir env]] + ++ global_args + + cabal_args = + global_args' + ++ [cmd, marked_verbose] + ++ extra_args + ++ args + defaultRecordMode RecordMarked $ do recordHeader ["cabal", cmd] cabal_raw' cabal_args input @@ -370,104 +391,124 @@ cabal_raw' cabal_args input = runProgramM cabalProgram cabal_args input withProjectFile :: FilePath -> TestM a -> TestM a withProjectFile fp m = - withReaderT (\env -> env { testCabalProjectFile = Just fp }) m + withReaderT (\env -> env{testCabalProjectFile = Just 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 - exePath <- planExePath pkg_name cname - defaultRecordMode RecordAll $ do + exePath <- planExePath pkg_name cname + defaultRecordMode RecordAll $ do recordHeader [pkg_name, cname] runM exePath args Nothing -planExePath :: String {- package name -} -> String {- component name -} - -> TestM FilePath +planExePath + :: String {- package name -} + -> String {- component name -} + -> TestM FilePath planExePath pkg_name cname = 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 - return exePath + 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 + return exePath ------------------------------------------------------------------------ + -- * 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 -- | Don't pass `--package-db` to cabal-install, so it won't find the specific version of -- `Cabal` which you have configured the testsuite to run with. You probably don't want to use -- this unless you are testing the `--package-db` flag itself. noCabalPackageDb :: TestM a -> TestM a -noCabalPackageDb m = withReaderT (\nenv -> nenv { testPackageDbPath = Nothing }) m +noCabalPackageDb m = withReaderT (\nenv -> nenv{testPackageDbPath = Nothing}) 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 -> PackageDBStackCWD -> [String] -ghcPkgPackageDBParams version dbs = concatMap convert dbs where +ghcPkgPackageDBParams version dbs = concatMap convert dbs + where convert :: PackageDBCWD -> [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@ @@ -477,8 +518,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 @@ -492,8 +533,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 @@ -502,6 +543,7 @@ shell :: String -> [String] -> TestM Result shell exe args = runM exe args Nothing ------------------------------------------------------------------------ + -- * Repository manipulation -- Workflows we support: @@ -539,28 +581,29 @@ 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] - ++ ["-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] + ++ ["-C", src_parent, src_dir] infixr 4 `archiveTo` @@ -569,138 +612,151 @@ infixr 4 `archiveTo` -- external repository corresponding to all of these packages withRepo :: FilePath -> TestM a -> TestM a withRepo repo_dir m = do - 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... + 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 where - repoUri env ="file+noindex://" ++ (if isWindows - then map (\x -> case x of - '\\' -> '/' - _ -> x) - else id) (testRepoDir env) + -- TODO: Arguably should undo everything when we're done... + + repoUri env = + "file+noindex://" + ++ ( if isWindows + then + map + ( \x -> case x of + '\\' -> '/' + _ -> x + ) + else id + ) + (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 + -- 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 - -- 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 - - 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" - r <- runReaderT m (env { testHaveRepo = True }) - -- Windows fails to kill the python server when the function above - -- is complete, so we kill it directly via CMD. - when (buildOS == Windows) $ void $ createProcess_ "kill python" $ System.Process.shell "taskkill /F /IM python3.exe" - pure r - ) - + 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" + r <- runReaderT m (env{testHaveRepo = True}) + -- Windows fails to kill the python server when the function above + -- is complete, so we kill it directly via CMD. + when (buildOS == Windows) $ void $ createProcess_ "kill python" $ System.Process.shell "taskkill /F /IM python3.exe" + pure r + ) -- | Record a header to help identify the output to the expect -- log. Unlike the 'recordLog', we don't record all arguments; @@ -709,23 +765,24 @@ withRemoteRepo repoDir m = 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" - rec_header = C.pack str_header - case mode of - DoNotRecord -> return () - _ -> do - initWorkDir - liftIO $ putStr str_header - liftIO $ C.appendFile (testWorkDir env "test.log") rec_header - liftIO $ C.appendFile (testActualFile env) rec_header - + env <- getTestEnv + let mode = testRecordMode env + str_header = "# " ++ intercalate " " args ++ "\n" + rec_header = C.pack str_header + case mode of + DoNotRecord -> return () + _ -> do + initWorkDir + liftIO $ putStr str_header + liftIO $ C.appendFile (testWorkDir env "test.log") rec_header + liftIO $ C.appendFile (testActualFile env) rec_header ------------------------------------------------------------------------ + -- * Test helpers ------------------------------------------------------------------------ + -- * Subprocess run results assertFailure :: WithCallStack (String -> m a) assertFailure msg = withFrozenCallStack $ error msg @@ -733,133 +790,182 @@ 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 + ) + ) + ) -- | Assert that at least one of the given paths contains the given search string. assertAnyFileContains :: MonadIO m => WithCallStack ([FilePath] -> String -> m ()) assertAnyFileContains paths needle = do - let findOne found path = - if found - then pure found - else withFileContents path $ \contents -> - pure $! needle `isInfixOf` contents - foundNeedle <- liftIO $ foldM findOne False paths - withFrozenCallStack $ - unless foundNeedle $ - assertFailure $ - "expected: " <> - needle <> - "\nin one of:\n" <> - unlines (map ("* " <>) paths) + let findOne found path = + if found + then pure found + else withFileContents path $ \contents -> + pure $! needle `isInfixOf` contents + foundNeedle <- liftIO $ foldM findOne False paths + withFrozenCallStack $ + unless foundNeedle $ + assertFailure $ + "expected: " + <> needle + <> "\nin one of:\n" + <> unlines (map ("* " <>) paths) -- | Assert that none of the given paths contains the given search string. assertNoFileContains :: MonadIO m => WithCallStack ([FilePath] -> String -> m ()) assertNoFileContains paths needle = - liftIO $ - forM_ paths $ - \path -> - assertFileDoesNotContain path needle + liftIO $ + forM_ paths $ + \path -> + assertFileDoesNotContain path needle -- | Replace line breaks with spaces, correctly handling "\r\n". concatOutput :: String -> String @@ -868,12 +974,13 @@ 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 = C.unpack . Base16.encode . C.take 26 . SHA256.hash . C.pack $ hashinput - return $ cabalDir "script-builds" hash + cabalDir <- testCabalDir `fmap` getTestEnv + hashinput <- liftIO $ canonicalizePath script + let hash = C.unpack . Base16.encode . C.take 26 . SHA256.hash . C.pack $ hashinput + return $ cabalDir "script-builds" hash ------------------------------------------------------------------------ + -- * Globs -- | Match a glob from a root directory and return the results. @@ -926,18 +1033,25 @@ assertGlobDoesNotMatchTestDir rootSelector glob = do assertGlobDoesNotMatch root glob ------------------------------------------------------------------------ + -- * Skipping tests testCompilerWithArgs :: [String] -> TestM Bool testCompilerWithArgs args = 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 (["-c", prof_test_hs] ++ args) - 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 + (["-c", prof_test_hs] ++ args) + Nothing + return (resultExitCode r == ExitSuccess) hasProfiledLibraries, hasProfiledSharedLibraries, hasSharedLibraries :: TestM Bool hasProfiledLibraries = testCompilerWithArgs ["-prof"] @@ -960,11 +1074,10 @@ hasCabalShared = do env <- getTestEnv return (testHaveCabalShared env) - -anyCabalVersion :: WithCallStack ( String -> TestM Bool ) +anyCabalVersion :: WithCallStack (String -> TestM Bool) anyCabalVersion = isCabalVersion any -allCabalVersion :: WithCallStack ( String -> TestM Bool ) +allCabalVersion :: WithCallStack (String -> TestM Bool) allCabalVersion = isCabalVersion all -- Used by cabal-install tests to determine which Cabal library versions are @@ -977,9 +1090,9 @@ isCabalVersion decide range = do cabal_pkgs <- ghcPkg_raw' $ ["--global", "list", "Cabal", "--simple"] ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs] let pkg_versions :: [PackageIdentifier] = mapMaybe simpleParsec (words (resultOutput cabal_pkgs)) vr <- case eitherParsec range of - Left err -> fail err - Right vr -> return vr - return $ decide (`withinRange` vr) (map pkgVersion pkg_versions) + Left err -> fail err + Right vr -> return vr + return $ decide (`withinRange` vr) (map pkgVersion pkg_versions) -- | Skip a test unless any available Cabal library version matches the predicate. skipUnlessAnyCabalVersion :: String -> TestM () @@ -999,15 +1112,17 @@ skipIfAllCabalVersion range = skipIf ("incompatible with Cabal " ++ range) =<< a 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 @@ -1035,8 +1150,9 @@ isLinux = buildOS == Linux isJavaScript :: Bool isJavaScript = 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 :: String -> IO () skipIfWindows why = skipIfIO ("Windows " <> why) isWindows @@ -1061,34 +1177,34 @@ expectBrokenIfWindows ticket = expectBrokenIf isWindows ticket expectBrokenIfWindowsCI :: IssueID -> TestM a -> TestM a expectBrokenIfWindowsCI ticket m = do - ci <- liftIO isCI - expectBrokenIf (isWindows && ci) ticket m + ci <- liftIO isCI + expectBrokenIf (isWindows && ci) ticket m expectBrokenIfWindowsCIAndGhc :: String -> IssueID -> TestM a -> TestM a expectBrokenIfWindowsCIAndGhc range ticket m = do - ghcVer <- isGhcVersion range - ci <- liftIO isCI - expectBrokenIf (isWindows && ghcVer && ci) ticket m + ghcVer <- isGhcVersion range + ci <- liftIO isCI + expectBrokenIf (isWindows && ghcVer && ci) ticket m expectBrokenIfWindowsAndGhc :: String -> IssueID -> TestM a -> TestM a expectBrokenIfWindowsAndGhc range ticket m = do - ghcVer <- isGhcVersion range - expectBrokenIf (isWindows && ghcVer) ticket m + ghcVer <- isGhcVersion range + expectBrokenIf (isWindows && ghcVer) ticket m expectBrokenIfOSXAndGhc :: String -> IssueID -> TestM a -> TestM a expectBrokenIfOSXAndGhc range ticket m = do - ghcVer <- isGhcVersion range - expectBrokenIf (isOSX && ghcVer) ticket m + ghcVer <- isGhcVersion range + expectBrokenIf (isOSX && ghcVer) ticket m expectBrokenIfGhc :: String -> IssueID -> TestM a -> TestM a expectBrokenIfGhc range ticket m = do - ghcVer <- isGhcVersion range - expectBrokenIf ghcVer ticket m + ghcVer <- isGhcVersion range + expectBrokenIf ghcVer ticket m flakyIfCI :: IssueID -> TestM a -> TestM a flakyIfCI ticket m = do - ci <- liftIO isCI - flakyIf ci ticket m + ci <- liftIO isCI + flakyIf ci ticket m flakyIfWindows :: IssueID -> TestM a -> TestM a flakyIfWindows ticket m = flakyIf isWindows ticket m @@ -1113,7 +1229,6 @@ getOpenFilesLimit = liftIO $ 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" @@ -1124,81 +1239,80 @@ 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 ghcPkg_raw' :: [String] -> TestM Result ghcPkg_raw' args = do recordHeader ["ghc-pkg"] runProgramM ghcPkgProgram 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 -- | 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. @@ -1219,13 +1333,13 @@ withSymlink oldpath newpath0 act = do writeSourceFile :: FilePath -> String -> TestM () writeSourceFile fp s = do - cwd <- fmap testCurrentDir getTestEnv - liftIO $ writeFile (cwd fp) s + cwd <- fmap testCurrentDir getTestEnv + liftIO $ writeFile (cwd fp) s copySourceFileTo :: FilePath -> FilePath -> TestM () copySourceFileTo src dest = do - cwd <- fmap testCurrentDir getTestEnv - liftIO $ copyFile (cwd src) (cwd dest) + cwd <- fmap testCurrentDir getTestEnv + liftIO $ copyFile (cwd src) (cwd dest) -- | Work around issue #4515 (store paths exceeding the Windows path length -- limit) by creating a temporary directory for the new-build store. This @@ -1237,21 +1351,24 @@ withShorterPathForNewBuildStore 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 :: String -- ^package name prefix - -> TestM FilePath -- ^package dir +findDependencyInStore + :: String + -- ^ package name prefix + -> TestM FilePath + -- ^ package dir findDependencyInStore pkgName = do - storeDir <- testStoreDir <$> getTestEnv - liftIO $ do - storeDirForGhcVersion:_ <- 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 = case filter (pkgName' `isPrefixOf`) packageDirs of - [] -> error $ "Could not find " <> pkgName' <> " when searching for " <> pkgName' <> " in\n" <> show packageDirs - (dir:_) -> dir - pure (storeDir storeDirForGhcVersion libDir) + storeDir <- testStoreDir <$> getTestEnv + liftIO $ do + storeDirForGhcVersion : _ <- 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 = case filter (pkgName' `isPrefixOf`) packageDirs of + [] -> error $ "Could not find " <> pkgName' <> " when searching for " <> pkgName' <> " in\n" <> show packageDirs + (dir : _) -> dir + pure (storeDir storeDirForGhcVersion libDir) diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 498c14ded23..f5dfb6d7f4a 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.hs @@ -1,116 +1,132 @@ {-# LANGUAGE DataKinds #-} {-# 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 + -- 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 - -- `System.Process.createPipe` calls (through many intermediaries) - -- `GHC.IO.Handle.FD.fdToHandle`, whose documentation says: - -- - -- > Makes a binary Handle. This is for historical reasons; it should - -- > probably be a text Handle with the default encoding and newline - -- > translation instead. - -- - -- The documentation for `System.IO.hSetBinaryMode` says: - -- - -- > This has the same effect as calling `hSetEncoding` with `char8`, together - -- > with `hSetNewlineMode` with `noNewlineTranslation`. - -- - -- But this is a lie, and Unicode written to or read from binary handles is - -- always encoded or decoded as Latin-1, which is always the wrong choice. - -- - -- Therefore, we explicitly set the output to UTF-8 to keep it consistent - -- between platforms and correct on all modern computers. - -- - -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25307 - hSetEncoding readh utf8 - hSetEncoding writeh utf8 + 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 + -- `System.Process.createPipe` calls (through many intermediaries) + -- `GHC.IO.Handle.FD.fdToHandle`, whose documentation says: + -- + -- > Makes a binary Handle. This is for historical reasons; it should + -- > probably be a text Handle with the default encoding and newline + -- > translation instead. + -- + -- The documentation for `System.IO.hSetBinaryMode` says: + -- + -- > This has the same effect as calling `hSetEncoding` with `char8`, together + -- > with `hSetNewlineMode` with `noNewlineTranslation`. + -- + -- But this is a lie, and Unicode written to or read from binary handles is + -- always encoded or decoded as Latin-1, which is always the wrong choice. + -- + -- Therefore, we explicitly set the output to UTF-8 to keep it consistent + -- between platforms and correct on all modern computers. + -- + -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25307 + hSetEncoding readh utf8 + hSetEncoding writeh utf8 - 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 - } + 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 a478d5008af..53470d660b7 100644 --- a/cabal-testsuite/src/Test/Cabal/Script.hs +++ b/cabal-testsuite/src/Test/Cabal/Script.hs @@ -3,45 +3,44 @@ -- | 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.Simple.Compiler +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup (Flag (..)) +import Distribution.System import Distribution.Types.ModuleRenaming import Distribution.Utils.NubList import Distribution.Utils.Path -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program -import Distribution.Simple.Compiler import Distribution.Verbosity -import Distribution.System -import Distribution.Simple.Setup (Flag(..)) 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 :: PackageDBStackCWD - , runnerVerbosity :: Verbosity - , runnerPlatform :: Platform - , runnerCompiler :: Compiler - , runnerPackages :: [(OpenUnitId, ModuleRenaming)] - , runnerWithSharedLib :: Bool - } - deriving Show + { runnerProgramDb :: ProgramDb + , runnerPackageDbStack :: PackageDBStackCWD + , runnerVerbosity :: Verbosity + , runnerPlatform :: Platform + , runnerCompiler :: Compiler + , runnerPackages :: [(OpenUnitId, ModuleRenaming)] + , runnerWithSharedLib :: Bool + } + deriving (Show) {- @@ -58,34 +57,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 = [] @@ -96,18 +107,20 @@ runnerGhcArgs :: ScriptEnv -> Maybe FilePath -> [String] runnerGhcArgs senv mb_cwd = renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options where - ghc_options = M.mempty { ghcOptPackageDBs = fmap (fmap makeSymbolicPath) (runnerPackageDbStack senv) - , ghcOptPackages = toNubListR (runnerPackages senv) - , ghcOptHideAllPackages = Flag True - -- Avoid picking stray module files that look - -- like our imports... - , ghcOptSourcePathClear = Flag True - -- ... yet retain the current directory as an included - -- directory, e.g. so that we can compile a Setup.hs - -- script which imports a locally defined module. - -- See the PackageTests/SetupDep test. - , ghcOptSourcePath = toNubListR $ - case mb_cwd of - Nothing -> [] - Just {} -> [sameDirectory] - } + ghc_options = + M.mempty + { ghcOptPackageDBs = fmap (fmap makeSymbolicPath) (runnerPackageDbStack senv) + , ghcOptPackages = toNubListR (runnerPackages senv) + , ghcOptHideAllPackages = Flag True + , -- Avoid picking stray module files that look + -- like our imports... + ghcOptSourcePathClear = Flag True + , -- ... yet retain the current directory as an included + -- directory, e.g. so that we can compile a Setup.hs + -- script which imports a locally defined module. + -- See the PackageTests/SetupDep test. + ghcOptSourcePath = toNubListR $ + case mb_cwd of + Nothing -> [] + Just{} -> [sameDirectory] + } diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index d7022ed9563..9e7b7fbbfbe 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- FOURMOLU_DISABLE -} + -- | A GHC run-server, which supports running multiple GHC scripts -- without having to restart from scratch. module Test.Cabal.Server ( diff --git a/cabal-testsuite/src/Test/Cabal/TestCode.hs b/cabal-testsuite/src/Test/Cabal/TestCode.hs index fc24b216285..3543f502557 100644 --- a/cabal-testsuite/src/Test/Cabal/TestCode.hs +++ b/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -5,50 +5,49 @@ -- | Exception type like 'ExitCode' but with more information -- than just integer. -module Test.Cabal.TestCode ( - -- * TestCode - TestCode (..), - FlakyStatus (..), - IssueID (..), - displayTestCode, - isTestCodeSkip, - isTestCodeFlaky, - isTestCodeUnexpectedSuccess, -) where +module Test.Cabal.TestCode + ( -- * TestCode + TestCode (..) + , FlakyStatus (..) + , IssueID (..) + , displayTestCode + , isTestCodeSkip + , isTestCodeFlaky + , isTestCodeUnexpectedSuccess + ) where import Control.Exception (Exception (..)) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable) ------------------------------------------------------------------------------- -- TestCode ------------------------------------------------------------------------------- data TestCode - = TestCodeOk - | TestCodeSkip String - | TestCodeKnownFail IssueID - | TestCodeUnexpectedOk IssueID - | TestCodeFail - | TestCodeFlakyFailed IssueID - | TestCodeFlakyPassed IssueID + = TestCodeOk + | TestCodeSkip String + | TestCodeKnownFail IssueID + | TestCodeUnexpectedOk IssueID + | TestCodeFail + | TestCodeFlakyFailed IssueID + | TestCodeFlakyPassed IssueID deriving (Eq, Show, Read, Typeable) -instance Exception TestCode - where - displayException = displayTestCode +instance Exception TestCode where + displayException = displayTestCode displayTestCode :: TestCode -> String -displayTestCode TestCodeOk = "OK" -displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg -displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" +displayTestCode TestCodeOk = "OK" +displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg +displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" displayTestCode (TestCodeUnexpectedOk t) = "FAIL (unexpected success, see #" <> show t <> ")" -displayTestCode TestCodeFail = "FAIL" -displayTestCode (TestCodeFlakyFailed t) = "FLAKY (FAIL, see #" <> show t <> ")" -displayTestCode (TestCodeFlakyPassed t) = "FLAKY (OK, see #" <> show t <> ")" +displayTestCode TestCodeFail = "FAIL" +displayTestCode (TestCodeFlakyFailed t) = "FLAKY (FAIL, see #" <> show t <> ")" +displayTestCode (TestCodeFlakyPassed t) = "FLAKY (OK, see #" <> show t <> ")" isTestCodeSkip :: TestCode -> Bool isTestCodeSkip (TestCodeSkip _) = True -isTestCodeSkip _ = False +isTestCodeSkip _ = False type TestPassed = Bool @@ -62,8 +61,8 @@ data FlakyStatus isTestCodeFlaky :: TestCode -> FlakyStatus isTestCodeFlaky (TestCodeFlakyPassed t) = Flaky True t isTestCodeFlaky (TestCodeFlakyFailed t) = Flaky False t -isTestCodeFlaky _ = NotFlaky +isTestCodeFlaky _ = NotFlaky isTestCodeUnexpectedSuccess :: TestCode -> Maybe IssueID isTestCodeUnexpectedSuccess (TestCodeUnexpectedOk t) = Just t -isTestCodeUnexpectedSuccess _ = Nothing +isTestCodeUnexpectedSuccess _ = Nothing diff --git a/cabal-testsuite/src/Test/Cabal/Workdir.hs b/cabal-testsuite/src/Test/Cabal/Workdir.hs index 148508eb606..cdb7f1d85b6 100644 --- a/cabal-testsuite/src/Test/Cabal/Workdir.hs +++ b/cabal-testsuite/src/Test/Cabal/Workdir.hs @@ -3,19 +3,19 @@ -- | 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 Distribution.Utils.Path - ( FileOrDir(..) + ( Dist + , FileOrDir (..) , Pkg - , Dist , SymbolicPath - , makeSymbolicPath , getSymbolicPath + , makeSymbolicPath ) import System.Directory -import System.Environment ( getExecutablePath ) +import System.Environment (getExecutablePath) import System.FilePath -- | Guess what the dist directory of a running executable is, @@ -24,10 +24,10 @@ import System.FilePath -- if the executable has been installed somewhere else. guessDistDir :: IO (SymbolicPath Pkg (Dir Dist)) guessDistDir = do - exe_path <- canonicalizePath =<< getExecutablePath - let dist0 = dropFileName exe_path ".." ".." - b <- doesFileExist (dist0 "setup-config") - if b + exe_path <- canonicalizePath =<< getExecutablePath + let dist0 = dropFileName exe_path ".." ".." + b <- doesFileExist (dist0 "setup-config") + if b then do cwd <- getCurrentDirectory dist1 <- canonicalizePath dist0 diff --git a/solver-benchmarks/HackageBenchmark.hs b/solver-benchmarks/HackageBenchmark.hs index 37996dbfc63..98c4a06b4a5 100644 --- a/solver-benchmarks/HackageBenchmark.hs +++ b/solver-benchmarks/HackageBenchmark.hs @@ -1,12 +1,11 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -module HackageBenchmark ( - hackageBenchmarkMain - --- Exposed for testing: - , CabalResult(..) +module HackageBenchmark + ( hackageBenchmarkMain + -- Exposed for testing: + , CabalResult (..) , isSignificantTimeDifference , combineTrialResults , isSignificantResult @@ -16,45 +15,62 @@ 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.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 @@ -75,20 +91,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 @@ -98,77 +116,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"] @@ -179,9 +223,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"] "" @@ -195,16 +239,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" @@ -212,11 +262,13 @@ 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 -- Initialize the config file, whether or not it already exists runCabalCmdWithEnv cabalDir thisEnv ["user-config", "init", "--force"] @@ -228,36 +280,29 @@ runCabal timeoutSeconds cabalUnderTest cabal flags = do -- return an actual runner return $ \pkg -> do ((exitCode, err), time) <- timeEvent $ do - let timeout = "timeout --foreground -sINT " ++ show timeoutSeconds - cabalCmd = unwords $ + cabalCmd = + unwords $ [ cabal - , "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 @@ -266,87 +311,91 @@ 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) where runCabalCmdWithEnv cabalDir thisEnv args = do - (ec, uout, uerr) <- readCreateProcessWithExitCode (proc cabal args) - { cwd = Just cabalDir - , env = Just thisEnv - } + (ec, uout, uerr) <- + readCreateProcessWithExitCode + (proc cabal args) + { cwd = Just cabalDir + , env = Just thisEnv + } "" unless (ec == ExitSuccess) $ do - putStrLn uout - putStrLn uerr - exitWith ec + putStrLn uout + putStrLn uerr + exitWith ec 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 - | r:_ <- rs - , allEqual rs = r + | r : _ <- rs + , allEqual rs = + r | allEqual [r | r <- rs, r /= Timeout] = Timeout - | otherwise = Unknown + | otherwise = Unknown where allEqual :: Eq a => [a] -> Bool allEqual xs = length (nub xs) == 1 @@ -362,71 +411,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 - ] - ]