phino-0.0.114: test/ASTSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

{- | Tests for the AST module that defines the abstract syntax tree
for phi-calculus expressions: bindings, attributes, and bytes.
Attention! Most of the tests are generated by LLM. Consider that when refactoring
-}
module ASTSpec where

import AST
import Control.Monad (forM_)
import Data.List (nub, sort)
import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe, shouldSatisfy)

spec :: Spec
spec = do
  describe "Attribute Show instance renders AtLabel" $
    forM_
      [ ("simple label", AtLabel "x", "x")
      , ("unicode label", AtLabel "日本語", "日本語")
      , ("long label", AtLabel "myAttribute", "myAttribute")
      ]
      ( \(desc, attr, expected) ->
          it desc $ show attr `shouldBe` expected
      )

  describe "Attribute Show instance renders AtAlpha" $
    forM_
      [ ("zero index", Alpha 0, "α0")
      , ("positive index", Alpha 42, "α42")
      , ("large index", Alpha 999, "α999")
      ]
      ( \(desc, attr, expected) ->
          it desc $ show attr `shouldBe` expected
      )

  describe "Alpha Eq instance compares same constructors" $
    forM_
      [ ("alphas equal", Alpha 1, Alpha 1, True)
      , ("alphas differ", Alpha 1, Alpha 2, False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Attribute Show instance renders special attributes" $
    forM_
      [ ("rho", AtRho, "ρ")
      , ("phi", AtPhi, "φ")
      , ("delta", AtDelta, "Δ")
      , ("lambda", AtLambda, "λ")
      ]
      ( \(desc, attr, expected) ->
          it desc $ show attr `shouldBe` expected
      )

  describe "Attribute Show instance renders AtMeta" $
    forM_
      [ ("simple meta", AtMeta "t", "!t")
      , ("long meta", AtMeta "tttribute", "!tttribute")
      , ("unicode meta", AtMeta "メタ", "!メタ")
      ]
      ( \(desc, attr, expected) ->
          it desc $ show attr `shouldBe` expected
      )

  describe "Attribute Eq instance compares same constructors" $
    forM_
      [ ("labels equal", AtLabel "x", AtLabel "x", True)
      , ("labels differ", AtLabel "x", AtLabel "y", False)
      , ("metas equal", AtMeta "t", AtMeta "t", True)
      , ("metas differ", AtMeta "t", AtMeta "b", False)
      , ("rho equals rho", AtRho, AtRho, True)
      , ("phi equals phi", AtPhi, AtPhi, True)
      , ("delta equals delta", AtDelta, AtDelta, True)
      , ("lambda equals lambda", AtLambda, AtLambda, True)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Attribute Eq instance compares different constructors" $
    forM_
      [ ("rho vs phi", AtRho, AtPhi, False)
      , ("delta vs lambda", AtDelta, AtLambda, False)
      , ("meta vs label", AtMeta "x", AtLabel "x", False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Attribute Ord instance orders correctly" $
    it "sorts attributes by constructor order" $
      let attrs = [AtMeta "z", AtDelta, AtLambda, AtRho, AtPhi, AtLabel "a"]
          first : _ = sort attrs
          isLabel (AtLabel _) = True
          isLabel _ = False
       in first `shouldSatisfy` isLabel

  describe "Bytes Eq instance compares same constructors" $
    forM_
      [ ("empty equals empty", BtEmpty, BtEmpty, True)
      , ("one equals one", BtOne "FF", BtOne "FF", True)
      , ("one differs", BtOne "FF", BtOne "00", False)
      , ("many equals many", BtMany ["00", "01"], BtMany ["00", "01"], True)
      , ("many differs", BtMany ["00"], BtMany ["01"], False)
      , ("meta equals meta", BtMeta "b", BtMeta "b", True)
      , ("meta differs", BtMeta "b", BtMeta "c", False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Bytes Eq instance compares different constructors" $
    forM_
      [ ("empty vs one", BtEmpty, BtOne "00", False)
      , ("one vs many", BtOne "00", BtMany ["00"], False)
      , ("many vs meta", BtMany ["00"], BtMeta "b", False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Bytes Ord instance orders correctly" $
    it "sorts bytes by constructor order" $
      let bytes = [BtMeta "z", BtMany ["00"], BtOne "FF", BtEmpty]
          first : _ = sort bytes
       in first `shouldBe` BtEmpty

  describe "Binding Eq instance compares same constructors" $
    forM_
      [ ("tau equals tau", BiTau AtRho ExRoot, BiTau AtRho ExRoot, True)
      , ("tau differs by attr", BiTau AtRho ExRoot, BiTau AtPhi ExRoot, False)
      , ("tau differs by expr", BiTau AtRho ExRoot, BiTau AtRho ExXi, False)
      , ("meta equals meta", BiMeta "B", BiMeta "B", True)
      , ("meta differs", BiMeta "B", BiMeta "C", False)
      , ("delta equals delta", BiDelta BtEmpty, BiDelta BtEmpty, True)
      , ("delta differs", BiDelta BtEmpty, BiDelta (BtOne "00"), False)
      , ("void equals void", BiVoid AtRho, BiVoid AtRho, True)
      , ("void differs", BiVoid AtRho, BiVoid AtPhi, False)
      , ("lambda equals lambda", BiLambda (Function "Func"), BiLambda (Function "Func"), True)
      , ("lambda differs", BiLambda (Function "Func"), BiLambda (Function "Other"), False)
      , ("metalambda equals", BiLambda (FnMeta "F"), BiLambda (FnMeta "F"), True)
      , ("metalambda differs", BiLambda (FnMeta "F"), BiLambda (FnMeta "G"), False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Binding Eq instance compares different constructors" $
    forM_
      [ ("tau vs meta", BiTau AtRho ExRoot, BiMeta "B", False)
      , ("delta vs void", BiDelta BtEmpty, BiVoid AtDelta, False)
      , ("lambda vs metalambda", BiLambda (Function "F"), BiLambda (FnMeta "F"), False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Binding Ord instance orders correctly" $
    it "sorts bindings by constructor order" $
      let bindings = [BiLambda (FnMeta "Z"), BiLambda (Function "A"), BiVoid AtRho, BiDelta BtEmpty, BiMeta "B", BiTau AtRho ExRoot]
          first : _ = sort bindings
          isTau (BiTau _ _) = True
          isTau _ = False
       in first `shouldSatisfy` isTau

  describe "Expression Eq instance compares same constructors" $
    forM_
      [ ("formation equals", ExFormation [], ExFormation [], True)
      , ("formation differs", ExFormation [], ExFormation [BiVoid AtRho], False)
      , ("this equals this", ExXi, ExXi, True)
      , ("global equals global", ExRoot, ExRoot, True)
      , ("termination equals", ExTermination, ExTermination, True)
      , ("meta equals meta", ExMeta "e", ExMeta "e", True)
      , ("meta differs", ExMeta "e", ExMeta "f", False)
      , ("application equals", ExApplication ExRoot (ArTau AtRho ExXi), ExApplication ExRoot (ArTau AtRho ExXi), True)
      , ("dispatch equals", ExDispatch ExRoot AtRho, ExDispatch ExRoot AtRho, True)
      , ("dispatch differs", ExDispatch ExRoot AtRho, ExDispatch ExRoot AtPhi, False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Expression Eq instance compares different constructors" $
    forM_
      [ ("formation vs this", ExFormation [], ExXi, False)
      , ("global vs termination", ExRoot, ExTermination, False)
      , ("meta vs dispatch", ExMeta "e", ExDispatch ExRoot AtRho, False)
      ]
      ( \(desc, lhs, rhs, expected) ->
          it desc $ (lhs == rhs) `shouldBe` expected
      )

  describe "Expression Ord instance orders correctly" $
    it "sorts expressions by constructor order" $
      let exprs = [ExDispatch ExRoot AtRho, ExApplication ExRoot (ArTau AtRho ExRoot), ExMeta "e", ExTermination, ExRoot, ExXi, ExFormation []]
          first : _ = sort exprs
       in first `shouldBe` ExFormation []

  describe "countNodes counts ExFormation with non-tau bindings" $
    forM_
      [ ("Q", ExRoot, 1)
      , ("T", ExTermination, 1)
      , ("$", ExXi, 1)
      , ("dispatch on global", ExDispatch ExRoot (AtLabel "x"), 3)
      , ("application with globals", ExApplication ExRoot (ArTau AtRho ExRoot), 6)
      , ("nested expressions", ExFormation [BiTau AtRho ExRoot, BiTau AtPhi ExRoot], 9)
      , ("empty formation", ExFormation [], 1)
      , ("void binding", ExFormation [BiVoid AtRho], 5)
      , ("delta binding", ExFormation [BiDelta BtEmpty], 5)
      , ("lambda binding", ExFormation [BiLambda (Function "Func")], 5)
      , ("meta binding", ExFormation [BiMeta "B"], 3)
      , ("metalambda binding", ExFormation [BiLambda (FnMeta "F")], 5)
      , ("meta expression", ExMeta "e", 1)
      , ("deeply nested dispatch", ExDispatch (ExDispatch ExRoot (AtLabel "a")) (AtLabel "b"), 5)
      , ("formation with dispatch inside", ExFormation [BiTau AtRho (ExDispatch ExRoot (AtLabel "x"))], 7)
      , ("application with tau argument", ExApplication ExRoot (ArTau AtRho ExRoot), 6)
      , ("application with alpha argument", ExApplication ExRoot (ArAlpha (Alpha 0) ExRoot), 6)
      , ("phi-meet wraps its inner count", ExPhiMeet Nothing 1 (ExDispatch ExRoot (AtLabel "x")), 3)
      , ("phi-meet with label wraps its inner count", ExPhiMeet (Just "m") 2 ExRoot, 1)
      , ("phi-again wraps its inner count", ExPhiAgain Nothing 1 (ExDispatch ExRoot (AtLabel "x")), 3)
      , ("phi-again with label wraps its inner count", ExPhiAgain (Just "m") 2 ExRoot, 1)
      , ("bare bytes falls into the catch-all", ExBytes BtEmpty, 1)
      ]
      ( \(desc, expr, expected) ->
          it desc $ countNodes expr `shouldBe` expected
      )

  describe "hashExpression" $ do
    it "hashes every Expression/Binding/Bytes/Attribute/Argument/Alpha/Function constructor without collisions" $
      let exprs =
            [ ExFormation []
            , ExFormation [BiTau AtRho ExRoot]
            , ExFormation [BiVoid AtPhi]
            , ExFormation [BiDelta BtEmpty]
            , ExFormation [BiDelta (BtOne "FF")]
            , ExFormation [BiDelta (BtMany ["00", "01"])]
            , ExFormation [BiDelta (BtMeta "b")]
            , ExFormation [BiLambda (Function "Func")]
            , ExFormation [BiLambda (FnMeta "F")]
            , ExFormation [BiMeta "M"]
            , ExXi
            , ExRoot
            , ExTermination
            , ExApplication ExRoot (ArTau AtRho ExXi)
            , ExApplication ExRoot (ArAlpha (Alpha 3) ExXi)
            , ExApplication ExRoot (ArAlpha (AlMeta "A") ExXi)
            , ExDispatch ExRoot (AtLabel "x")
            , ExDispatch ExRoot AtPhi
            , ExDispatch ExRoot AtRho
            , ExDispatch ExRoot AtLambda
            , ExDispatch ExRoot AtDelta
            , ExDispatch ExRoot (AtMeta "m")
            , ExMeta "e"
            , ExMeta "f"
            , ExPhiMeet (Just "m") 2 ExRoot
            , ExPhiMeet Nothing 2 ExRoot
            , ExPhiMeet Nothing 3 ExRoot
            , ExPhiAgain (Just "m") 2 ExRoot
            , ExPhiAgain Nothing 2 ExRoot
            , ExPhiAgain Nothing 3 ExRoot
            , ExBytes BtEmpty
            , ExBytes (BtOne "FF")
            , ExBytes (BtMany ["00", "FF"])
            , ExBytes (BtMeta "b")
            ]
          hashes = map hashExpression exprs
       in nub hashes `shouldBe` hashes

    it "produces different hashes for a couple of hand-picked distinct expressions" $ do
      hashExpression ExRoot `shouldNotBe` hashExpression ExXi
      hashExpression (ExDispatch ExRoot (AtLabel "x")) `shouldNotBe` hashExpression (ExDispatch ExRoot (AtLabel "y"))

  describe "BaseObject pattern" $ do
    it "constructs a Q-dispatch expression" $
      BaseObject "bytes" `shouldBe` ExDispatch ExRoot (AtLabel "bytes")

    forM_
      [ ("matches a Q-dispatch expression, extracting the label", ExDispatch ExRoot (AtLabel "number"), Just "number")
      , ("does not match a non-Q-dispatch expression", ExDispatch ExXi (AtLabel "number"), Nothing)
      ]
      ( \(desc, expr, expected) ->
          it desc $
            let matched = case expr of
                  BaseObject label -> Just label
                  _ -> Nothing
             in matched `shouldBe` expected
      )

  describe "dataBytes" $
    it "builds the bytes-object formation carrying the given bytes" $
      dataBytes (BtOne "48")
        `shouldBe` ExApplication
          (ExDispatch ExRoot (AtLabel "bytes"))
          (ArTau (AtLabel "data") (ExFormation [BiDelta (BtOne "48"), BiVoid AtRho]))

  describe "DataObject/DataString/DataNumber pattern" $ do
    it "constructs the named, unwrapped as-bytes form" $
      DataString (BtOne "48")
        `shouldBe` ExApplication
          (ExDispatch ExRoot (AtLabel "string"))
          (ArTau (AtLabel "as-bytes") (dataBytes (BtOne "48")))

    forM_
      [
        ( "matches the named, unwrapped form"
        , ExApplication (ExDispatch ExRoot (AtLabel "string")) (ArTau (AtLabel "as-bytes") (dataBytes (BtOne "48")))
        , Just (BtOne "48")
        )
      ,
        ( "matches the named form with a phi-again-wrapped outer object"
        , ExApplication
            (ExPhiAgain Nothing 1 (ExDispatch ExRoot (AtLabel "string")))
            (ArTau (AtLabel "as-bytes") (dataBytes (BtOne "48")))
        , Just (BtOne "48")
        )
      ,
        ( "matches the named form with a phi-again-wrapped inner bytes formation"
        , ExApplication
            (ExDispatch ExRoot (AtLabel "number"))
            ( ArTau
                (AtLabel "as-bytes")
                ( ExApplication
                    (ExDispatch ExRoot (AtLabel "bytes"))
                    (ArTau (AtLabel "data") (ExPhiAgain Nothing 1 (ExFormation [BiDelta (BtOne "05"), BiVoid AtRho])))
                )
            )
        , Just (BtOne "05")
        )
      ,
        ( "matches the legacy positional (alpha0) form on both layers"
        , ExApplication
            (ExDispatch ExRoot (AtLabel "number"))
            ( ArAlpha
                (Alpha 0)
                ( ExApplication
                    (ExDispatch ExRoot (AtLabel "bytes"))
                    (ArAlpha (Alpha 0) (ExFormation [BiDelta (BtOne "05"), BiVoid AtRho]))
                )
            )
        , Just (BtOne "05")
        )
      ]
      ( \(desc, expr, expected) ->
          it desc $
            let matched = case expr of
                  DataString bts -> Just bts
                  DataNumber bts -> Just bts
                  _ -> Nothing
             in matched `shouldBe` expected
      )

    forM_
      [
        ( "does not match when the outer object is not a base object (matchOuter fails)"
        , ExApplication ExRoot (ArTau (AtLabel "as-bytes") (dataBytes (BtOne "48")))
        )
      ,
        ( "does not match when the inner object is not an application (matchInner fails)"
        , ExApplication (ExDispatch ExRoot (AtLabel "string")) (ArTau (AtLabel "as-bytes") ExRoot)
        )
      ,
        ( "does not match when the inner base object is not 'bytes' (matchesBytes fails)"
        , ExApplication
            (ExDispatch ExRoot (AtLabel "string"))
            ( ArTau
                (AtLabel "as-bytes")
                ( ExApplication
                    (ExDispatch ExRoot (AtLabel "other"))
                    (ArTau (AtLabel "data") (ExFormation [BiDelta (BtOne "48"), BiVoid AtRho]))
                )
            )
        )
      ,
        ( "does not match when the bytes formation has the wrong shape (matchFormation fails)"
        , ExApplication
            (ExDispatch ExRoot (AtLabel "string"))
            ( ArTau
                (AtLabel "as-bytes")
                ( ExApplication
                    (ExDispatch ExRoot (AtLabel "bytes"))
                    (ArTau (AtLabel "data") (ExFormation [BiDelta (BtOne "48")]))
                )
            )
        )
      ]
      ( \(desc, expr) ->
          it desc $
            let matched = case expr of
                  DataObject label bts -> Just (label, bts)
                  _ -> Nothing
             in matched `shouldBe` Nothing
      )