;; lib/maude/tests/parse.sx — Phase 1: tokenizer, signatures, term/eq parsing.

(define mpt-pass 0)
(define mpt-fail 0)
(define mpt-failures (list))

(define
  mpt-check!
  (fn
    (name got expected)
    (if
      (= got expected)
      (set! mpt-pass (+ mpt-pass 1))
      (do
        (set! mpt-fail (+ mpt-fail 1))
        (append!
          mpt-failures
          (str name "  expected: " expected "  got: " got))))))

;; ---- modules under test ----

(define
  mpt-peano
  (mau/parse-module
    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm prec 33] .\n  op _*_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + X = X .\n  eq s X + Y = s (X + Y) .\n  eq 0 * X = 0 .\nendfm"))

(define
  mpt-natlist
  (mau/parse-module
    "fmod NATLIST is\n  sorts Zero NzNat Nat List .\n  subsort Zero < Nat .\n  subsort NzNat < Nat .\n  subsort Nat < List .\n  op 0 : -> Zero .\n  op nil : -> List .\n  op _;_ : List List -> List [assoc id: nil] .\n  op head : List -> Nat .\n  op length : List -> Nat .\n  vars L M : List .\n  var N : Nat .\n  eq length(nil) = 0 .\n  eq head(N ; L) = N .\nendfm"))

;; ---- tokenizer ----

(define mpt-toks (mau/tokenize "op _+_ : Nat Nat -> Nat [assoc] ."))

(mpt-check! "tok-count" (len mpt-toks) 11)
(mpt-check! "tok-op" (nth mpt-toks 0) "op")
(mpt-check! "tok-mixfix" (nth mpt-toks 1) "_+_")
(mpt-check! "tok-colon" (nth mpt-toks 2) ":")
(mpt-check! "tok-arrow" (nth mpt-toks 5) "->")
(mpt-check! "tok-lbrack" (nth mpt-toks 7) "[")
(mpt-check! "tok-dot" (nth mpt-toks 10) ".")
(mpt-check!
  "tok-comment"
  (len (mau/tokenize "sort Nat . --- a comment\nop 0 : -> Nat ."))
  9)

;; ---- mixfix classification ----

(mpt-check! "form-infix" (get (mau/op-form "_+_") :kind) "infix")
(mpt-check! "form-infix-tok" (get (mau/op-form "_+_") :token) "+")
(mpt-check! "form-prefix" (get (mau/op-form "s_") :kind) "prefix")
(mpt-check! "form-prefix-tok" (get (mau/op-form "s_") :token) "s")
(mpt-check! "form-postfix" (get (mau/op-form "_!") :kind) "postfix")
(mpt-check! "form-const" (get (mau/op-form "nil") :kind) "const")
(mpt-check!
  "form-mixfix"
  (get (mau/op-form "if_then_else_fi") :kind)
  "mixfix")

;; ---- module header / sorts ----

(mpt-check! "mod-name" (mau/module-name mpt-peano) "PEANO")
(mpt-check! "mod-kind" (mau/module-kind mpt-peano) "fmod")
(mpt-check! "mod-sorts" (mau/module-sorts mpt-peano) (list "Nat"))
(mpt-check!
  "natlist-sorts-count"
  (len (mau/module-sorts mpt-natlist))
  4)

;; ---- subsorts (direct + transitive) ----

(mpt-check! "subsort-direct" (mau/subsort? mpt-natlist "NzNat" "Nat") true)
(mpt-check! "subsort-trans" (mau/subsort? mpt-natlist "NzNat" "List") true)
(mpt-check! "subsort-trans2" (mau/subsort? mpt-natlist "Zero" "List") true)
(mpt-check! "subsort-none" (mau/subsort? mpt-natlist "List" "Nat") false)
(mpt-check! "sort<=-refl" (mau/sort<=? mpt-natlist "Nat" "Nat") true)
(mpt-check! "sort<=-trans" (mau/sort<=? mpt-natlist "Zero" "List") true)

;; ---- operators / overloading ----

(mpt-check! "ops-count" (len (mau/module-ops mpt-peano)) 4)
(mpt-check!
  "op-arity"
  (get (first (mau/ops-named mpt-peano "_+_")) :arity)
  (list "Nat" "Nat"))
(mpt-check!
  "op-result"
  (get (first (mau/ops-named mpt-peano "s_")) :result)
  "Nat")
(mpt-check!
  "op-const-arity"
  (len (get (first (mau/ops-named mpt-peano "0")) :arity))
  0)
(mpt-check!
  "natlist-ops-count"
  (len (mau/module-ops mpt-natlist))
  5)

;; ---- attributes ----

(mpt-check!
  "attr-assoc"
  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :assoc)
  true)
(mpt-check!
  "attr-comm"
  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :comm)
  true)
(mpt-check!
  "attr-prec"
  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :prec)
  33)
(mpt-check!
  "attr-id"
  (get (get (first (mau/ops-named mpt-natlist "_;_")) :attrs) :id)
  "nil")
(mpt-check!
  "attr-absent"
  (get (get (first (mau/ops-named mpt-peano "_*_")) :attrs) :prec)
  nil)

