rose-ash/lib/haskell/tests/parse.sx

;; Haskell parser / tokenizer tests.
;;
;; Lightweight runner: each test checks actual vs expected with
;; structural (deep) equality and accumulates pass/fail counters.
;; Final value of this file is a summary dict with :pass :fail :fails.

(define
  hk-deep=?
  (fn
    (a b)
    (cond
      ((= a b) true)
      ((and (dict? a) (dict? b))
        (let
          ((ak (keys a)) (bk (keys b)))
          (if
            (not (= (len ak) (len bk)))
            false
            (every?
              (fn
                (k)
                (and (has-key? b k) (hk-deep=? (get a k) (get b k))))
              ak))))
      ((and (list? a) (list? b))
        (if
          (not (= (len a) (len b)))
          false
          (let
            ((i 0) (ok true))
            (define
              hk-de-loop
              (fn
                ()
                (when
                  (and ok (< i (len a)))
                  (do
                    (when
                      (not (hk-deep=? (nth a i) (nth b i)))
                      (set! ok false))
                    (set! i (+ i 1))
                    (hk-de-loop)))))
            (hk-de-loop)
            ok)))
      (:else false))))

(define hk-test-pass 0)
(define hk-test-fail 0)
(define hk-test-fails (list))

(define
  hk-test
  (fn
    (name actual expected)
    (if
      (hk-deep=? actual expected)
      (set! hk-test-pass (+ hk-test-pass 1))
      (do
        (set! hk-test-fail (+ hk-test-fail 1))
        (append! hk-test-fails {:actual actual :expected expected :name name})))))

;; Convenience: tokenize and drop newline + eof tokens so tests focus
;; on meaningful content. Returns list of {:type :value} pairs.
(define
  hk-toks
  (fn
    (src)
    (map
      (fn (tok) {:value (get tok "value") :type (get tok "type")})
      (filter
        (fn
          (tok)
          (let
            ((ty (get tok "type")))
            (not (or (= ty "newline") (= ty "eof")))))
        (hk-tokenize src)))))

;; ── 1. Identifiers & reserved words ──
(hk-test "varid simple" (hk-toks "foo") (list {:value "foo" :type "varid"}))

(hk-test
  "varid with digits and prime"
  (hk-toks "foo123' bar2")
  (list {:value "foo123'" :type "varid"} {:value "bar2" :type "varid"}))

(hk-test "conid" (hk-toks "Maybe") (list {:value "Maybe" :type "conid"}))

(hk-test "reserved: where" (hk-toks "where") (list {:value "where" :type "reserved"}))

(hk-test
  "reserved: case of"
  (hk-toks "case of")
  (list {:value "case" :type "reserved"} {:value "of" :type "reserved"}))

(hk-test "underscore is reserved" (hk-toks "_") (list {:value "_" :type "reserved"}))

;; ── 2. Qualified names ──
(hk-test "qvarid" (hk-toks "Data.Map.lookup") (list {:value "Data.Map.lookup" :type "qvarid"}))

(hk-test "qconid" (hk-toks "Data.Map") (list {:value "Data.Map" :type "qconid"}))

(hk-test "qualified operator" (hk-toks "Prelude.+") (list {:value "Prelude.+" :type "varsym"}))

;; ── 3. Numbers ──
(hk-test "integer" (hk-toks "42") (list {:value 42 :type "integer"}))

(hk-test "hex" (hk-toks "0x2A") (list {:value 42 :type "integer"}))

(hk-test "octal" (hk-toks "0o17") (list {:value 15 :type "integer"}))

(hk-test "float" (hk-toks "3.14") (list {:value 3.14 :type "float"}))

(hk-test "float with exp" (hk-toks "1.5e-3") (list {:value 0.0015 :type "float"}))

;; ── 4. Strings / chars ──
(hk-test "string" (hk-toks "\"hello\"") (list {:value "hello" :type "string"}))

(hk-test "char" (hk-toks "'a'") (list {:value "a" :type "char"}))

(hk-test "char escape newline" (hk-toks "'\\n'") (list {:value "\n" :type "char"}))

(hk-test "string escape" (hk-toks "\"a\\nb\"") (list {:value "a\nb" :type "string"}))

;; ── 5. Operators ──
(hk-test "operator +" (hk-toks "+") (list {:value "+" :type "varsym"}))

(hk-test "operator >>=" (hk-toks ">>=") (list {:value ">>=" :type "varsym"}))

(hk-test "consym" (hk-toks ":+:") (list {:value ":+:" :type "consym"}))

(hk-test "reservedop ->" (hk-toks "->") (list {:value "->" :type "reservedop"}))

