;;; $Id: combinator-term-mod.scm,v 1.3 2006/02/14 03:56:42 leavens Exp $

;;; An ADT for combinator terms

;;;  <combinator-term> ::= <identifier> | S | K | I
;;;                     | (<combinator-term> <combinator-term>)

(module combinator-term-mod (lib "typedscm.ss" "typedscm")

(provide combinator-term combinator-term? var S K I capp
         S? K? I? capp? capp->rator capp->rand
         parse-combinator-term unparse-combinator-term)

(define-datatype combinator-term combinator-term?
  (var (symbol symbol?))
  (S)
  (K)
  (I)
  (capp (rator combinator-term?) (rand combinator-term?)))

(define S?
  (lambda (trm)
    (cases combinator-term trm
      (S () #t)
      (else #f))))
(define K?
  (lambda (trm)
    (cases combinator-term trm
      (K () #t)
      (else #f))))
(define I?
  (lambda (trm)
    (cases combinator-term trm
      (I () #t)
      (else #f))))

(define capp?
  (lambda (trm)
    (cases combinator-term trm
      (capp (rator rand) #t)
      (else #f))))

(define capp->rator
  (lambda (trm)
    (cases combinator-term trm
      (capp (rator rand) rator)
      (else (error "capp->rand called on non-capp term: " trm)))))

(define capp->rand
  (lambda (trm)
    (cases combinator-term trm
      (capp (rator rand) rand)
      (else (error "capp->rand called on non-capp term: " trm)))))

(deftype parse-combinator-term (-> (datum) combinator-term))
(define parse-combinator-term
  (lambda (exp)
    (test-type
      combinator-term?
      (cond
       ((symbol? exp)
        (case exp
          ((S s) (S)) ;; DrScheme can be case sensitive...
          ((K k) (K))
          ((I i) (I))
          (else (var exp))))
       ((and (list? exp) (= (length exp) 2))
        (capp (parse-combinator-term (car exp))
              (parse-combinator-term (cadr exp))))
       (else (error "parse-combinator-term: bad syntax in expression:"
                    exp))))))

(deftype unparse-combinator-term (-> (combinator-term) datum))
(define unparse-combinator-term
  (lambda (exp)
    (cases combinator-term exp
      (S () (has-type datum 'S))
      (K () (has-type datum 'K))
      (I () (has-type datum 'I))
      (var (symbol) (has-type datum symbol))
      (capp (rator rand) (list (unparse-combinator-term rator)
                               (unparse-combinator-term rand)))
      (else (error "unparse-combinator-term: Invalid abstract syntax"
                   exp)))))

) ;; end module