cabal-install/tests/UnitTests/Distribution/Client/Targets.hs

   1 module UnitTests.Distribution.Client.Targets
   2   ( tests
   3   ) where
   4
   5 import Distribution.Client.Targets
   6   ( UserConstraint (..)
   7   , UserConstraintScope (..)
   8   , UserQualifier (..)
   9   , readUserConstraint
  10   )
  11 import Distribution.Package (mkPackageName)
  12 import Distribution.PackageDescription (mkFlagAssignment, mkFlagName)
  13 import Distribution.Version (anyVersion, mkVersion, thisVersion)
  14
  15 import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList)
  16
  17 import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..))
  18 import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
  19
  20 import Test.Tasty
  21 import Test.Tasty.HUnit
  22
  23 import Data.List (intercalate)
  24
  25 -- Helper function: makes a test group by mapping each element
  26 -- of a list to a test case.
  27 makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree
  28 makeGroup name f xs =
  29   testGroup name $
  30     zipWith testCase (map show [0 :: Integer ..]) (map f xs)
  31
  32 tests :: [TestTree]
  33 tests =
  34   [ makeGroup
  35       "readUserConstraint"
  36       (uncurry readUserConstraintTest)
  37       exampleConstraints
  38   , makeGroup
  39       "parseUserConstraint"
  40       (uncurry parseUserConstraintTest)
  41       exampleConstraints
  42   , makeGroup
  43       "readUserConstraints"
  44       (uncurry readUserConstraintsTest)
  45       [ -- First example only.
  46
  47         ( case exampleStrs of (e : _) -> e; _ -> error "empty examples"
  48         , take 1 exampleUcs
  49         )
  50       , -- All examples separated by commas.
  51         (intercalate ", " exampleStrs, exampleUcs)
  52       ]
  53   ]
  54   where
  55     (exampleStrs, exampleUcs) = unzip exampleConstraints
  56
  57 exampleConstraints :: [(String, UserConstraint)]
  58 exampleConstraints =
  59   [
  60     ( "template-haskell installed"
  61     , UserConstraint
  62         (UserQualified UserQualToplevel (pn "template-haskell"))
  63         PackagePropertyInstalled
  64     )
  65   ,
  66     ( "bytestring >= 0"
  67     , UserConstraint
  68         (UserQualified UserQualToplevel (pn "bytestring"))
  69         (PackagePropertyVersion anyVersion)
  70     )
  71   ,
  72     ( "any.directory test"
  73     , UserConstraint
  74         (UserAnyQualifier (pn "directory"))
  75         (PackagePropertyStanzas [TestStanzas])
  76     )
  77   ,
  78     ( "setup.Cabal installed"
  79     , UserConstraint
  80         (UserAnySetupQualifier (pn "Cabal"))
  81         PackagePropertyInstalled
  82     )
  83   ,
  84     ( "process:setup.bytestring ==5.2"
  85     , UserConstraint
  86         (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))
  87         (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))
  88     )
  89   , -- flag MUST be prefixed with - or +
  90
  91     ( "network:setup.containers +foo -bar +baz"
  92     , UserConstraint
  93         (UserQualified (UserQualSetup (pn "network")) (pn "containers"))
  94         ( PackagePropertyFlags
  95             ( mkFlagAssignment
  96                 [ (fn "foo", True)
  97                 , (fn "bar", False)
  98                 , (fn "baz", True)
  99                 ]
 100             )
 101         )
 102     )
 103     -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
 104     --
 105     -- , ("foo:happy:exe.template-haskell test",
 106     --    UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))
 107     --                   (PackagePropertyStanzas [TestStanzas]))
 108   ]
 109   where
 110     pn = mkPackageName
 111     fn = mkFlagName
 112
 113 readUserConstraintTest :: String -> UserConstraint -> Assertion
 114 readUserConstraintTest str uc =
 115   assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual
 116   where
 117     expected = Right uc
 118     actual = readUserConstraint str
 119
 120 parseUserConstraintTest :: String -> UserConstraint -> Assertion
 121 parseUserConstraintTest str uc =
 122   assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual
 123   where
 124     expected = Right uc
 125     actual = explicitEitherParsec parsec str
 126
 127 readUserConstraintsTest :: String -> [UserConstraint] -> Assertion
 128 readUserConstraintsTest str ucs =
 129   assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual
 130   where
 131     expected = Right ucs
 132     actual = explicitEitherParsec (parsecCommaList parsec) str