hackport-0.5: cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.Client.ProjectConfig (tests) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Control.Applicative
#endif
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
import Distribution.Package
import Distribution.PackageDescription hiding (Flag)
import Distribution.Compiler
import Distribution.Version
import Distribution.ParseUtils
import Distribution.Simple.Compiler
import Distribution.Simple.Setup
import Distribution.Simple.InstallDirs
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Simple.Utils
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db
import Distribution.Client.Types
import Distribution.Client.Dependency.Types
import Distribution.Client.BuildReports.Types
import Distribution.Client.Targets
import Distribution.Utils.NubList
import Network.URI
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectConfig.Legacy
import UnitTests.Distribution.Client.ArbitraryInstances
import Test.Tasty
import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
[ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $
[ testProperty "packages" prop_roundtrip_legacytypes_packages
, testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
, testProperty "specific" prop_roundtrip_legacytypes_specific
] ++
-- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
-- unclear why as of yet
concat
[ [ testProperty "shared" prop_roundtrip_legacytypes_shared
, testProperty "local" prop_roundtrip_legacytypes_local
, testProperty "all" prop_roundtrip_legacytypes_all
]
| not usingGhc76orOlder
]
, testGroup "individual parser tests"
[ testProperty "package location" prop_parsePackageLocationTokenQ
]
, testGroup "ProjectConfig printing/parsing round trip"
[ testProperty "packages" prop_roundtrip_printparse_packages
, testProperty "buildonly" prop_roundtrip_printparse_buildonly
, testProperty "shared" prop_roundtrip_printparse_shared
, testProperty "local" prop_roundtrip_printparse_local
, testProperty "specific" prop_roundtrip_printparse_specific
, testProperty "all" prop_roundtrip_printparse_all
]
]
where
usingGhc76orOlder =
case buildCompilerId of
CompilerId GHC v -> v < Version [7,7] []
_ -> False
------------------------------------------------
-- Round trip: conversion to/from legacy types
--
roundtrip :: Eq a => (a -> b) -> (b -> a) -> a -> Bool
roundtrip f f_inv x =
(f_inv . f) x == x
roundtrip_legacytypes :: ProjectConfig -> Bool
roundtrip_legacytypes =
roundtrip convertToLegacyProjectConfig
convertLegacyProjectConfig
prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool
prop_roundtrip_legacytypes_all =
roundtrip_legacytypes
prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool
prop_roundtrip_legacytypes_packages config =
roundtrip_legacytypes
config {
projectConfigBuildOnly = mempty,
projectConfigShared = mempty,
projectConfigLocalPackages = mempty,
projectConfigSpecificPackage = mempty
}
prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Bool
prop_roundtrip_legacytypes_buildonly config =
roundtrip_legacytypes
mempty { projectConfigBuildOnly = config }
prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Bool
prop_roundtrip_legacytypes_shared config =
roundtrip_legacytypes
mempty { projectConfigShared = config }
prop_roundtrip_legacytypes_local :: PackageConfig -> Bool
prop_roundtrip_legacytypes_local config =
roundtrip_legacytypes
mempty { projectConfigLocalPackages = config }
prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool
prop_roundtrip_legacytypes_specific config =
roundtrip_legacytypes
mempty { projectConfigSpecificPackage = config }
--------------------------------------------
-- Round trip: printing and parsing config
--
roundtrip_printparse :: ProjectConfig -> Bool
roundtrip_printparse config =
case (fmap convertLegacyProjectConfig
. parseLegacyProjectConfig
. showLegacyProjectConfig
. convertToLegacyProjectConfig)
config of
ParseOk _ x -> x == config
_ -> False
prop_roundtrip_printparse_all :: ProjectConfig -> Bool
prop_roundtrip_printparse_all config =
roundtrip_printparse config {
projectConfigBuildOnly =
hackProjectConfigBuildOnly (projectConfigBuildOnly config),
projectConfigShared =
hackProjectConfigShared (projectConfigShared config)
}
prop_roundtrip_printparse_packages :: [PackageLocationString]
-> [PackageLocationString]
-> [SourceRepo]
-> [Dependency]
-> Bool
prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =
roundtrip_printparse
mempty {
projectPackages = map getPackageLocationString pkglocstrs1,
projectPackagesOptional = map getPackageLocationString pkglocstrs2,
projectPackagesRepo = repos,
projectPackagesNamed = named
}
prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Bool
prop_roundtrip_printparse_buildonly config =
roundtrip_printparse
mempty {
projectConfigBuildOnly = hackProjectConfigBuildOnly config
}
hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly
hackProjectConfigBuildOnly config =
config {
-- These two fields are only command line transitory things, not
-- something to be recorded persistently in a config file
projectConfigOnlyDeps = mempty,
projectConfigDryRun = mempty
}
prop_roundtrip_printparse_shared :: ProjectConfigShared -> Bool
prop_roundtrip_printparse_shared config =
roundtrip_printparse
mempty {
projectConfigShared = hackProjectConfigShared config
}
hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared
hackProjectConfigShared config =
config {
projectConfigConstraints =
--TODO: [required eventually] parse ambiguity in constraint
-- "pkgname -any" as either any version or disabled flag "any".
let ambiguous ((UserConstraintFlags _pkg flags), _) =
(not . null) [ () | (FlagName name, False) <- flags
, "any" `isPrefixOf` name ]
ambiguous _ = False
in filter (not . ambiguous) (projectConfigConstraints config)
}
prop_roundtrip_printparse_local :: PackageConfig -> Bool
prop_roundtrip_printparse_local config =
roundtrip_printparse
mempty {
projectConfigLocalPackages = config
}
prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)
-> Bool
prop_roundtrip_printparse_specific config =
roundtrip_printparse
mempty {
projectConfigSpecificPackage = fmap getNonMEmpty config
}
----------------------------
-- Individual Parser tests
--
prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
prop_parsePackageLocationTokenQ (PackageLocationString str) =
case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ
(renderPackageLocationToken str) ] of
[str'] -> str' == str
_ -> False
------------------------
-- Arbitrary instances
--
instance Arbitrary ProjectConfig where
arbitrary =
ProjectConfig
<$> (map getPackageLocationString <$> arbitrary)
<*> (map getPackageLocationString <$> arbitrary)
<*> shortListOf 3 arbitrary
<*> arbitrary
<*> arbitrary <*> arbitrary
<*> arbitrary
<*> (fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary)
-- package entries with no content are equivalent to
-- the entry not existing at all, so exclude empty
shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) =
[ ProjectConfig x0' x1' x2' x3' x4' x5' x6' (fmap getNonMEmpty x7')
| ((x0', x1', x2', x3'), (x4', x5', x6', x7'))
<- shrink ((x0, x1, x2, x3), (x4, x5, x6, fmap NonMEmpty x7))
]
newtype PackageLocationString
= PackageLocationString { getPackageLocationString :: String }
deriving Show
instance Arbitrary PackageLocationString where
arbitrary =
PackageLocationString <$>
oneof
[ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))
, arbitraryGlobLikeStr
, show <$> (arbitrary :: Gen URI)
]
arbitraryGlobLikeStr :: Gen String
arbitraryGlobLikeStr = outerTerm
where
outerTerm = concat <$> shortListOf1 4
(frequency [ (2, token)
, (1, braces <$> innerTerm) ])
innerTerm = intercalate "," <$> shortListOf1 3
(frequency [ (3, token)
, (1, braces <$> innerTerm) ])
token = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))
braces s = "{" ++ s ++ "}"
instance Arbitrary ProjectConfigBuildOnly where
arbitrary =
ProjectConfigBuildOnly
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> (toNubList <$> shortListOf 2 arbitrary) -- 4
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> (fmap getShortToken <$> arbitrary) -- 8
<*> arbitrary
<*> arbitraryNumJobs
<*> arbitrary
<*> arbitrary -- 12
<*> (fmap getShortToken <$> arbitrary)
<*> arbitrary
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary) -- 16
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
where
arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary
shrink (ProjectConfigBuildOnly
x00 x01 x02 x03 x04 x05 x06 x07
x08 x09 x10 x11 x12 x13 x14 x15
x16 x17) =
[ ProjectConfigBuildOnly
x00' x01' x02' x03' x04'
x05' x06' x07' x08' (postShrink_NumJobs x09')
x10' x11' x12 x13' x14
x15 x16 x17
| ((x00', x01', x02', x03', x04'),
(x05', x06', x07', x08', x09'),
(x10', x11', x13'))
<- shrink
((x00, x01, x02, x03, x04),
(x05, x06, x07, x08, preShrink_NumJobs x09),
(x10, x11, x13))
]
where
preShrink_NumJobs = fmap (fmap Positive)
postShrink_NumJobs = fmap (fmap getPositive)
instance Arbitrary ProjectConfigShared where
arbitrary =
ProjectConfigShared
<$> (Map.fromList <$> shortListOf 10
((,) <$> arbitraryProgramName
<*> arbitraryShortToken))
<*> (Map.fromList <$> shortListOf 10
((,) <$> arbitraryProgramName
<*> listOf arbitraryShortToken))
<*> (toNubList <$> listOf arbitraryShortToken)
<*> arbitrary -- 4
<*> arbitraryFlag arbitraryShortToken
<*> arbitraryFlag arbitraryShortToken
<*> arbitrary
<*> arbitrary -- 8
<*> (toNubList <$> listOf arbitraryShortToken)
<*> arbitraryConstraints
<*> arbitrary <*> shortListOf 2 arbitrary -- 12
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 16
<*> arbitrary <*> arbitrary
where
arbitraryProgramName :: Gen String
arbitraryProgramName =
elements [ programName prog
| (prog, _) <- knownPrograms (defaultProgramDb) ]
arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
arbitraryConstraints =
map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary
shrink (ProjectConfigShared
x00 x01 x02 x03 x04
x05 x06 x07 x08 x09
x10 x11 x12 x13 x14
x15 x16 x17) =
[ ProjectConfigShared
(postShrink_Paths x00')
(postShrink_Args x01')
x02' x03'
(fmap getNonEmpty x04')
(fmap getNonEmpty x05')
x06' x07' x08'
(postShrink_Constraints x09')
x10' x11' x12' x13' x14'
x15' x16' x17'
| ((x00', x01', x02', x03', x04'),
(x05', x06', x07', x08', x09'),
(x10', x11', x12', x13', x14'),
(x15', x16', x17'))
<- shrink
((preShrink_Paths x00,
preShrink_Args x01,
x02, x03, fmap NonEmpty x04),
(fmap NonEmpty x05, x06, x07, x08, preShrink_Constraints x09),
(x10, x11, x12, x13, x14),
(x15, x16, x17))
]
where
preShrink_Paths = Map.map NonEmpty . Map.mapKeys NoShrink
postShrink_Paths = Map.map getNonEmpty . Map.mapKeys getNoShrink
preShrink_Args = Map.map (NonEmpty . map NonEmpty)
. Map.mapKeys NoShrink
postShrink_Args = Map.map (map getNonEmpty . getNonEmpty)
. Map.mapKeys getNoShrink
preShrink_Constraints = map fst
postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))
projectConfigConstraintSource :: ConstraintSource
projectConfigConstraintSource =
ConstraintSourceProjectConfig "TODO"
instance Arbitrary PackageConfig where
arbitrary =
PackageConfig
<$> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 4
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 8
<*> shortListOf 5 arbitraryShortToken
<*> arbitrary
<*> arbitrary <*> arbitrary -- 12
<*> shortListOf 5 arbitraryShortToken
<*> shortListOf 5 arbitraryShortToken
<*> shortListOf 5 arbitraryShortToken
<*> arbitrary -- 16
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 20
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 24
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary -- 28
<*> arbitraryFlag arbitraryShortToken
<*> arbitrary
<*> arbitrary <*> arbitrary -- 32
<*> arbitrary
<*> arbitraryFlag arbitraryShortToken
<*> arbitrary
<*> arbitraryFlag arbitraryShortToken -- 36
<*> arbitrary
shrink (PackageConfig
x00 x01 x02 x03 x04
x05 x06 x07 x08 x09
x10 x11 x12 x13 x14
x15 x16 x17 x18 x19
x20 x21 x22 x23 x24
x25 x26 x27 x28 x29
x30 x31 x32 x33 x34
x35 x36) =
[ PackageConfig
x00' x01' x02' x03' x04'
x05' x06' x07' (map getNonEmpty x08') x09'
x10' x11'
(map getNonEmpty x12')
(map getNonEmpty x13')
(map getNonEmpty x14')
x15' x16' x17' x18' x19'
x20' x21' x22' x23' x24'
x25' x26' x27' x28' x29'
x30' x31' x32' (fmap getNonEmpty x33') x34'
(fmap getNonEmpty x35') x36'
| (((x00', x01', x02', x03', x04'),
(x05', x06', x07', x08', x09'),
(x10', x11', x12', x13', x14'),
(x15', x16', x17', x18', x19')),
((x20', x21', x22', x23', x24'),
(x25', x26', x27', x28', x29'),
(x30', x31', x32', x33', x34'),
(x35', x36')))
<- shrink
(((x00, x01, x02, x03, x04),
(x05, x06, x07, map NonEmpty x08, x09),
(x10, x11,
map NonEmpty x12,
map NonEmpty x13,
map NonEmpty x14),
(x15, x16, x17, x18, x19)),
((x20, x21, x22, x23, x24),
(x25, x26, x27, x28, x29),
(x30, x31, x32, fmap NonEmpty x33, x34),
(fmap NonEmpty x35, x36)))
]
instance Arbitrary SourceRepo where
arbitrary = (SourceRepo RepoThis
<$> arbitrary
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary))
`suchThat` (/= emptySourceRepo)
shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =
[ repo
| ((x1', x2', x3'), (x4', x5', x6'))
<- shrink ((x1,
fmap ShortToken x2,
fmap ShortToken x3),
(fmap ShortToken x4,
fmap ShortToken x5,
fmap ShortToken x6))
, let repo = SourceRepo RepoThis x1'
(fmap getShortToken x2')
(fmap getShortToken x3')
(fmap getShortToken x4')
(fmap getShortToken x5')
(fmap getShortToken x6')
, repo /= emptySourceRepo
]
emptySourceRepo :: SourceRepo
emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing
Nothing Nothing Nothing
instance Arbitrary RepoType where
arbitrary = elements knownRepoTypes
instance Arbitrary ReportLevel where
arbitrary = elements [NoReports .. DetailedReports]
instance Arbitrary CompilerFlavor where
arbitrary = elements knownCompilerFlavors
where
--TODO: [code cleanup] export knownCompilerFlavors from D.Compiler
-- it's already defined there, just need it exported.
knownCompilerFlavors =
[GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
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 -- 14
instance Arbitrary PackageDB where
arbitrary = oneof [ pure GlobalPackageDB
, pure UserPackageDB
, SpecificPackageDB . getShortToken <$> arbitrary
]
instance Arbitrary RemoteRepo where
arbitrary =
RemoteRepo
<$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`))
<*> arbitrary -- URI
<*> arbitrary
<*> listOf arbitraryRootKey
<*> (fmap getNonNegative arbitrary)
<*> pure False
where
arbitraryRootKey =
shortListOf1 5 (oneof [ choose ('0', '9')
, choose ('a', 'f') ])
instance Arbitrary UserConstraint where
arbitrary =
oneof
[ UserConstraintVersion <$> arbitrary <*> arbitrary
, UserConstraintInstalled <$> arbitrary
, UserConstraintSource <$> arbitrary
, UserConstraintFlags <$> arbitrary <*> shortListOf1 3 arbitrary
, UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary)
]
instance Arbitrary OptionalStanza where
arbitrary = elements [minBound..maxBound]
instance Arbitrary FlagName where
arbitrary = FlagName <$> flagident
where
flagident = lowercase <$> shortListOf1 5 (elements flagChars)
`suchThat` (("-" /=) . take 1)
flagChars = "-_" ++ ['a'..'z']
instance Arbitrary PreSolver where
arbitrary = elements [minBound..maxBound]
instance Arbitrary AllowNewer where
arbitrary = oneof [ pure AllowNewerNone
, AllowNewerSome <$> shortListOf1 3 arbitrary
, pure AllowNewerAll
]
instance Arbitrary AllowNewerDep where
arbitrary = oneof [ AllowNewerDep <$> arbitrary
, AllowNewerDepScoped <$> arbitrary <*> arbitrary
]
instance Arbitrary ProfDetailLevel where
arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]
instance Arbitrary OptimisationLevel where
arbitrary = elements [minBound..maxBound]
instance Arbitrary DebugInfoLevel where
arbitrary = elements [minBound..maxBound]
instance Arbitrary URI where
arbitrary =
URI <$> elements ["file:", "http:", "https:"]
<*> (Just <$> arbitrary)
<*> (('/':) <$> arbitraryURIToken)
<*> (('?':) <$> arbitraryURIToken)
<*> pure ""
instance Arbitrary URIAuth where
arbitrary =
URIAuth <$> pure "" -- no password as this does not roundtrip
<*> arbitraryURIToken
<*> arbitraryURIPort
arbitraryURIToken :: Gen String
arbitraryURIToken =
shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))
arbitraryURIPort :: Gen String
arbitraryURIPort =
oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]