chez-libs/syntax-object.scm

(library (syntax-object)

;;(require "utilities.scm")
;;(require "sets.scm")

(export syx syx? syx-type syx-data syx-metadata
 	annotate annotate? annotate-syn annotate-set
	
	syx-atomic? syx-id? syx-id syx-special?
	syx-scope-set

	syn-force

	syn-car syn-cdr syn-map

	syn->datum)
(import (chezscheme)
	(only (chezscheme csv7) record-field-accessor)
	(utils) (sets))


;; This implements a representation of syntax objects
;;
;; <syntax> ::= (syx atomic <atomic> ?)
;;            | (syx id|special <symbol> ?)
;;            | ()
;;            | (<syntax> . <syntax>)
;;            | (annotate <syntax> <set>)

;; (struct syx ((type) (data) (metadata)) #:transparent)
;; (define-record syx (type data metadata))

(define %syx (make-record-type "syx" '(type data metadata)))
(define syx (record-constructor %syx))
(define syx? (record-predicate %syx))
(define syx-type (record-field-accessor %syx 'type))
(define syx-data (record-field-accessor %syx 'data))
(define syx-metadata (record-field-accessor %syx 'metadata))


;; (struct annotate ((syn) (set)) #:transparent)
;; (define-record annotate (syn set))

(define %annotate (make-record-type "annotate" '(syn set)))
(define annotate (record-constructor %annotate))
(define annotate? (record-predicate %annotate))
(define annotate-syn (record-field-accessor %annotate 'syn))
(define annotate-set (record-field-accessor %annotate 'set))



;;; Simple predicates and projections
;;

(define (syx-atomic? syn)
  (and (syx? syn) (eq? 'atomic (syx-type syn))))

(define (syx-id? syn)
  (and (syx? syn) (eq? 'id (syx-type syn))))

(define (syx-id syn)
  (unless (syx-id? syn)
	  (error 'syx-id "invalid input"))
  (syx-data syn))

(define (syx-special? syn)
  (and (syx? syn) (eq? 'special (syx-type syn))))

(define (syx-scope-set syn)
  (cond ((assoc 'set (syx-metadata syn)) => cdr)
	(else empty-set)))

;;; Pushing annotations down lazy syntax
;;

(define (syx-apply e set)
  (case (syx-type e)
    ((atomic) e)
    ((id) (syx (syx-type e)
	       (syx-data e)
	       (assoc-replace (syx-metadata e)
			      'set
			      (set-union set (syx-scope-set e)))))
    ((special) e)
    (else (error 'syx-apply "unknown type" (syx-type e)))))

(define (syn-apply syn set)
  (cond ((syx? syn) (syx-apply syn set))
	((null? syn) syn)
	((pair? syn) (cons (syn-apply (car syn) set)
			   (syn-apply (cdr syn) set)))
	((annotate? syn)
	 (syn-apply (annotate-syn syn)
		    (set-union set (annotate-set syn))))
	(else (error 'syn-apply "unknown type" syn))))

(define (syn-force s)
  (if (annotate? s)
      (let ((syn (annotate-syn s))
	    (set (annotate-set s)))
	(syn-apply syn set))
      s))

(define (syn-car e) (car (syn-force e)))
(define (syn-cdr e) (cdr (syn-force e)))
(define (syn-map f l)
  (let ((e (syn-force l)))
    (if (null? l)
	'()
	(cons (f (car l))
	      (syn-map f (cdr l))))))

;;; Present it without lots of noise for debugging
;;

(define (syn->datum syn)
  (cond ((syx? syn) (syx-data syn))
	((null? syn) syn)
	((pair? syn) (cons (syn->datum (car syn))
			   (syn->datum (cdr syn))))
	((annotate? syn) (syn->datum (annotate-syn syn)))
        ((symbol? syn) syn) ;; raw symbols are allowed inside quote
	(else (error 'syn->datum "unknown type" syn))))

)