Eithers.hs

module Hydra.Sources.Test.Lib.Eithers where

-- Standard imports for shallow DSL tests
import Hydra.Kernel
import Hydra.Dsl.Meta.Testing                 as Testing
import Hydra.Dsl.Meta.Terms                   as Terms
import Hydra.Sources.Kernel.Types.All
import qualified Hydra.Dsl.Meta.Core          as Core
import qualified Hydra.Dsl.Meta.Phantoms      as Phantoms
import qualified Hydra.Dsl.Meta.Types         as T
import qualified Hydra.Sources.Test.TestGraph as TestGraph
import qualified Hydra.Sources.Test.TestTerms as TestTerms
import qualified Hydra.Sources.Test.TestTypes as TestTypes
import qualified Data.List                    as L
import qualified Data.Map                     as M

-- Additional imports specific to this file
import Hydra.Testing
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Meta.Lib.Logic as Logic


ns :: Namespace
ns = Namespace "hydra.test.lib.eithers"

module_ :: Module
module_ = Module ns elements [] [] $
    Just "Test cases for hydra.lib.eithers primitives"
  where
    elements = [Phantoms.toBinding allTests]

-- Helper to create Left terms
leftInt32 :: Int -> TTerm Term
leftInt32 x = left (int32 x)

-- Helper to create Right terms
rightString :: String -> TTerm Term
rightString s = right (string s)

-- Test groups for hydra.lib.eithers primitives

eithersBind :: TTerm TestGroup
eithersBind = subgroup "bind" [
  test "bind Right with success" (rightString "ab") (right (int32 2)),
  test "bind Right with failure" (rightString "") (leftInt32 0),
  test "bind Left returns Left unchanged" (leftInt32 42) (leftInt32 42)]
  where
    -- Function: get length of string, fail with 0 if empty
    bindFn = lambda "s" (primitive _logic_ifElse
      @@ (primitive _strings_null @@ var "s")
      @@ (left (int32 0))
      @@ (right (primitive _strings_length @@ var "s")))
    test name input expected = primCase name _eithers_bind [input, bindFn] expected

eithersBimap :: TTerm TestGroup
eithersBimap = subgroup "bimap" [
  test "map left value" (leftInt32 5) (leftInt32 10),
  test "map right value" (rightString "ab") (right (int32 2))]
  where
    test name input expected = primCase name _eithers_bimap [
      lambda "x" (primitive _math_mul @@ var "x" @@ int32 2),
      lambda "s" (primitive _strings_length @@ var "s"),
      input] expected

eithersIsLeft :: TTerm TestGroup
eithersIsLeft = subgroup "isLeft" [
  test "left value" (leftInt32 42) true,
  test "right value" (rightString "test") false]
  where
    test name x result = primCase name _eithers_isLeft [x] result

eithersIsRight :: TTerm TestGroup
eithersIsRight = subgroup "isRight" [
  test "right value" (rightString "test") true,
  test "left value" (leftInt32 42) false]
  where
    test name x result = primCase name _eithers_isRight [x] result

eithersFromLeft :: TTerm TestGroup
eithersFromLeft = subgroup "fromLeft" [
  test "extract left" 99 (leftInt32 42) 42,
  test "use default for right" 99 (rightString "test") 99]
  where
    test name def x result = primCase name _eithers_fromLeft [int32 def, x] (int32 result)

eithersFromRight :: TTerm TestGroup
eithersFromRight = subgroup "fromRight" [
  test "extract right" "default" (rightString "test") "test",
  test "use default for left" "default" (leftInt32 42) "default"]
  where
    test name def x result = primCase name _eithers_fromRight [string def, x] (string result)

eithersEither :: TTerm TestGroup
eithersEither = subgroup "either" [
  test "apply left function" (leftInt32 5) 10,
  test "apply right function" (rightString "ab") 2]
  where
    test name x result = primCase name _eithers_either [
      lambda "x" (primitive _math_mul @@ var "x" @@ int32 2),
      lambda "s" (primitive _strings_length @@ var "s"),
      x] (int32 result)

