;; lib/maude/sorts.sx — order-sorted least-sort inference.
;;
;; Order-sorted signatures: subsorts induce a partial order on sorts, and an
;; overloaded operator can have several declarations. The LEAST SORT of a term
;; is the smallest result sort among the operator declarations whose argument
;; sorts the actual arguments satisfy (modulo subsorting). This is what lets
;; `f(1)` be a NzNat while `f(s 0)` is only a Nat when f is declared at both.
;;
;;   mau/term-sort   M T        -> least sort of T (string, "?" if unknown)
;;   mau/has-sort?   M T SORT   -> does T's least sort fit under SORT?

(define
  mau/arg-sorts-ok?
  (fn
    (m argsorts declared)
    (cond
      ((and (empty? argsorts) (empty? declared)) true)
      ((or (empty? argsorts) (empty? declared)) false)
      ((mau/sort<=? m (first argsorts) (first declared))
        (mau/arg-sorts-ok? m (rest argsorts) (rest declared)))
      (else false))))

(define
  mau/matching-ops
  (fn
    (m name argsorts)
    (filter
      (fn
        (op)
        (and
          (= (len (get op :arity)) (len argsorts))
          (mau/arg-sorts-ok? m argsorts (get op :arity))))
      (mau/ops-named m name))))

(define
  mau/least-loop
  (fn
    (m best rst)
    (cond
      ((empty? rst) best)
      ((mau/sort<=? m (first rst) best)
        (mau/least-loop m (first rst) (rest rst)))
      (else (mau/least-loop m best (rest rst))))))

(define
  mau/least-sort
  (fn
    (m sorts)
    (if (empty? sorts) "?" (mau/least-loop m (first sorts) (rest sorts)))))

(define
  mau/result-sort
  (fn
    (m name argsorts)
    (let
      ((cands (mau/matching-ops m name argsorts)))
      (if
        (empty? cands)
        (let
          ((any (mau/ops-named m name)))
          (if (empty? any) "?" (get (first any) :result)))
        (mau/least-sort m (map (fn (op) (get op :result)) cands))))))

(define
  mau/term-sort
  (fn
    (m t)
    (cond
      ((mau/var? t) (mau/vsort t))
      ((mau/app? t)
        (mau/result-sort
          m
          (mau/op t)
          (map (fn (a) (mau/term-sort m a)) (mau/args t))))
      (else "?"))))

(define
  mau/term-sort-src
  (fn (m src) (mau/term-sort m (mau/parse-term-in m src))))

(define
  mau/has-sort?
  (fn (m t sort) (mau/sort<=? m (mau/term-sort m t) sort)))

(define
  mau/has-sort-src?
  (fn (m src sort) (mau/has-sort? m (mau/parse-term-in m src) sort)))