67 lines
2.1 KiB
Scheme
67 lines
2.1 KiB
Scheme
(declare (unit templates))
|
|
|
|
(import
|
|
brev-separate
|
|
(chicken plist)
|
|
fmt
|
|
regex
|
|
srfi-1 ; list routines
|
|
tree)
|
|
|
|
(define (register-template name)
|
|
(put! name 'sex-template #t))
|
|
|
|
(define-syntax template
|
|
(syntax-rules ()
|
|
((template (name . args) . body)
|
|
(begin
|
|
(register-template 'name)
|
|
(define-syntax name
|
|
(syntax-rules ()
|
|
((name . applied-args)
|
|
(let* ((subst-alist (map cons 'args 'applied-args))
|
|
(replaced-body (apply-substitution `body subst-alist)))
|
|
replaced-body))))))))
|
|
|
|
(define (apply-symbol-substitution sym subst-alist)
|
|
;; All non-symbol substitutions will be filtered.
|
|
;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
|
|
;; only ((U . w) (W . e)) will be applied to symbols.
|
|
(let ((str (symbol->string sym))
|
|
(subst-map (map (fn
|
|
(if (symbol? (car x))
|
|
(cons
|
|
(fmt #f "([^\\-]?)"
|
|
(regexp-escape (symbol->string (car x)))
|
|
"([\\-$]?)")
|
|
(fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
|
|
x))
|
|
(filter (fn (symbol? (cdr x))) subst-alist))))
|
|
(string->symbol
|
|
(string-substitute* str subst-map))))
|
|
|
|
(define (maybe-replace-symbol sym subst-alist)
|
|
(call/cc
|
|
(lambda (return)
|
|
(for-each (fn (when (eq? (car x) sym)
|
|
(return (cdr x))))
|
|
subst-alist)
|
|
(return sym))))
|
|
|
|
(define (apply-substitution target subst-alist)
|
|
;; Subsitute free symbols and -/$/^ separated parts
|
|
;; of symbols with provided forms.
|
|
;; E.g. with substitution (T int):
|
|
;; list-T -> list-int ; by apply-symbol-substitution
|
|
;; (var T data) -> (var int data) ; by maybe-replace-symbol
|
|
;; see respective functions for further details.
|
|
(tree-map
|
|
(fn
|
|
(if (symbol? x)
|
|
(let ((st (maybe-replace-symbol x subst-alist)))
|
|
(if (eq? st x)
|
|
(apply-symbol-substitution x subst-alist)
|
|
st))
|
|
x))
|
|
target))
|