test-verify.scm

(load "gram.scm")
(load "tree.scm")
(load "phog.scm")

;; ============================================================
;; Test harness
;; ============================================================

(define *test-pass* 0)
(define *test-fail* 0)

(define (test name expected actual)
  (if (equal? expected actual)
      (begin
        (set! *test-pass* (+ *test-pass* 1))
        (printf "  PASS ~a\n" name))
      (begin
        (set! *test-fail* (+ *test-fail* 1))
        (printf "  FAIL ~a\n    expected: ~a\n    actual:   ~a\n" name expected actual))))

(define (test-summary)
  (printf "\n~a passed, ~a failed\n" *test-pass* *test-fail*)
  (when (> *test-fail* 0)
    (printf "*** ~a FAILURES ***\n" *test-fail*)))

;; ============================================================
;; Helper tests: corpus-named-children / parsed-named-children
;; ============================================================

(printf "\n=== structural verification helper tests ===\n")

(printf "\n--- corpus-named-children ---\n")

(test "corpus-named-children on expr with token"
      '((num . (num "43")) (plus . (*token* plus "+")) (num . (num "2")))
      (corpus-named-children '(expr (num "43") (*token* plus "+") (num "2"))))

(test "corpus-named-children on unary expr"
      '((num . (num "7")))
      (corpus-named-children '(expr (num "7"))))

(test "corpus-named-children skips string leaves"
      '((ident . (ident "x")) (num . (num "42")))
      (corpus-named-children '(stmt (ident "x") " = " (num "42"))))

(printf "\n--- parsed-named-children ---\n")

(test "parsed-named-children on parsed expr"
      '((num . (num #\4 #\3)) (plus . (plus #\+)) (num . (num #\2)))
      (parsed-named-children '(expr (num #\4 #\3) (plus #\+) (num #\2))))

(test "parsed-named-children on unary parsed expr"
      '((num . (num #\7)))
      (parsed-named-children '(expr (num #\7))))

(test "parsed-named-children skips chars"
      '((num . (num #\5)))
      (parsed-named-children '(expr #\( (num #\5) #\))))

;; ============================================================
;; cst-structure-match? tests
;; ============================================================

(printf "\n--- cst-structure-match? ---\n")

;; Basic matching: same structure
(test "cst-structure-match? matching expr"
      #t
      (cst-structure-match?
        '(expr (num "43") (*token* plus "+") (num "2"))
        '(expr (num #\4 #\3) (plus #\+) (num #\2))))

(test "cst-structure-match? unary expr"
      #t
      (cst-structure-match?
        '(expr (num "7"))
        '(expr (num #\7))))

;; Different child names should not match
(test "cst-structure-match? different child name"
      #f
      (cst-structure-match?
        '(expr (num "43") (*token* plus "+") (num "2"))
        '(expr (num #\4 #\3) (minus #\-) (num #\2))))

;; Different number of children should not match
(test "cst-structure-match? different child count"
      #f
      (cst-structure-match?
        '(expr (num "43") (*token* plus "+") (num "2"))
        '(expr (num #\4 #\3))))

;; Nested structure match
(test "cst-structure-match? nested nonterminals"
      #t
      (cst-structure-match?
        '(outer (inner (leaf "x")))
        '(outer (inner (leaf #\x)))))

;; Nested structure mismatch at depth
(test "cst-structure-match? nested mismatch"
      #f
      (cst-structure-match?
        '(outer (inner (leaf "x")))
        '(outer (inner (other #\x)))))

;; ============================================================
;; Full pipeline: learn-grammar + verify-grammar-structural
;; ============================================================

(printf "\n=== verify-grammar-structural on arithmetic corpus ===\n")

(define corpus
  (list
    '(expr (num "43") (*token* plus "+") (num "2"))
    '(expr (num "1") (*token* minus "-") (num "99"))
    '(expr (num "7"))
    '(expr (num "100") (*token* plus "+") (num "200"))))

(let-values (((phog-table pattern-table) (extract-phog-stats corpus)))
  (let ((grammar (learn-grammar corpus phog-table 10)))
    (printf "\nLearned grammar:\n")
    (print-grammar grammar)

    (printf "\n--- structural verification ---\n")
    (let ((results (verify-grammar-structural corpus)))
      (print-structural-verification results)

      ;; Check expr: all 4 instances should structurally match
      (let ((expr-entry (assq 'expr results)))
        (test "expr: all instances parsed"
              #t
              (and expr-entry #t))
        (test "expr: 4 total instances"
              4
              (cadr expr-entry))
        (test "expr: all match structurally"
              4
              (caddr expr-entry))
        (test "expr: 0 mismatches"
              0
              (cadddr expr-entry)))

      ;; Check num: all 7 instances should match
      (let ((num-entry (assq 'num results)))
        (test "num: all instances parsed"
              #t
              (and num-entry #t))
        (test "num: 7 total instances"
              7
              (cadr num-entry))
        (test "num: all match structurally"
              7
              (caddr num-entry))
        (test "num: 0 mismatches"
              0
              (cadddr num-entry))))))

;; ============================================================
;; Verify that structural check catches mismatches
;; ============================================================

(printf "\n=== deliberate mismatch detection ===\n")

;; A corpus node whose child names differ from what the grammar produces
;; should be detected as a mismatch. We test cst-structure-match? directly.

(test "mismatch: wrong top-level child"
      #f
      (cst-structure-match?
        '(foo (bar "x"))
        '(foo (baz #\x))))

(test "mismatch: extra child in parsed"
      #f
      (cst-structure-match?
        '(foo (bar "x"))
        '(foo (bar #\x) (extra #\y))))

(test "mismatch: extra child in corpus"
      #f
      (cst-structure-match?
        '(foo (bar "x") (*token* sep ",") (baz "y"))
        '(foo (bar #\x) (baz #\y))))

;; ============================================================
;; More complex corpus: let-statements with anonymous strings
;; ============================================================

(printf "\n=== verify-grammar-structural on let-stmt corpus ===\n")

(define corpus2
  (list
    '(let-stmt (*token* let-kw "let") " " (ident "x") " = " (num "42"))
    '(let-stmt (*token* let-kw "let") " " (ident "y") " = " (num "7"))))

(let-values (((phog-table2 pattern-table2) (extract-phog-stats corpus2)))
  (let ((grammar2 (learn-grammar corpus2 phog-table2 10)))
    (printf "\nLearned grammar:\n")
    (print-grammar grammar2)

    (printf "\n--- structural verification ---\n")
    (let ((results (verify-grammar-structural corpus2)))
      (print-structural-verification results)

      ;; let-stmt instances should parse and match structurally
      (let ((let-entry (assq 'let-stmt results)))
        (test "let-stmt: entry exists"
              #t
              (and let-entry #t))
        (when let-entry
          (test "let-stmt: 2 total instances"
                2
                (cadr let-entry))
          ;; Report results even if not all match
          (printf "    let-stmt matched: ~a/~a\n"
                  (caddr let-entry) (cadr let-entry)))))))

;; ============================================================
;; Summary
;; ============================================================

(test-summary)