summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xjson-template.rkt370
1 files changed, 211 insertions, 159 deletions
diff --git a/json-template.rkt b/json-template.rkt
index fe596c4..ebbe1bb 100755
--- a/json-template.rkt
+++ b/json-template.rkt
@@ -1,28 +1,86 @@
+#!r6rs
;;; -*- mode: scheme; coding: utf-8 -*-
;;; Copyright 2011, Matthias Andreas Benkard.
-#lang racket
-(provide read-template
- formatters)
+(library (json-template)
+ (export make-template
+ formatters
+ meta-left
+ meta-right
+ default-formatter
+ format-char)
+ (import (rnrs base) (rnrs programs) (rnrs unicode) (rnrs lists) (rnrs control)
+ (rnrs records syntactic) (rnrs records procedural) (rnrs records inspection)
+ (rnrs exceptions) (rnrs conditions) (rnrs io simple) (rnrs io ports) (rnrs hashtables)
+ (rnrs r5rs) (srfi :39) (srfi :28)
+ ;; Racket-specific:
+ (only (racket)
+ regexp-quote regexp-replace regexp regexp-split regexp-match)
+ (only (racket mpair)
+ list->mlist)
+
+ )
+
+ ;; Racket-specific:
+ (define pregexp-quote regexp-quote)
+ (define pregexp-split (lambda args (list->mlist (apply regexp-split args))))
+ (define pregexp regexp)
+ (define pregexp-replace regexp-replace)
+ (define pregexp-match
+ (lambda args
+ (let ([m (apply regexp-match args)])
+ (and m
+ (list->mlist m)))))
+
+(define meta-left (make-parameter "{"))
+(define meta-right (make-parameter "}"))
+(define default-formatter (make-parameter "raw"))
+(define format-char (make-parameter "|"))
+
+(define-syntax λ
+ (syntax-rules ()
+ [(_ forms ...)
+ (lambda forms ...)]))
+
+(define (dict? x)
+ (or (list? x)
+ (hashtable? x)))
+
+(define (dict-ref dict key default)
+ (let* ([default-default (cons #f #f)]
+ [result
+ (cond
+ [(list? dict)
+ (let ([result-cons (assoc key dict)])
+ (if result-cons
+ (cdr result-cons)
+ default-default))]
+ [(hashtable? dict)
+ (hashtable-ref dict key default-default)])])
+ (if (eq? result default-default)
+ (if (procedure? default)
+ (default)
+ default)
+ result)))
(define (template-string->chunks input meta-left meta-right)
- (let* ([meta-left-re (regexp-quote meta-left)]
- [meta-right-re (regexp-quote meta-right)]
+ (let* ([meta-left-re (pregexp-quote meta-left)]
+ [meta-right-re (pregexp-quote meta-right)]
[re (regexp
(string-append "(" meta-left-re ")|(" meta-right-re ")"))])
- (regexp-split re input)))
+ (pregexp-split re input)))
(define (flip-flop-map f1 f2 lst)
"Like map, but alternate between f1 and f2 as the function to apply."
- (define (flip items)
- (match items
- ['() '()]
- [(list* x xs) (cons (f1 x) (flop xs))]))
- (define (flop items)
- (match items
- ['() '()]
- [(list* x xs) (cons (f2 x) (flip xs))]))
- (flip lst))
+ (letrec ((flip (λ (items)
+ (cond
+ [(null? items)'()]
+ [else (cons (f1 (car items)) (flop (cdr items)))])))
+ (flop (λ (items)
+ (cond
+ [(null? items)'()]
+ [else (cons (f2 (car items)) (flip (cdr items)))]))))
+ (flip lst)))
(define (classify-chunks chunks format-char)
(flip-flop-map (λ (x) x)
@@ -30,51 +88,51 @@
chunks))
(define (parse-directive directive format-char)
- (match directive
- [(regexp #rx"^#")
+ (cond
+ [(pregexp-match "^#" directive)
#f]
- [(regexp #px"^\\.section\\s+(.*)$" (list _ x))
- (list 'section x)]
- [(regexp #px"^\\.repeated\\s+section\\s+(.*)$" (list _ x))
- (list 'repeated-section x)]
- [#".end"
+ [(pregexp-match "^\\.section[ \t]+(.*)$" directive)
+ => (λ (x) (list 'section (cadr x)))]
+ [(pregexp-match "^\\.repeated[ \t]+section[ \t]+(.*)$" directive)
+ => (λ (x) (list 'repeated-section (cadr x)))]
+ [(string=? ".end" directive)
(list 'end)]
- [#".or"
+ [(string=? ".or" directive)
(list 'or)]
- [(regexp #px"^\\.alternates\\s+with$")
+ [(pregexp-match "^\\.alternates\\s+with$" directive)
(list 'alternates-with)]
- [_
- (list* 'substitute (regexp-split (regexp-quote format-char)
- directive))]))
+ [else
+ (cons 'substitute (pregexp-split (pregexp-quote format-char)
+ directive))]))
(define (remove-spurious-newlines-from-token-groups groups)
(let ([last-was-directive? #f])
- (for/list ([group groups])
- (if last-was-directive?
- (begin
- (set! last-was-directive? (pair? group))
- (if (or (string? group) (bytes? group))
- (regexp-replace #rx"^\n" group "")
- group))
- (begin
- (set! last-was-directive? (pair? group))
- group)))))
+ (map
+ (λ (group)
+ (if last-was-directive?
+ (begin
+ (set! last-was-directive? (pair? group))
+ (if (string? group)
+ (pregexp-replace "^\n" group "")
+ group))
+ (begin
+ (set! last-was-directive? (pair? group))
+ group)))
+ groups)))
-(struct section
- (name
- body
- alternative)
- #:transparent)
+(define-record-type section
+ (fields (immutable name)
+ (immutable body)
+ (immutable alternative)))
-(struct repeated-section section
- (alternates-with)
- #:transparent)
+(define-record-type repeated-section
+ (parent section)
+ (fields (immutable alternates-with)))
-(struct substitution
- (name
- formatter
- arguments)
- #:transparent)
+(define-record-type substitution
+ (fields (immutable name)
+ (immutable formatter)
+ (immutable arguments)))
(define (parse-structure parsed-groups)
(let loop ([parsed-groups parsed-groups]
@@ -85,23 +143,27 @@
(values (reverse clauses)
(and (pair? parsed-groups) (caar parsed-groups))
(if (pair? parsed-groups) (cdr parsed-groups) '()))
- (match (car parsed-groups)
- [(list 'section x)
- (let-values ([(stuff reason rest)
- (parse-structure (cdr parsed-groups))])
- (case reason
- [(or)
- (let-values ([(stuff2 _ rest2)
- (parse-structure rest)])
- (loop rest2 (cons (section x stuff stuff2) clauses)))]
- [(end)
- (loop rest (cons (section x stuff #f) clauses))]))]
- [(list 'repeated-section x)
+ (let ([grp (car parsed-groups)])
+ (cond
+ [(string? grp)
+ (loop (cdr parsed-groups)
+ (cons grp clauses))]
+ [(eq? (car grp) 'section)
+ (let-values ([(stuff reason rest)
+ (parse-structure (cdr parsed-groups))])
+ (case reason
+ [(or)
+ (let-values ([(stuff2 _ rest2)
+ (parse-structure rest)])
+ (loop rest2 (cons (make-section (cadr grp) stuff stuff2) clauses)))]
+ [(end)
+ (loop rest (cons (make-section (cadr grp) stuff #f) clauses))]))]
+ [(eq? (car grp) 'repeated-section)
(let inner-loop ([subsections '()]
[rest (cdr parsed-groups)])
(let-values ([(stuff reason new-rest)
(parse-structure rest)])
- (when (false? reason)
+ (when (not reason)
(error "Premature end of file."))
(if (eq? reason 'end)
(let inner-inner-loop
@@ -110,10 +172,10 @@
[alternates-with #f])
(if (null? (cdr subsections))
(loop new-rest
- (cons (repeated-section x
- (cdar subsections)
- alternative
- alternates-with)
+ (cons (make-repeated-section (cadr grp)
+ (cdar subsections)
+ alternative
+ alternates-with)
clauses))
(case (caadr subsections)
[(alternates-with)
@@ -127,42 +189,31 @@
[else
(error "Oh no, I don't know what I'm doing here! Subsections:" subsections)])))
(inner-loop (cons (cons reason stuff) subsections) new-rest))))]
- [(list 'substitute x)
- (loop (cdr parsed-groups)
- (cons (substitution x #f '()) clauses))]
- [(list 'substitute x y arg ...)
+ [(eq? (car grp) 'substitute)
(loop (cdr parsed-groups)
- (cons (substitution x y arg) clauses))]
- [x
- (loop (cdr parsed-groups)
- (cons x clauses))]))))
+ (if (null? (cddr grp))
+ (cons (make-substitution (cadr grp) #f '()) clauses)
+ (cons (make-substitution (cadr grp) (caddr grp) (cdddr grp)) clauses)))])))))
(define (parse-structure* x)
(let-values ([(stuff reason rest) (parse-structure x)])
stuff))
-(struct template (expander)
- #:property prop:procedure (struct-field-index expander))
-
-(define (read-template #:meta-left [meta-left "{"]
- #:meta-right [meta-right "}"]
- #:default-formatter [default-formatter "raw"]
- #:format-char [format-char "|"])
+(define (make-template template-string)
(let ([template-data
(parse-structure*
(remove-spurious-newlines-from-token-groups
- (classify-chunks (template-string->chunks (current-input-port)
- meta-left meta-right)
- format-char)))])
- (template
- (λ (context)
- (expand-template template-data (list context) default-formatter)))))
+ (classify-chunks (template-string->chunks template-string
+ (meta-left) (meta-right))
+ (format-char))))])
+ (let ([default-formatter (default-formatter)])
+ (λ (context)
+ (expand-template template-data (list context) default-formatter)))))
-(define (name->path bytename)
- (let ([name (bytes->string/utf-8 bytename)])
- (if (string=? name "@")
- '()
- (regexp-split #rx"\\." name))))
+(define (name->path name)
+ (if (string=? name "@")
+ '()
+ (pregexp-split "\\." name)))
(define (resolve-path stack path)
(if (null? stack)
@@ -174,7 +225,7 @@
(resolve-path (cdr stack) path)))))
(define (resolve-path-in-object context path)
- (let ([nothing (gensym)])
+ (let ([nothing (cons #f #f)])
(cond [(null? path)
(values context #t)]
[(dict? context)
@@ -191,50 +242,49 @@
(values #f #f)])))
(define (find-formatter name)
- (cdr (assoc (if (string? name)
- name
- (bytes->string/utf-8 name))
- (formatters))))
+ (cdr (assoc name (formatters))))
(define (expand-template template stack default-formatter)
- (for ([thing template])
- (match thing
- [(repeated-section name body alternative alternates-with)
- (let ([context (resolve-path stack (name->path name))])
- (if (or (false? context)
- (null? (sequence->list context)))
- (when alternative
- (expand-template alternative
+ (for-each
+ (λ (thing)
+ (cond
+ [(repeated-section? thing)
+ (let ([context (resolve-path stack (name->path (section-name thing)))])
+ (if (or (not context)
+ (null? context))
+ (when (section-alternative thing)
+ (expand-template (section-alternative thing)
(cons context stack)
default-formatter))
(let ([first-iteration? #t])
- (for ([value context])
- (when alternates-with
+ (for-each
+ (λ (value)
+ (when (repeated-section-alternates-with thing)
(if first-iteration?
(set! first-iteration? #f)
- (expand-template alternates-with
+ (expand-template (repeated-section-alternates-with thing)
stack
default-formatter)))
- (expand-template body
+ (expand-template (section-body thing)
(cons value stack)
- default-formatter)))))]
- [(section name body alternative)
- (let ([context (resolve-path stack (name->path name))])
+ default-formatter))
+ context))))]
+ [(section? thing)
+ (let ([context (resolve-path stack (name->path (section-name thing)))])
(if context
- (expand-template body
+ (expand-template (section-body thing)
(cons context stack)
default-formatter)
- (when alternative
- (expand-template alternative
+ (when (section-alternative thing)
+ (expand-template (section-alternative thing)
(cons context stack)
default-formatter))))]
- [(substitution name formatter args)
- (display ((find-formatter (or formatter default-formatter))
- (resolve-path stack (name->path name))))]
- [_
- (display thing)])))
-
-
+ [(substitution? thing)
+ (display ((find-formatter (or (substitution-formatter thing) default-formatter))
+ (resolve-path stack (name->path (substitution-name thing)))))]
+ [else
+ (display thing)]))
+ template))
(define (make-escaper replacements)
(let* ([escapees (map car replacements)]
@@ -242,48 +292,48 @@
[re (regexp
(string-append "^(.*?)"
"(?:("
- (foldl (λ (x acc)
- (string-append acc
- ")|("
- (regexp-quote (string x))))
- (regexp-quote (string (car escapees)))
- (cdr escapees))
+ (fold-left (λ (acc x)
+ (string-append acc
+ ")|("
+ (pregexp-quote (string x))))
+ (pregexp-quote (string (car escapees)))
+ (cdr escapees))
"))"
"|$"))])
(λ (thing)
- (with-output-to-string
- (λ ()
- (with-input-from-string
- (if (string? thing)
- thing
- (format "~a" thing))
- (λ ()
- (let loop ()
- (unless (eof-object? (peek-byte))
- (match-let ([(list* _ raw-text escapee-matches)
- (regexp-match re (current-input-port))])
- (when raw-text
- (display raw-text))
- (for ([x escapee-matches]
- [y escapings])
- (when x
- (display y)))
- (loop)))))))))))
+ (call-with-string-output-port
+ (λ (out)
+ (let ([in (open-string-input-port (if (string? thing)
+ thing
+ (format "~a" thing)))])
+ (let loop ()
+ (if (eof-object? (peek-char in))
+ (values)
+ (let* ([m (pregexp-match re in)]
+ [raw-text (and m (cadr m))]
+ [escapee-matches (and m (cddr m))])
+ (when raw-text
+ (display raw-text out))
+ (for-each (λ (x y)
+ (when x
+ (display y out)))
+ escapee-matches
+ escapings)
+ (loop))))))))))
(define (escape-for-uri thing)
- (with-output-to-string
- (λ ()
- (for ([char (in-string (if (string? thing)
- thing
- (format "~a" thing)))])
+ (call-with-string-output-port
+ (λ (out)
+ (for-each
+ (λ (char)
(let ((cnum (char->integer char)))
(if (or (<= (char->integer #\A) cnum (char->integer #\Z))
(<= (char->integer #\a) cnum (char->integer #\z))
(<= (char->integer #\0) cnum (char->integer #\9))
(member char
'(#\$ #\- #\_ #\. #\+ #\! #\* #\( #\) #\')))
- (display char)
+ (display char out)
;; FIXME: This assumes that (< cnum 256).
;; Maybe we should interpret the data as a byte string
;; rather than as a string. W3C says we ought to use
@@ -292,8 +342,11 @@
;;
;; http://www.w3.org/International/O-URL-code.html
(if (< cnum 16)
- (printf "%0~x" cnum)
- (printf "%~x" cnum))))))))
+ (display (format "%0~x" cnum) out)
+ (display (format "%~x" cnum) out)))))
+ (if (string? thing)
+ thing
+ (format "~a" thing))))))
(define formatters
@@ -311,8 +364,7 @@
#;
-(let ([template (with-input-from-string
- #<<EOF
+(let ([template (make-template "
<h1>{title|html}</h1>
{.section people}
<ul>
@@ -323,10 +375,10 @@
{.or}
<p>No one's registered.</p>
{.end}
-EOF
- (λ () (read-template)))])
+")])
(template '((title . "<Registered People>")
(people .
(((name . "Nathalie") (age . 24))
((name . "Heinrich") (age . 28))
((name . "Hans") (age . 25)))))))
+)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 08:31:35 +0000