ArrowSpec.hs

{-# LANGUAGE BlockArguments #-}

-- | Acceptance tests for the 'Control.Arrow.Arrow' instance on
-- 'SomeSymTransducer' (EP-29 of MasterPlan 9, M3).
--
-- The Arrow instance lifts arbitrary Haskell functions via
-- 'Arr.arr' (a stateless one-edge transducer whose 'WireCtor's
-- 'wcBuild' applies the function), and inherits 'Arr.first' /
-- 'Arr.second' from the 'Strong' instance. @(>>>)@ comes from the
-- 'Cat.Category' instance.
--
-- /Composition limitation:/ 'arr f >>> arr g' does NOT produce
-- 'arr (g . f)' on this wrapper — see 'arrTransducer' haddock for
-- the @icName == wcName@ alignment reason. The spec covers the
-- standalone-arr forward eval, sentinel preservation, first
-- delegation, and the documented 'solveOutput' lossy contract.
module Keiki.ArrowSpec (spec) where

import Control.Arrow qualified as Arr
import Control.Category qualified as Cat
import Control.Exception (evaluate)
import Data.Text (Text)
import Data.Text qualified as Text
import Keiki.Core
import Keiki.LawHelpers (emittedLog, runScript)
import Keiki.Profunctor
import Test.Hspec

-- * Specs -------------------------------------------------------------------

spec :: Spec
spec = do
  describe "arr" $ do
    it "lifts (Text.pack . show) :: SomeSymTransducer Int Text" $ do
      let lifted :: SomeSymTransducer Int Text
          lifted = Arr.arr (Text.pack . show)
      case lifted of
        SomeSymTransducer t ->
          omega t (initial t) (initialRegs t) (42 :: Int)
            `shouldBe` [("42" :: Text)]

    it "lifts identity-shaped functions but does not detect them as Cat.id" $ do
      -- Arr.arr id has the identity *behaviour* on every input but
      -- the wrapper cannot observe Haskell function identity, so it
      -- materialises into a SomeSymTransducer rather than the
      -- sentinel. This is the documented behaviour.
      let lifted :: SomeSymTransducer Int Int
          lifted = Arr.arr (id :: Int -> Int)
      case lifted of
        SomeSymTransducer t ->
          omega t (initial t) (initialRegs t) (7 :: Int)
            `shouldBe` [7]
        SomeSymIdentity ->
          expectationFailure
            "Arr.arr id should NOT short-circuit to SomeSymIdentity \
            \— Haskell function identity is unobservable at the value level"

  describe "first via Arrow's first method (delegates to Strong.first')" $ do
    it "first (arr show) on (42, \"extra\") emits (\"42\", \"extra\")" $ do
      let lifted :: SomeSymTransducer (Int, Text) (String, Text)
          lifted = Arr.first (Arr.arr show)
      case lifted of
        SomeSymTransducer t ->
          omega t (initial t) (initialRegs t) (42 :: Int, "extra" :: Text)
            `shouldBe` [("42", "extra")]

  describe "Cat.id and the Arrow instance interplay" $ do
    it "Cat.id passes through arr-style values verbatim" $
      -- This exercises that the Arrow instance's superclass dispatch
      -- of (>>>) hits the sentinel short-circuit when one operand is
      -- the sentinel. arr f >>> Cat.id should equal arr f
      -- behaviourally.
      let lifted :: SomeSymTransducer Int Text
          lifted = Arr.arr (Text.pack . show) Cat.>>> Cat.id
       in case lifted of
            SomeSymTransducer t ->
              omega t (initial t) (initialRegs t) (99 :: Int)
                `shouldBe` [("99" :: Text)]

    it "Cat.id <<< arr f passes through verbatim too" $
      let lifted :: SomeSymTransducer Int Text
          lifted = Cat.id Cat.<<< Arr.arr (Text.pack . show)
       in case lifted of
            SomeSymTransducer t ->
              omega t (initial t) (initialRegs t) (5 :: Int)
                `shouldBe` [("5" :: Text)]

  describe "forward and inversion observations" $ do
    it "standalone arr has a four-command forward trace" $ do
      let lifted = Arr.arr (+ 1) :: SomeSymTransducer Int Int
          script = [1, 2, 3, 4]
      case lifted of
        SomeSymTransducer transducer ->
          runScript transducer script `shouldBe` map (\n -> [n + 1]) script
        SomeSymIdentity -> expectationFailure "arr returned identity sentinel"

    it "arr is not replay-equivalent" $ do
      let lifted = Arr.arr (+ 1) :: SomeSymTransducer Int Int
          script = [1, 2, 3, 4]
      case lifted of
        SomeSymTransducer transducer ->
          case reconstituteEither transducer (emittedLog transducer script) of
            Left _ -> pure ()
            Right _ -> expectationFailure "arr unexpectedly replayed"
        SomeSymIdentity -> expectationFailure "arr returned identity sentinel"

    it "arr fusion fails loudly at the poisoned boundary" $ do
      let fused =
            (Arr.arr (+ 1) Cat.>>> Arr.arr (* 2)) ::
              SomeSymTransducer Int Int
      evaluate fused
        `shouldThrow` (\e -> pceSide e == "upstream output")