;; ---- variables ----

(mpt-check! "var-sort" (get (mau/module-vars mpt-peano) "X") "Nat")
(mpt-check! "var-list-sort" (get (mau/module-vars mpt-natlist) "L") "List")

;; ---- term parsing ----

(mpt-check!
  "term-const"
  (mau/term->str (mau/parse-term-in mpt-peano "0"))
  "0")
(mpt-check!
  "term-prefix-mixfix"
  (mau/term->str (mau/parse-term-in mpt-peano "s 0"))
  "s_(0)")
(mpt-check!
  "term-nested-prefix"
  (mau/term->str (mau/parse-term-in mpt-peano "s s 0"))
  "s_(s_(0))")
(mpt-check!
  "term-infix"
  (mau/term->str (mau/parse-term-in mpt-peano "X + Y"))
  "_+_(X, Y)")
(mpt-check!
  "term-prec"
  (mau/term->str (mau/parse-term-in mpt-peano "s X + Y"))
  "_+_(s_(X), Y)")
(mpt-check!
  "term-paren"
  (mau/term->str (mau/parse-term-in mpt-peano "s (X + Y)"))
  "s_(_+_(X, Y))")
(mpt-check!
  "term-left-assoc"
  (mau/term->str (mau/parse-term-in mpt-peano "X + Y + X"))
  "_+_(_+_(X, Y), X)")
(mpt-check!
  "term-prefix-form"
  (mau/term->str (mau/parse-term-in mpt-peano "_+_(X, 0)"))
  "_+_(X, 0)")
(mpt-check!
  "term-funcall"
  (mau/term->str (mau/parse-term-in mpt-natlist "length(nil)"))
  "length(nil)")
(mpt-check!
  "term-onthefly-var"
  (mau/var? (mau/parse-term-in mpt-peano "Z:Nat"))
  true)
(mpt-check!
  "term-onthefly-sort"
  (mau/vsort (mau/parse-term-in mpt-peano "Z:Nat"))
  "Nat")
(mpt-check!
  "term-var-vs-const"
  (mau/var? (mau/parse-term-in mpt-peano "X"))
  true)
(mpt-check!
  "term-const-not-var"
  (mau/var? (mau/parse-term-in mpt-peano "0"))
  false)

;; ---- equations ----

(mpt-check! "eq-count" (len (mau/module-eqs mpt-peano)) 3)
(mpt-check!
  "eq-lhs"
  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :lhs))
  "_+_(s_(X), Y)")
(mpt-check!
  "eq-rhs"
  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :rhs))
  "s_(_+_(X, Y))")
(mpt-check!
  "eq-uncond"
  (get (nth (mau/module-eqs mpt-peano) 0) :cond)
  nil)
(mpt-check!
  "natlist-eq-head"
  (mau/term->str (get (nth (mau/module-eqs mpt-natlist) 1) :lhs))
  "head(_;_(N, L))")

;; ---- conditional equations ----

(define
  mpt-gcd
  (mau/parse-module
    "fmod GCD is\n  sort Nat .\n  op _>_ : Nat Nat -> Bool .\n  op _-_ : Nat Nat -> Nat .\n  op gcd : Nat Nat -> Nat .\n  vars X Y : Nat .\n  ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\nendfm"))

(mpt-check! "ceq-count" (len (mau/module-eqs mpt-gcd)) 1)
(mpt-check!
  "ceq-has-cond"
  (= (get (first (mau/module-eqs mpt-gcd)) :cond) nil)
  false)
(mpt-check!
  "ceq-cond-kind"
  (get (get (first (mau/module-eqs mpt-gcd)) :cond) :kind)
  "eq")
(mpt-check!
  "ceq-cond-lhs"
  (mau/term->str (get (get (first (mau/module-eqs mpt-gcd)) :cond) :lhs))
  "_>_(X, Y)")

;; ---- system module + rules ----

(define
  mpt-vending
  (mau/parse-module
    "mod VENDING is\n  sort State .\n  op _coin : State -> State .\n  op buy : State -> State .\n  var S : State .\n  rl [insert] : S coin => buy(S) .\n  crl [guard] : buy(S) => S if S = S .\nendfm"))

(mpt-check! "mod-kind-mod" (mau/module-kind mpt-vending) "mod")
(mpt-check! "rules-count" (len (mau/module-rules mpt-vending)) 2)
(mpt-check!
  "rule-label"
  (get (first (mau/module-rules mpt-vending)) :label)
  "insert")
(mpt-check!
  "rule-rhs"
  (mau/term->str (get (first (mau/module-rules mpt-vending)) :rhs))
  "buy(S)")
(mpt-check!
  "crl-label"
  (get (nth (mau/module-rules mpt-vending) 1) :label)
  "guard")
(mpt-check!
  "crl-cond-kind"
  (get (get (nth (mau/module-rules mpt-vending) 1) :cond) :kind)
  "eq")

(define mau-parse-tests-run! (fn () {:failures mpt-failures :total (+ mpt-pass mpt-fail) :passed mpt-pass :failed mpt-fail}))