module Futhark.Pkg.SolveTests (tests) where

import Data.Map qualified as M
import Data.Monoid
import Data.Text qualified as T
import Futhark.Pkg.Solve
import Futhark.Pkg.Types
import Test.Tasty
import Test.Tasty.HUnit
import Prelude

semverE :: T.Text -> SemVer
semverE :: Text -> SemVer
semverE Text
s = case Text -> Either (ParseErrorBundle Text Void) SemVer
parseVersion Text
s of
  Left ParseErrorBundle Text Void
err ->
    [Char] -> SemVer
forall a. HasCallStack => [Char] -> a
error ([Char] -> SemVer) -> [Char] -> SemVer
forall a b. (a -> b) -> a -> b
$
      Text -> [Char]
T.unpack Text
s
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a valid version number: "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ParseErrorBundle Text Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle Text Void
err
  Right SemVer
x -> SemVer
x

-- | A world of packages and interdependencies for testing the solver
-- without touching the outside world.
testEnv :: PkgRevDepInfo
testEnv :: PkgRevDepInfo
testEnv =
  [((Text, SemVer), PkgRevDeps)] -> PkgRevDepInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((Text, SemVer), PkgRevDeps)] -> PkgRevDepInfo)
-> [((Text, SemVer), PkgRevDeps)] -> PkgRevDepInfo
forall a b. (a -> b) -> a -> b
$
    ((Text, [(Text, [(Text, [(Text, Text)])])])
 -> [((Text, SemVer), PkgRevDeps)])
-> [(Text, [(Text, [(Text, [(Text, Text)])])])]
-> [((Text, SemVer), PkgRevDeps)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (Text, [(Text, [(Text, [(Text, Text)])])])
-> [((Text, SemVer), PkgRevDeps)]
forall {m :: * -> *} {a}.
(Monad m, Semigroup a, IsString a) =>
(a, m (a, m (Text, [(Text, Text)]))) -> m ((a, SemVer), PkgRevDeps)
frob
      [ ( Text
"athas",
          [ ( Text
"foo",
              [ (Text
"0.1.0", []),
                (Text
"0.2.0", [(Text
"athas/bar", Text
"1.0.0")]),
                (Text
"0.3.0", [])
              ]
            ),
            (Text
"foo@v2", [(Text
"2.0.0", [(Text
"athas/quux", Text
"0.1.0")])]),
            (Text
"bar", [(Text
"1.0.0", [])]),
            (Text
"baz", [(Text
"0.1.0", [(Text
"athas/foo", Text
"0.3.0")])]),
            ( Text
"quux",
              [ ( Text
"0.1.0",
                  [ (Text
"athas/foo", Text
"0.2.0"),
                    (Text
"athas/baz", Text
"0.1.0")
                  ]
                )
              ]
            ),
            ( Text
"quux_perm",
              [ ( Text
"0.1.0",
                  [ (Text
"athas/baz", Text
"0.1.0"),
                    (Text
"athas/foo", Text
"0.2.0")
                  ]
                )
              ]
            ),
            (Text
"x_bar", [(Text
"1.0.0", [(Text
"athas/bar", Text
"1.0.0")])]),
            (Text
"x_foo", [(Text
"1.0.0", [(Text
"athas/foo", Text
"0.3.0")])]),
            ( Text
"tricky",
              [ ( Text
"1.0.0",
                  [ (Text
"athas/foo", Text
"0.2.0"),
                    (Text
"athas/x_foo", Text
"1.0.0")
                  ]
                )
              ]
            )
          ]
        ),
        -- Some mutually recursive packages.
        ( Text
"nasty",
          [ (Text
"foo", [(Text
"1.0.0", [(Text
"nasty/bar", Text
"1.0.0")])]),
            (Text
"bar", [(Text
"1.0.0", [(Text
"nasty/foo", Text
"1.0.0")])])
          ]
        )
      ]
  where
    frob :: (a, m (a, m (Text, [(Text, Text)]))) -> m ((a, SemVer), PkgRevDeps)
frob (a
user, m (a, m (Text, [(Text, Text)]))
repos) = do
      (a
repo, m (Text, [(Text, Text)])
repo_revs) <- m (a, m (Text, [(Text, Text)]))
repos
      (Text
rev, [(Text, Text)]
deps) <- m (Text, [(Text, Text)])
repo_revs
      let rev' :: SemVer
rev' = Text -> SemVer
semverE Text
rev
          onDep :: (a, Text) -> (a, (SemVer, Maybe a))
onDep (a
dp, Text
dv) = (a
dp, (Text -> SemVer
semverE Text
dv, Maybe a
forall a. Maybe a
Nothing))
          deps' :: PkgRevDeps
deps' = Map Text (SemVer, Maybe Text) -> PkgRevDeps
PkgRevDeps (Map Text (SemVer, Maybe Text) -> PkgRevDeps)
-> Map Text (SemVer, Maybe Text) -> PkgRevDeps
forall a b. (a -> b) -> a -> b
$ [(Text, (SemVer, Maybe Text))] -> Map Text (SemVer, Maybe Text)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, (SemVer, Maybe Text))] -> Map Text (SemVer, Maybe Text))
-> [(Text, (SemVer, Maybe Text))] -> Map Text (SemVer, Maybe Text)
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> (Text, (SemVer, Maybe Text)))
-> [(Text, Text)] -> [(Text, (SemVer, Maybe Text))]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (Text, (SemVer, Maybe Text))
forall {a} {a}. (a, Text) -> (a, (SemVer, Maybe a))
onDep [(Text, Text)]
deps
      ((a, SemVer), PkgRevDeps) -> m ((a, SemVer), PkgRevDeps)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
