MetaTest.hs

{-# LANGUAGE OverloadedStrings #-}

module YCHR.MetaTest (tests) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase)
import YCHR.Internal.Compile.Names (vmName)
import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))
import YCHR.Internal.Meta (metaHostCallRegistry, valueToTerm)
import YCHR.Internal.Runtime.Interpreter
  ( HostCallFn (..),
    HostCallRegistry,
    baseHostCallRegistry,
  )
import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)
import YCHR.Internal.Runtime.Types (Value (..))
import YCHR.Internal.Runtime.Var (deref, equal)
import YCHR.Internal.Types (Term (..))
import YCHR.Internal.Types qualified as Types
import YCHR.Internal.VM (Name (..))
import YCHR.Run (compileModules, runProgramWithQuery)

tests :: TestTree
tests =
  testGroup
    "YCHR.Internal.Meta"
    [ readTermTests,
      vmNameRoundTripTests
    ]

hostCalls :: HostCallRegistry
hostCalls = baseHostCallRegistry <> metaHostCallRegistry

runChrBase :: Chr a -> IO a
runChrBase action = do
  env <- initSessionEnv [] [] Map.empty baseHostCallRegistry Map.empty Map.empty Set.empty
  runChr action env

-- | Invoke the read_term_from_string host call directly and return the Value.
readTerm :: Text -> IO Value
readTerm s = case Map.lookup (Name "read_term_from_string") metaHostCallRegistry of
  Nothing -> assertFailure "read_term_from_string not found in registry"
  Just (HostCallFn f) -> runChrBase (f [VText s])

compileOrFail :: [(FilePath, Text)] -> IO CompiledProgram
compileOrFail inputs = case compileModules False inputs of
  Left err -> assertFailure $ show err
  Right (cp, _) -> pure cp

readTermTests :: TestTree
readTermTests =
  testGroup
    "read_term_from_string"
    [ testCase "integer" $ do
        v <- readTerm "42"
        case v of
          VInt 42 -> pure ()
          _ -> assertFailure "expected VInt 42",
      testCase "negative integer" $ do
        v <- readTerm "-7"
        case v of
          VInt (-7) -> pure ()
          _ -> assertFailure "expected VInt (-7)",
      testCase "atom" $ do
        v <- readTerm "hello"
        case v of
          VAtom "hello" -> pure ()
          _ -> assertFailure "expected VAtom hello",
      testCase "quoted atom" $ do
        v <- readTerm "'hello world'"
        case v of
          VAtom "hello world" -> pure ()
          _ -> assertFailure "expected VAtom 'hello world'",
      testCase "string" $ do
        v <- readTerm "\"hello\""
        case v of
          VText "hello" -> pure ()
          _ -> assertFailure "expected VText hello",
      testCase "wildcard" $ do
        v <- readTerm "_"
        case v of
          VWildcard -> pure ()
          _ -> assertFailure "expected VWildcard",
      testCase "compound term" $ do
        v <- readTerm "f(1, hello)"
        case v of
          VTerm "f" [VInt 1, VAtom "hello"] -> pure ()
          _ -> assertFailure "unexpected result for f(1, hello)",
      testCase "nested compound term" $ do
        v <- readTerm "f(g(1), h(2, 3))"
        case v of
          VTerm "f" [VTerm "g" [VInt 1], VTerm "h" [VInt 2, VInt 3]] -> pure ()
          _ -> assertFailure "unexpected result for f(g(1), h(2, 3))",
      testCase "variable produces a fresh unbound var" $ do
        v <- readTerm "X"
        v' <- runChrBase (deref v)
        case v' of
          VVar _ -> pure ()
          _ -> assertFailure "expected unbound variable",
      testCase "same variable name maps to same var" $ do
        v <- readTerm "f(X, X)"
        eq <- runChrBase $ case v of
          VTerm "f" [a, b] -> equal a b
          _ -> pure False
        assertBool "both X args should be the same variable" eq,
      testCase "different variable names map to different vars" $ do
        v <- readTerm "f(X, Y)"
        eq <- runChrBase $ case v of
          VTerm "f" [a, b] -> equal a b
          _ -> pure True
        assertBool "X and Y should be different variables" (not eq),
      testCase "list syntax" $ do
        v <- readTerm "[1, 2, 3]"
        case v of
          VTerm "." [VInt 1, VTerm "." [VInt 2, VTerm "." [VInt 3, VAtom "[]"]]] -> pure ()
          _ -> assertFailure "unexpected result for [1, 2, 3]",
      testCase "infix operator <=> parses as compound term" $ do
        v <- readTerm "a <=> b"
        case v of
          VTerm "<=>" [VAtom "a", VAtom "b"] -> pure ()
          _ -> assertFailure "unexpected result for a <=> b",
      testCase "infix operator = parses as compound term" $ do
        v <- readTerm "a = b"
        case v of
          VTerm "=" [VAtom "a", VAtom "b"] -> pure ()
          _ -> assertFailure "unexpected result for a = b",
      endToEndReadTermTest
    ]

