Category.hs

-- | Pure laws for the category accessor and safe stream-name constructor
-- ('Kiroku.Store.Types.categoryName' and 'streamNameInCategory').
--
-- These pin the "category = substring before the first @-@" rule — enforced by
-- the @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column
-- and re-derived in 'Kiroku.Store.Notification' — so the public accessor cannot
-- drift from it. The round-trip law is the contract keiro's typed @Category@ API
-- (ExecPlan #66) builds on.
--
-- Pure; no database. Runs inside hspec via 'hspec-hedgehog'.
module Test.Category (spec) where

import Data.Text (Text)
import Data.Text qualified as T
import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Kiroku.Store.Types (CategoryName (..), StreamName (..), categoryName, streamNameInCategory)
import Test.Hspec
import Test.Hspec.Hedgehog (hedgehog)

-- | A non-empty, dash-free category. Includes @:@ and @$@ to exercise the
-- sub-namespacing convention (e.g. @"wf:orders"@) without the @-@ boundary.
genCategoryText :: Gen Text
genCategoryText = Gen.text (Range.linear 1 16) (Gen.element categoryChars)
  where
    categoryChars = ['a' .. 'z'] <> ['0' .. '9'] <> [':', '$', '_']

-- | An arbitrary id segment. May contain @-@: the id lives after the first
-- @-@, so embedded dashes must not change the leading category.
genSegment :: Gen Text
genSegment = Gen.text (Range.linear 0 16) (Gen.element segmentChars)
  where
    segmentChars = ['a' .. 'z'] <> ['0' .. '9'] <> ['-', ':', '_']

-- | An arbitrary stream name (may contain dashes anywhere, or none).
genStreamNameText :: Gen Text
genStreamNameText = Gen.text (Range.linear 0 24) (Gen.element nameChars)
  where
    nameChars = ['a' .. 'z'] <> ['0' .. '9'] <> ['-', ':', '_']

spec :: Spec
spec = describe "Kiroku.Store.Types category rule" $ do
  describe "categoryName" $ do
    it "takes the substring before the first dash" $
      categoryName (StreamName "orders-1") `shouldBe` CategoryName "orders"

    it "treats a dashless name as its own category" $
      categoryName (StreamName "singleton") `shouldBe` CategoryName "singleton"

    it "stops at the first dash even with later dashes" $
      categoryName (StreamName "orders-a-b-c") `shouldBe` CategoryName "orders"

    it "never yields a category containing a dash" $ hedgehog $ do
      name <- forAll genStreamNameText
      let CategoryName cat = categoryName (StreamName name)
      assert (not (T.isInfixOf "-" cat))

  describe "streamNameInCategory" $ do
    it "joins category and segment with a dash" $
      streamNameInCategory (CategoryName "orders") "1" `shouldBe` StreamName "orders-1"

  describe "round-trip" $ do
    it "categoryName . streamNameInCategory == id, for dash-free categories" $ hedgehog $ do
      cat <- forAll genCategoryText
      seg <- forAll genSegment
      categoryName (streamNameInCategory (CategoryName cat) seg) === CategoryName cat