diff options
| author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-06-25 23:53:06 +0200 |
|---|---|---|
| committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-06-25 23:53:06 +0200 |
| commit | 29448dcfd0482988d3d7b7d2c06cbbaf0ee1287f (patch) | |
| tree | 49603ae543ef51a2f7b0e1fd9357e9d1a7a53348 /json-template.s6l | |
| parent | 976d5cdd3d728d9fa1e2f177f7fa400492a5bf97 (diff) | |
| parent | f634effc069bceb552f73b571f7ad016e4889b45 (diff) | |
Diffstat (limited to 'json-template.s6l')
| -rw-r--r-- | json-template.s6l | 370 |
1 files changed, 370 insertions, 0 deletions
diff --git a/json-template.s6l b/json-template.s6l new file mode 100644 index 0000000..06a591b --- /dev/null +++ b/json-template.s6l @@ -0,0 +1,370 @@ +#!r6rs
+;;; -*- mode: scheme; coding: utf-8 -*-
+;;; Copyright 2011, Matthias Andreas Benkard.
+
+(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)
+ (pregexp))
+
+
+(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 (pregexp-quote meta-left)]
+ [meta-right-re (pregexp-quote meta-right)]
+ [re (pregexp
+ (string-append "(" meta-left-re ")|(" meta-right-re ")"))])
+ (pregexp-split re input)))
+
+(define (flip-flop-map f1 f2 lst)
+ "Like map, but alternate between f1 and f2 as the function to apply."
+ (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)
+ (λ (x) (parse-directive x format-char))
+ chunks))
+
+(define (parse-directive directive format-char)
+ (cond
+ [(pregexp-match "^#" directive)
+ #f]
+ [(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)]
+ [(string=? ".or" directive)
+ (list 'or)]
+ [(pregexp-match "^\\.alternates\\s+with$" directive)
+ (list 'alternates-with)]
+ [else
+ (cons 'substitute (pregexp-split (pregexp-quote format-char)
+ directive))]))
+
+(define (remove-spurious-newlines-from-token-groups groups)
+ (let ([last-was-directive? #f])
+ (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)))
+
+(define-record-type section
+ (fields (immutable name)
+ (immutable body)
+ (immutable alternative)))
+
+(define-record-type repeated-section
+ (parent section)
+ (fields (immutable alternates-with)))
+
+(define-record-type substitution
+ (fields (immutable name)
+ (immutable formatter)
+ (immutable arguments)))
+
+(define (parse-structure parsed-groups)
+ (let loop ([parsed-groups parsed-groups]
+ [clauses '()])
+ (if (or (null? parsed-groups)
+ (and (pair? (car parsed-groups))
+ (memq (caar parsed-groups) '(end or alternates-with))))
+ (values (reverse clauses)
+ (and (pair? parsed-groups) (caar parsed-groups))
+ (if (pair? parsed-groups) (cdr parsed-groups) '()))
+ (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 (not reason)
+ (error "Premature end of file."))
+ (if (eq? reason 'end)
+ (let inner-inner-loop
+ ([subsections (cons (cons 'end stuff) subsections)]
+ [alternative #f]
+ [alternates-with #f])
+ (if (null? (cdr subsections))
+ (loop new-rest
+ (cons (make-repeated-section (cadr grp)
+ (cdar subsections)
+ alternative
+ alternates-with)
+ clauses))
+ (case (caadr subsections)
+ [(alternates-with)
+ (inner-inner-loop (cdr subsections)
+ alternative
+ (cdar subsections))]
+ [(or)
+ (inner-inner-loop (cdr subsections)
+ (cdar subsections)
+ alternates-with)]
+ [else
+ (error "Oh no, I don't know what I'm doing here! Subsections:" subsections)])))
+ (inner-loop (cons (cons reason stuff) subsections) new-rest))))]
+ [(eq? (car grp) 'substitute)
+ (loop (cdr parsed-groups)
+ (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))
+
+(define (make-template template-string)
+ (let ([template-data
+ (parse-structure*
+ (remove-spurious-newlines-from-token-groups
+ (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 name)
+ (if (string=? name "@")
+ '()
+ (pregexp-split "\\." name)))
+
+(define (resolve-path stack path)
+ (if (null? stack)
+ #f
+ (let-values ([(value success?)
+ (resolve-path-in-object (car stack) path)])
+ (if success?
+ value
+ (resolve-path (cdr stack) path)))))
+
+(define (resolve-path-in-object context path)
+ (let ([nothing (cons #f #f)])
+ (cond [(null? path)
+ (values context #t)]
+ [(dict? context)
+ (let ([y (dict-ref context
+ (car path)
+ (λ ()
+ (dict-ref context
+ (string->symbol (car path))
+ nothing)))])
+ (if (eq? y nothing)
+ (values #f #f)
+ (resolve-path-in-object y (cdr path))))]
+ [else
+ (values #f #f)])))
+
+(define (find-formatter name)
+ (cdr (assoc name (formatters))))
+
+(define (expand-template template stack default-formatter)
+ (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-each
+ (λ (value)
+ (when (repeated-section-alternates-with thing)
+ (if first-iteration?
+ (set! first-iteration? #f)
+ (expand-template (repeated-section-alternates-with thing)
+ stack
+ default-formatter)))
+ (expand-template (section-body thing)
+ (cons value stack)
+ default-formatter))
+ context))))]
+ [(section? thing)
+ (let ([context (resolve-path stack (name->path (section-name thing)))])
+ (if (and context (not (null? context)))
+ (expand-template (section-body thing)
+ (cons context stack)
+ default-formatter)
+ (when (section-alternative thing)
+ (expand-template (section-alternative thing)
+ (cons context stack)
+ default-formatter))))]
+ [(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)]
+ [escapings (map cdr replacements)]
+ [re (pregexp
+ (string-append "^(.*?)"
+ "(?:("
+ (fold-left (λ (acc x)
+ (string-append acc
+ ")|("
+ (pregexp-quote (string x))))
+ (pregexp-quote (string (car escapees)))
+ (cdr escapees))
+ "))"
+ "|$"))])
+ (λ (thing)
+ (call-with-string-output-port
+ (λ (out)
+ (let ([input (if (string? thing)
+ thing
+ (format "~a" thing))])
+ (let loop ([position 0])
+ (if (>= position (string-length input))
+ (values)
+ (let* ([m (pregexp-match re input position)]
+ [positions (pregexp-match-positions re input position)]
+ [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 (cdar positions)))))))))))
+
+
+(define (escape-for-uri 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 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
+ ;; UTF-8 encoding, which is consistent with the Racket
+ ;; default encoding:
+ ;;
+ ;; http://www.w3.org/International/O-URL-code.html
+ (if (< cnum 16)
+ (display (format "%0~x" cnum) out)
+ (display (format "%~x" cnum) out)))))
+ (if (string? thing)
+ thing
+ (format "~a" thing))))))
+
+
+(define formatters
+ (make-parameter
+ `(("html" . ,(make-escaper '((#\< . "<")
+ (#\> . ">")
+ (#\& . "&"))))
+ ("html-attr-value" . ,(make-escaper '((#\< . "<")
+ (#\> . ">")
+ (#\& . "&")
+ (#\' . "'")
+ (#\" . """))))
+ ("url-param-value" . ,escape-for-uri)
+ ("raw" . ,(λ (x) x)))))
+
+
+#;
+(let ([template (make-template "
+<h1>{title|html}</h1>
+{.section people}
+<ul>
+{.repeated section @}
+ <li>{name} ({age} years)</li>
+{.end}
+</ul>
+{.or}
+<p>No one's registered.</p>
+{.end}
+")])
+ (template '((title . "<Registered People>")
+ (people .
+ (((name . "Nathalie") (age . 24))
+ ((name . "Heinrich") (age . 28))
+ ((name . "Hans") (age . 25)))))))
+)
|