endToEndReadTermTest :: TestTree
endToEndReadTermTest =
  testCase "end-to-end: read_term_from_string in CHR query" $ do
    let src =
          ":- module(m, [check/2]).\n\
          \:- chr_constraint check/2.\n\
          \\n\
          \check(X, X) <=> true.\n"
    prog <- compileOrFail [("m.chr", src)]
    bindings <-
      runProgramWithQuery
        prog
        hostCalls
        "T is host:read_term_from_string(\"f(1, hello)\"), check(T, f(1, hello))."
    case Map.lookup "T" bindings of
      Just
        ( CompoundTerm
            (Types.Unqualified "f")
            [IntTerm 1, CompoundTerm (Types.Unqualified "hello") []]
          ) -> pure ()
      other -> assertFailure $ "Expected T = f(1, hello), got: " ++ show other

-- | Property: 'YCHR.Internal.Meta.valueToTerm' (run on a 'VAtom' whose payload
-- comes from 'YCHR.Internal.Compile.Names.vmName') recovers the original
-- 'Types.Name' as a qualified or unqualified 'CompoundTerm'. This
-- pins the injectivity of the mangling pair @encodeText@\/@%%u@
-- escape ↔ @decodeMangled@\/@decodeEscapes@.
vmNameRoundTripTests :: TestTree
vmNameRoundTripTests =
  testGroup
    "vmName round-trip"
    [ roundTrip "ASCII qualified" (Types.Qualified "mymodule" "foo"),
      roundTrip "non-ASCII base" (Types.Qualified "m" "naïve"),
      roundTrip "non-ASCII module" (Types.Qualified "naïve" "foo"),
      roundTrip "non-ASCII both" (Types.Qualified "café" "naïve"),
      -- Previously broken: base whose encoded form follows a non-ASCII
      -- escape with literal "u<hex>" chars, which the old "__u<HEX>__"
      -- decoder mis-split.
      roundTrip "uffï base" (Types.Qualified "mymodule" "uffï"),
      -- Previously broken: module ending in non-ASCII + literal
      -- "u<hex>". With the old encoding this collided with another
      -- (m, n) pair; the new "%%u<6 hex>" encoding is injective.
      roundTrip "fooáue module" (Types.Qualified "fooáue" "b"),
      -- Base that LOOKS like a stale "__u<HEX>__" escape but is just
      -- ASCII content past the separator.
      roundTrip "uaafoo base" (Types.Qualified "mymodule" "uaafoo"),
      -- 0-arity 'Unqualified' atoms go through 'VAtom' too.
      roundTripUnqualified "ASCII unqualified" "foo",
      roundTripUnqualified "unicode unqualified" "naïve"
    ]
  where
    roundTrip label name = testCase label $ do
      let mangled = (vmName name).unName
      t <- runChrBase (valueToTerm Map.empty (VAtom mangled))
      case t of
        CompoundTerm n [] | n == name -> pure ()
        other ->
          assertFailure $
            "Round-trip failed for "
              ++ show name
              ++ "\n  mangled = "
              ++ show mangled
              ++ "\n  got     = "
              ++ show other
    roundTripUnqualified label n = testCase label $ do
      let mangled = (vmName (Types.Unqualified n)).unName
      t <- runChrBase (valueToTerm Map.empty (VAtom mangled))
      case t of
        CompoundTerm (Types.Unqualified n') [] | n' == n -> pure ()
        other ->
          assertFailure $
            "Round-trip failed for unqualified "
              ++ show n
              ++ "\n  mangled = "
              ++ show mangled
              ++ "\n  got     = "
              ++ show other