eithersLefts :: TTerm TestGroup
eithersLefts = subgroup "lefts" [
  test "filter left values" [leftInt32 1, rightString "a", leftInt32 2, rightString "b"] [1, 2],
  test "all lefts" [leftInt32 1, leftInt32 2] [1, 2],
  test "all rights" [rightString "a", rightString "b"] [],
  test "empty list" [] []]
  where
    test name input expected = primCase name _eithers_lefts [list input] (list $ fmap int32 expected)

eithersRights :: TTerm TestGroup
eithersRights = subgroup "rights" [
  test "filter right values" [leftInt32 1, rightString "a", leftInt32 2, rightString "b"] ["a", "b"],
  test "all rights" [rightString "a", rightString "b"] ["a", "b"],
  test "all lefts" [leftInt32 1, leftInt32 2] [],
  test "empty list" [] []]
  where
    test name input expected = primCase name _eithers_rights [list input] (list $ fmap string expected)

eithersPartitionEithers :: TTerm TestGroup
eithersPartitionEithers = subgroup "partitionEithers" [
  test "partition mixed" [leftInt32 1, rightString "a", leftInt32 2, rightString "b"] ([1, 2], ["a", "b"]),
  test "all lefts" [leftInt32 1, leftInt32 2] ([1, 2], []),
  test "all rights" [rightString "a", rightString "b"] ([], ["a", "b"]),
  test "empty list" [] ([], [])]
  where
    test name input (lefts, rights) = primCase name _eithers_partitionEithers [list input]
      (Core.termPair $ Phantoms.pair (list $ fmap int32 lefts) (list $ fmap string rights))

eithersMap :: TTerm TestGroup
eithersMap = subgroup "map" [
  test "map right value" (rightInt32 5) (rightInt32 10),
  test "preserve left" (leftInt32 99) (leftInt32 99)]
  where
    rightInt32 x = right (int32 x)
    leftInt32 x = left (int32 x)
    test name input expected = primCase name _eithers_map [
      lambda "x" (primitive _math_mul @@ var "x" @@ int32 2),
      input] expected

eithersMapList :: TTerm TestGroup
eithersMapList = subgroup "mapList" [
  test "all succeed" [1, 2, 3] (right (list [int32 2, int32 4, int32 6])),
  test "first fails" [1, 0, 3] (left (string "zero")),
  test "empty list" [] (right (list []))]
  where
    test name input expected = primCase name _eithers_mapList [
      lambda "x" (primitive _logic_ifElse
        @@ (primitive _equality_equal @@ var "x" @@ int32 0)
        @@ left (string "zero")
        @@ right (primitive _math_mul @@ var "x" @@ int32 2)),
      list $ fmap int32 input] expected

eithersMapMaybe :: TTerm TestGroup
eithersMapMaybe = subgroup "mapMaybe" [
  test "just succeeds" (Core.termMaybe $ just (int32 5)) (right (Core.termMaybe $ just (int32 10))),
  test "just fails" (Core.termMaybe $ just (int32 0)) (left (string "zero")),
  test "nothing" (Core.termMaybe nothing) (right (Core.termMaybe nothing))]
  where
    test name input expected = primCase name _eithers_mapMaybe [
      lambda "x" (primitive _logic_ifElse
        @@ (primitive _equality_equal @@ var "x" @@ int32 0)
        @@ left (string "zero")
        @@ right (primitive _math_mul @@ var "x" @@ int32 2)),
      input] expected

allTests :: TBinding TestGroup
allTests = definitionInModule module_ "allTests" $
    Phantoms.doc "Test cases for hydra.lib.eithers primitives" $
    supergroup "hydra.lib.eithers primitives" [
      eithersBind,
      eithersBimap,
      eithersIsLeft,
      eithersIsRight,
      eithersFromLeft,
      eithersFromRight,
      eithersEither,
      eithersLefts,
      eithersRights,
      eithersPartitionEithers,
      eithersMap,
      eithersMapList,
      eithersMapMaybe]