SolveTests.hs

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 s = case parseVersion s of
  Left err ->
    error $
      T.unpack s
        <> " is not a valid version number: "
        <> errorBundlePretty err
  Right x -> x

-- | A world of packages and interdependencies for testing the solver
-- without touching the outside world.
testEnv :: PkgRevDepInfo
testEnv =
  M.fromList $
    concatMap
      frob
      [ ( "athas",
          [ ( "foo",
              [ ("0.1.0", []),
                ("0.2.0", [("athas/bar", "1.0.0")]),
                ("0.3.0", [])
              ]
            ),
            ("foo@v2", [("2.0.0", [("athas/quux", "0.1.0")])]),
            ("bar", [("1.0.0", [])]),
            ("baz", [("0.1.0", [("athas/foo", "0.3.0")])]),
            ( "quux",
              [ ( "0.1.0",
                  [ ("athas/foo", "0.2.0"),
                    ("athas/baz", "0.1.0")
                  ]
                )
              ]
            ),
            ( "quux_perm",
              [ ( "0.1.0",
                  [ ("athas/baz", "0.1.0"),
                    ("athas/foo", "0.2.0")
                  ]
                )
              ]
            ),
            ("x_bar", [("1.0.0", [("athas/bar", "1.0.0")])]),
            ("x_foo", [("1.0.0", [("athas/foo", "0.3.0")])]),
            ( "tricky",
              [ ( "1.0.0",
                  [ ("athas/foo", "0.2.0"),
                    ("athas/x_foo", "1.0.0")
                  ]
                )
              ]
            )
          ]
        ),
        -- Some mutually recursive packages.
        ( "nasty",
          [ ("foo", [("1.0.0", [("nasty/bar", "1.0.0")])]),
            ("bar", [("1.0.0", [("nasty/foo", "1.0.0")])])
          ]
        )
      ]
  where
    frob (user, repos) = do
      (repo, repo_revs) <- repos
      (rev, deps) <- repo_revs
      let rev' = semverE rev
          onDep (dp, dv) = (dp, (semverE dv, Nothing))
          deps' = PkgRevDeps $ M.fromList $ map onDep deps
      pure ((user <> "/" <> repo, rev'), deps')

newtype SolverRes = SolverRes BuildList
  deriving (Eq)

instance Show SolverRes where
  show (SolverRes bl) = T.unpack $ prettyBuildList bl

solverTest :: PkgPath -> T.Text -> Either T.Text [(PkgPath, T.Text)] -> TestTree
solverTest p v expected =
  testCase (T.unpack $ p <> "-" <> prettySemVer v') $
    fmap SolverRes (solveDepsPure testEnv target)
      @?= expected'
  where
    target = PkgRevDeps $ M.singleton p (v', Nothing)
    v' = semverE v
    expected' = SolverRes . BuildList . M.fromList . map onRes <$> expected
    onRes (dp, dv) = (dp, semverE dv)

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