(hk-test "reservedop =>" (hk-toks "=>") (list {:value "=>" :type "reservedop"}))

(hk-test "reservedop .. (range)" (hk-toks "..") (list {:value ".." :type "reservedop"}))

(hk-test "reservedop backslash" (hk-toks "\\") (list {:value "\\" :type "reservedop"}))

;; ── 6. Punctuation ──
(hk-test "parens" (hk-toks "( )") (list {:value "(" :type "lparen"} {:value ")" :type "rparen"}))

(hk-test "brackets" (hk-toks "[]") (list {:value "[" :type "lbracket"} {:value "]" :type "rbracket"}))

(hk-test "braces" (hk-toks "{}") (list {:value "{" :type "lbrace"} {:value "}" :type "rbrace"}))

(hk-test
  "backtick"
  (hk-toks "`mod`")
  (list {:value "`" :type "backtick"} {:value "mod" :type "varid"} {:value "`" :type "backtick"}))

(hk-test "comma and semi" (hk-toks ",;") (list {:value "," :type "comma"} {:value ";" :type "semi"}))

;; ── 7. Comments ──
(hk-test "line comment stripped" (hk-toks "-- a comment") (list))

(hk-test "line comment before code" (hk-toks "-- c\nfoo") (list {:value "foo" :type "varid"}))

(hk-test
  "block comment stripped"
  (hk-toks "{- block -} foo")
  (list {:value "foo" :type "varid"}))

(hk-test
  "nested block comment"
  (hk-toks "{- {- nested -} -} x")
  (list {:value "x" :type "varid"}))

(hk-test
  "-- inside operator is comment in Haskell"
  (hk-toks "-->")
  (list {:value "-->" :type "varsym"}))

;; ── 8. Mixed declarations ──
(hk-test
  "type signature"
  (hk-toks "main :: IO ()")
  (list {:value "main" :type "varid"} {:value "::" :type "reservedop"} {:value "IO" :type "conid"} {:value "(" :type "lparen"} {:value ")" :type "rparen"}))

(hk-test
  "data declaration"
  (hk-toks "data Maybe a = Nothing | Just a")
  (list
    {:value "data" :type "reserved"}
    {:value "Maybe" :type "conid"}
    {:value "a" :type "varid"}
    {:value "=" :type "reservedop"}
    {:value "Nothing" :type "conid"}
    {:value "|" :type "reservedop"}
    {:value "Just" :type "conid"}
    {:value "a" :type "varid"}))

(hk-test
  "lambda"
  (hk-toks "\\x -> x + 1")
  (list {:value "\\" :type "reservedop"} {:value "x" :type "varid"} {:value "->" :type "reservedop"} {:value "x" :type "varid"} {:value "+" :type "varsym"} {:value 1 :type "integer"}))

(hk-test
  "let expression"
  (hk-toks "let x = 1 in x + x")
  (list
    {:value "let" :type "reserved"}
    {:value "x" :type "varid"}
    {:value "=" :type "reservedop"}
    {:value 1 :type "integer"}
    {:value "in" :type "reserved"}
    {:value "x" :type "varid"}
    {:value "+" :type "varsym"}
    {:value "x" :type "varid"}))

(hk-test
  "case expr"
  (hk-toks "case x of Just y -> y")
  (list
    {:value "case" :type "reserved"}
    {:value "x" :type "varid"}
    {:value "of" :type "reserved"}
    {:value "Just" :type "conid"}
    {:value "y" :type "varid"}
    {:value "->" :type "reservedop"}
    {:value "y" :type "varid"}))

(hk-test
  "list literal"
  (hk-toks "[1, 2, 3]")
  (list
    {:value "[" :type "lbracket"}
    {:value 1 :type "integer"}
    {:value "," :type "comma"}
    {:value 2 :type "integer"}
    {:value "," :type "comma"}
    {:value 3 :type "integer"}
    {:value "]" :type "rbracket"}))

(hk-test
  "range syntax"
  (hk-toks "[1..10]")
  (list {:value "[" :type "lbracket"} {:value 1 :type "integer"} {:value ".." :type "reservedop"} {:value 10 :type "integer"} {:value "]" :type "rbracket"}))

;; ── 9. Positions ──
(hk-test
  "line/col positions"
  (let
    ((toks (hk-tokenize "foo\n  bar")))
    (list
      (get (nth toks 0) "line")
      (get (nth toks 0) "col")
      (get (nth toks 2) "line")
      (get (nth toks 2) "col")))
  (list 1 1 2 3))

;; ── Summary — final value of this file ──
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}