Commit 8b74b634 authored by Robert Henderson's avatar Robert Henderson
Browse files

Updated unit tests for user constraints.

Added Arbitrary instance for UserQualifier.

Added more test cases for user constraint parsing.
parent 606b1600
......@@ -565,15 +565,22 @@ instance Arbitrary RemoteRepo where
shortListOf1 5 (oneof [ choose ('0', '9')
, choose ('a', 'f') ])
instance Arbitrary UserQualifier where
arbitrary = oneof [ pure UserToplevel
, UserSetup <$> arbitrary
, UserExe <$> arbitrary <*> arbitrary
]
instance Arbitrary UserConstraint where
arbitrary =
oneof [ UserConstraint UserToplevel <$> arbitrary <*> prop
| prop <- [ PackagePropertyVersion <$> arbitrary
arbitrary = UserConstraint <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary PackageProperty where
arbitrary = oneof [ PackagePropertyVersion <$> arbitrary
, pure PackagePropertyInstalled
, pure PackagePropertySource
, PackagePropertyFlags <$> shortListOf1 3 arbitrary
, PackagePropertyStanzas . (\x->[x]) <$> arbitrary
] ]
]
instance Arbitrary OptionalStanza where
arbitrary = elements [minBound..maxBound]
......
......@@ -4,61 +4,92 @@ module UnitTests.Distribution.Client.Targets (
import Distribution.Client.Targets (UserQualifier(..), UserConstraint(..)
,readUserConstraint)
import Distribution.Compat.ReadP (ReadP, readP_to_S)
import Distribution.Compat.ReadP (readP_to_S)
import Distribution.Package (mkPackageName)
import Distribution.PackageDescription (mkFlagName)
import Distribution.Version (anyVersion, thisVersion, mkVersion)
import Distribution.ParseUtils (parseCommaList)
import Distribution.Text (parse)
import Distribution.Solver.Types.PackageConstraint (PackageProperty(..))
import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..))
import Test.Tasty
import Test.Tasty.HUnit
import Data.Char (isSpace)
import Data.List (intercalate)
tests :: [TestTree]
tests = [ testCase "readUserConstraint" readUserConstraintTest
, testCase "parseUserConstraint" parseUserConstraintTest
, testCase "readUserConstraints" readUserConstraintsTest
]
-- Helper function: makes a test group by mapping each element
-- of a list to a test case.
makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree
makeGroup name f xs = testGroup name $
zipWith testCase (map show [0 :: Integer ..]) (map f xs)
readUserConstraintTest :: Assertion
readUserConstraintTest =
assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual
tests :: [TestTree]
tests =
[ makeGroup "readUserConstraint" (uncurry readUserConstraintTest)
exampleConstraints
, makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest)
exampleConstraints
, makeGroup "readUserConstraints" (uncurry readUserConstraintsTest)
[-- First example only.
(head exampleStrs, take 1 exampleUcs),
-- All examples separated by commas.
(intercalate ", " exampleStrs, exampleUcs)]
]
where
pkgName = "template-haskell"
constr = pkgName ++ " installed"
(exampleStrs, exampleUcs) = unzip exampleConstraints
expected = UserConstraint UserToplevel (mkPackageName pkgName)
PackagePropertyInstalled
actual = let (Right r) = readUserConstraint constr in r
exampleConstraints :: [(String, UserConstraint)]
exampleConstraints =
[ ("template-haskell installed",
UserConstraint UserToplevel (pn "template-haskell")
PackagePropertyInstalled)
, ("bytestring -any",
UserConstraint UserToplevel (pn "bytestring")
(PackagePropertyVersion anyVersion))
, ("process:setup.bytestring ==5.2",
UserConstraint (UserSetup (pn "process")) (pn "bytestring")
(PackagePropertyVersion (thisVersion (mkVersion [5, 2]))))
, ("network:setup.containers +foo -bar baz",
UserConstraint (UserSetup (pn "network")) (pn "containers")
(PackagePropertyFlags [(fn "foo", True),
(fn "bar", False),
(fn "baz", True)]))
, ("foo:happy:exe.template-haskell test",
UserConstraint (UserExe (pn "foo") (pn "happy")) (pn "template-haskell")
(PackagePropertyStanzas [TestStanzas]))
]
where
pn = mkPackageName
fn = mkFlagName
parseUserConstraintTest :: Assertion
parseUserConstraintTest =
assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual
readUserConstraintTest :: String -> UserConstraint -> Assertion
readUserConstraintTest str uc =
assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual
where
pkgName = "template-haskell"
constr = pkgName ++ " installed"
expected = uc
actual = let Right r = readUserConstraint str in r
expected = [UserConstraint UserToplevel (mkPackageName pkgName)
PackagePropertyInstalled]
actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr
parseUserConstraintTest :: String -> UserConstraint -> Assertion
parseUserConstraintTest str uc =
assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual
where
expected = [uc]
actual = [ x | (x, ys) <- readP_to_S parse str
, all isSpace ys]
parseUserConstraint :: ReadP r UserConstraint
parseUserConstraint = parse
readUserConstraintsTest :: Assertion
readUserConstraintsTest =
assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual
readUserConstraintsTest :: String -> [UserConstraint] -> Assertion
readUserConstraintsTest str ucs =
assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual
where
pkgName = "template-haskell"
constr = pkgName ++ " installed"
expected = [[UserConstraint UserToplevel (mkPackageName pkgName)
PackagePropertyInstalled]]
actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr
expected = [ucs]
actual = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str
, all isSpace ys]
parseUserConstraints :: ReadP r [UserConstraint]
parseUserConstraints = parseCommaList parse
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment