107 lines
3.7 KiB
Scheme
107 lines
3.7 KiB
Scheme
(define (default-writer obj out)
|
|
(when obj
|
|
(display obj out)))
|
|
|
|
(define default-lookup
|
|
(compose-lookups
|
|
alist-lookup))
|
|
|
|
(define default-collection
|
|
(compose-collections
|
|
vector-collection
|
|
stream-collection))
|
|
|
|
(define (port->string port)
|
|
(define str
|
|
(let loop ((chunks '())
|
|
(chunk (read-string 2000 port)))
|
|
(if (eof-object? chunk)
|
|
(apply string-append (reverse chunks))
|
|
(loop (cons chunk chunks)
|
|
(read-string 2000 port)))))
|
|
(close-input-port port)
|
|
str)
|
|
|
|
(define (template-get-partials template)
|
|
(define partials
|
|
(let loop ((template template)
|
|
(parts '()))
|
|
(cond
|
|
((null? template) parts)
|
|
(else (let ((t (car template))
|
|
(rest (cdr template)))
|
|
(cond
|
|
((partial? t) (loop rest
|
|
(cons (partial-name t) parts)))
|
|
((section? t) (loop rest
|
|
(append (template-get-partials (section-content t))
|
|
parts)))
|
|
(else (loop rest
|
|
parts))))))))
|
|
(delete-duplicates! partials))
|
|
|
|
(define compile
|
|
(case-lambda
|
|
((template) (compile/without-partials template))
|
|
((root partial-locator) (compile/with-partials root partial-locator))))
|
|
|
|
(define (compile/without-partials template)
|
|
(compile/with-partials #f (lambda (partial)
|
|
(if partial
|
|
#f
|
|
template))))
|
|
|
|
(define (compile/with-partials root partial-locator)
|
|
|
|
;; returns 2 values: missing partials (found in part) and compiled part template
|
|
(define (compile-part part resolved-partials)
|
|
(define source (partial-locator part))
|
|
(define in (cond
|
|
((not source) "")
|
|
((string? source) source)
|
|
((port? source) (port->string source))
|
|
(else (error "Partial locator returned unrecognized type"))))
|
|
(define template (parse (read-tokens in)))
|
|
(define partials (template-get-partials template))
|
|
(define missing-partials (lset-difference string=? partials resolved-partials))
|
|
(values missing-partials template))
|
|
|
|
(let loop ((unresolved (list root))
|
|
(resolved-map '())
|
|
(resolved-lst '()))
|
|
(cond
|
|
((null? unresolved) (cons root resolved-map))
|
|
(else (let ((part (car unresolved)))
|
|
(define-values (unresolved* template)
|
|
(compile-part part resolved-lst))
|
|
(loop (append unresolved* (cdr unresolved))
|
|
(cons (cons part template) resolved-map)
|
|
(cons part resolved-lst)))))))
|
|
|
|
(define current-lookup (make-parameter default-lookup))
|
|
(define current-collection (make-parameter default-collection))
|
|
(define current-writer (make-parameter default-writer))
|
|
|
|
(define execute
|
|
(case-lambda
|
|
((compilation data)
|
|
(let ((out (open-output-string)))
|
|
(execute compilation data out)
|
|
(get-output-string out)))
|
|
((compilation data out)
|
|
(define root (car compilation))
|
|
(define partials (cdr compilation))
|
|
(define template (cdr (assoc root partials)))
|
|
(define lookup (current-lookup))
|
|
(define collection* (current-collection))
|
|
(define writer (current-writer))
|
|
(executor-execute template
|
|
(list data)
|
|
partials
|
|
out
|
|
lookup
|
|
(collection-pred-proc collection*)
|
|
(collection-empty?-proc collection*)
|
|
(collection-for-each-proc collection*)
|
|
writer))))
|