user a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"/" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
repo, SemVer
rev'), PkgRevDeps
deps')

newtype SolverRes = SolverRes BuildList
  deriving (SolverRes -> SolverRes -> Bool
(SolverRes -> SolverRes -> Bool)
-> (SolverRes -> SolverRes -> Bool) -> Eq SolverRes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SolverRes -> SolverRes -> Bool
== :: SolverRes -> SolverRes -> Bool
$c/= :: SolverRes -> SolverRes -> Bool
/= :: SolverRes -> SolverRes -> Bool
Eq)

instance Show SolverRes where
  show :: SolverRes -> [Char]
show (SolverRes BuildList
bl) = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ BuildList -> Text
prettyBuildList BuildList
bl

solverTest :: PkgPath -> T.Text -> Either T.Text [(PkgPath, T.Text)] -> TestTree
solverTest :: Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
p Text
v Either Text [(Text, Text)]
expected =
  [Char] -> Assertion -> TestTree
testCase (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v') (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
    (BuildList -> SolverRes)
-> Either Text BuildList -> Either Text SolverRes
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BuildList -> SolverRes
SolverRes (PkgRevDepInfo -> PkgRevDeps -> Either Text BuildList
solveDepsPure PkgRevDepInfo
testEnv PkgRevDeps
target)
      Either Text SolverRes -> Either Text SolverRes -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either Text SolverRes
expected'
  where
    target :: PkgRevDeps
target = Map Text (SemVer, Maybe Text) -> PkgRevDeps
PkgRevDeps (Map Text (SemVer, Maybe Text) -> PkgRevDeps)
-> Map Text (SemVer, Maybe Text) -> PkgRevDeps
forall a b. (a -> b) -> a -> b
$ Text -> (SemVer, Maybe Text) -> Map Text (SemVer, Maybe Text)
forall k a. k -> a -> Map k a
M.singleton Text
p (SemVer
v', Maybe Text
forall a. Maybe a
Nothing)
    v' :: SemVer
v' = Text -> SemVer
semverE Text
v
    expected' :: Either Text SolverRes
expected' = BuildList -> SolverRes
SolverRes (BuildList -> SolverRes)
-> ([(Text, Text)] -> BuildList) -> [(Text, Text)] -> SolverRes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text SemVer -> BuildList
BuildList (Map Text SemVer -> BuildList)
-> ([(Text, Text)] -> Map Text SemVer)
-> [(Text, Text)]
-> BuildList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, SemVer)] -> Map Text SemVer
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, SemVer)] -> Map Text SemVer)
-> ([(Text, Text)] -> [(Text, SemVer)])
-> [(Text, Text)]
-> Map Text SemVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> (Text, SemVer))
-> [(Text, Text)] -> [(Text, SemVer)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (Text, SemVer)
forall {a}. (a, Text) -> (a, SemVer)
onRes ([(Text, Text)] -> SolverRes)
-> Either Text [(Text, Text)] -> Either Text SolverRes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text [(Text, Text)]
expected
    onRes :: (a, Text) -> (a, SemVer)
onRes (a
dp, Text
dv) = (a
dp, Text -> SemVer
semverE Text
dv)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"SolveTests"
    [ Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/foo" Text
"0.1.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right [(Text
"athas/foo", Text
"0.1.0")],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/foo" Text
"0.2.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"athas/foo", Text
"0.2.0"),
            (Text
"athas/bar", Text
"1.0.0")
          ],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/quux" Text
"0.1.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"athas/quux", Text
"0.1.0"),
            (Text
"athas/foo", Text
"0.3.0"),
            (Text
"athas/baz", Text
"0.1.0")
          ],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/quux_perm" Text
"0.1.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"athas/quux_perm", Text
"0.1.0"),
            (Text
"athas/foo", Text
"0.3.0"),
            (Text
"athas/baz", Text
"0.1.0")
          ],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/foo@v2" Text
"2.0.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"athas/foo@v2", Text
"2.0.0"),
            (Text
"athas/quux", Text
"0.1.0"),
            (Text
"athas/foo", Text
"0.3.0"),
            (Text
"athas/baz", Text
"0.1.0")
          ],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/foo@v3" Text
"3.0.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text [(Text, Text)]
forall a b. a -> Either a b
Left Text
"Unknown package/version: athas/foo@v3-3.0.0",
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"nasty/foo" Text
"1.0.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"nasty/foo", Text
"1.0.0"),
            (Text
"nasty/bar", Text
"1.0.0")
          ],
      Text -> Text -> Either Text [(Text, Text)] -> TestTree
solverTest Text
"athas/tricky" Text
"1.0.0" (Either Text [(Text, Text)] -> TestTree)
-> Either Text [(Text, Text)] -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right
          [ (Text
"athas/tricky", Text
"1.0.0"),
            (Text
"athas/foo", Text
"0.3.0"),
            (Text
"athas/x_foo", Text
"1.0.0")
          ]
    ]