;;; $Id: sym-exp-cooked.scm,v 1.3 2006/01/05 22:24:09 leavens Exp $
;;; 
;;; This file has a variation on the symbol-expression helpers
;;; that internally labels every symbol and s-list so that the distinctions
;;; are visible to users who look at the results. That is, the parsed form
;;; of a sym-exp is described by the following grammar. 
;;;
;;; <sym-exp> ::= (symbol <symbol>)          "symbol (symbol)"
;;;            | (s-list ( {<sym-exp>}* ))   "s-list (s-list)"
;;;
;;; However, the parsing procedures use the following external representation:
;;;
;;;  <sym-exp-external> ::= <symbol> 
;;;                      | ( {<sym-exp-external>}* )
;;;
;;; Since <sym-exp-external> is the grammar used in other sym-exp problems,
;;; and since parsing translates from <sym-exp-external> into <sym-exp>,
;;; these helping procedures to be used in any sym-exp problem.

(module sym-exp-cooked (lib "typedscm.ss" "typedscm")

(provide s-list? sym-exp? symbol s-list
        sym-exp-symbol? sym-exp-s-list? sym-exp->symbol sym-exp->s-list
        parse-sym-exp parse-s-list)

;; type predicates
(deftype sym-exp? (type-predicate-for sym-exp))
(deftype s-list? (type-predicate-for (list-of sym-exp)))

;; constructors
(deftype symbol (-> (symbol) sym-exp))
(deftype s-list (-> ((list-of sym-exp)) sym-exp))

;; case testers (discriminators)
(deftype sym-exp-symbol? (-> (sym-exp) boolean))
(deftype sym-exp-s-list? (-> (sym-exp) boolean))

;; observers
(deftype sym-exp->symbol (-> (sym-exp) symbol))
(deftype sym-exp->s-list (-> (sym-exp) (list-of sym-exp)))

;; parsing/bless input correctness
(deftype parse-sym-exp (-> (datum) sym-exp))
(deftype parse-s-list (-> (datum) (list-of sym-exp)))

(defrep (sym-exp (list-of datum)))

(define *s-list-tag* (has-type datum 's-list))
(define *symbol-tag* (has-type datum 'symbol))

(define sym-exp?
  (has-type-trusted
   (type-predicate-for sym-exp)
   (lambda (d)
     ;; ENSURES: result is true just when d represents a sym-exp
     (and (list? d)
          (= 2 (length d))
          (or (and (eq? (car d) *symbol-tag*)
                   (symbol? (cadr d)))
              (and (eq? (car d) *s-list-tag*)
                   (s-list? (cadr d))))))))

(define s-list?
  (has-type-trusted
   (type-predicate-for (list-of sym-exp))
   (lambda (d)
     ;; ENSURES: result is true just when d represents a list of sym-exps
     ((list-of sym-exp?) d))))

(define symbol
  (lambda (sym)
    ;; ENSURES: result represents a sym-exp built from sym
    (list *symbol-tag* sym)))

(define s-list
  (lambda (list-of-sym-exp)
    ;; ENSURES: result represents a sym-exp built from list-of-sym-exp
    (list *s-list-tag* list-of-sym-exp)))

(define sym-exp-symbol?
  (lambda (se)
    ;; ENSURES: result is true just when se represents a symbol
    (eq? (car se) *symbol-tag*)))

(define sym-exp-s-list?
  (lambda (se)
    ;; ENSURES: result is true just when se represents a list of sym-exps
    (eq? (car se) *s-list-tag*)))

(define sym-exp->symbol
  (lambda (se)
    ;; REQUIRES: se represents a symbol
    ;; ENSURES: result is the symbol represented by se
    (if (sym-exp-symbol? se)
        (has-type-trusted symbol (cadr se))
        (error "sym-exp->symbol: this is not a sym-exp symbol: " se))))

(define sym-exp->s-list
  (lambda (se)
    ;; REQUIRES: se represents a s-list
    ;; ENSURES: result is the s-list represented by se
    (if (sym-exp-s-list? se)
        (has-type-trusted (list-of (list-of datum)) (cadr se))
        (error "sym-exp->s-list: this is not a sym-exp s-list: " se))))

(define parse-sym-exp
  (lambda (exp)
    ;; ENSURES: if exp has the syntax of a sym-exp,
    ;;          then result is the representation of exp
    ;;          otherwise an error message is given.
    (cond
     ((symbol? exp) (symbol (has-type-trusted symbol exp)))
     ((list? exp)
      (s-list (parse-s-list exp)))
     (else (error "parse-sym-exp: bad syntax: " exp)))))

(define parse-s-list
  (lambda (exp)
    ;; ENSURES: if exp has the syntax of a list of sym-exp,
    ;;          then result is the representation of exp as a list of sym-exps,
    ;;          otherwise an error message is given.
    (cond
     ((list? exp)
      (map parse-sym-exp (has-type-trusted (list-of datum) exp)))
     (else (error "parse-s-list: bad syntax: " exp)))))

) ;; end module