From 395d8a112550a43c7ee9dcfbadee491d4a1efb8c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 16 Jun 2011 23:38:51 +0200 Subject: Initial commit. --- json-template.rkt | 375 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 375 insertions(+) create mode 100644 json-template.rkt diff --git a/json-template.rkt b/json-template.rkt new file mode 100644 index 0000000..7d9f4c9 --- /dev/null +++ b/json-template.rkt @@ -0,0 +1,375 @@ +;;; -*- mode: scheme; coding: utf-8 -*- +;;; Copyright 2011, Matthias Andreas Benkard. +#lang racket + +(provide read-template + formatters) + +;;(define (prepare-input in) +;; (regexp-replace* #rx"\n({[^}]*})\n" (port->string in) "\\1")) + +(define (read-and-tokenize meta-left meta-right format-char) + (let* ([meta-left-re (regexp-quote meta-left)] + [meta-right-re (regexp-quote meta-right)] + [format-char-re (regexp-quote format-char)] + [re (regexp + (string-append "(.*?)" ;raw text + "(?:" + "(" meta-left-re ")|" + "(" meta-right-re ")|" + "(" format-char-re ")" + ")" + ;; --- if nothing matches: --- + "|(.*)$"))]) + (let loop ([tokens '()]) + (match-let ([(list _ raw-text meta-left? meta-right? format-char? alternative) + (regexp-match re (current-input-port))]) + (cond + [meta-left? + (loop (list* 'meta-left raw-text tokens))] + [meta-right? + (loop (list* 'meta-right raw-text tokens))] + [format-char? + (loop (list* 'format-char raw-text tokens))] + [alternative + (reverse (list* alternative tokens))] + [else + (error "JSON Template: Failed tokenizing input.")]))))) + +(define (group-tokens tokens meta-left meta-right format-char) + (let loop ([tokens tokens] + [groups '()] + [current-group #f]) + (if (null? tokens) + (reverse (if current-group (cons (reverse current-group) groups) groups)) + (let ([token (car tokens)]) + (if current-group + (case token + [(meta-right) + (loop (cdr tokens) (cons (reverse current-group) groups) #f)] + ;; format-char is discarded since its only purpose was + ;; to separate the captured strings. + [(format-char) + (loop (cdr tokens) groups current-group)] + [else + (loop (cdr tokens) groups (cons token current-group))]) + (case token + [(meta-left) + (loop (cdr tokens) groups '())] + [(format-char) + (loop (cdr tokens) (cons format-char groups) #f)] + [(meta-right) + (loop (cdr tokens) (cons meta-right groups) #f)] + [else + (loop (cdr tokens) (cons token groups) #f)])))))) + +(define (parse-token-groups groups) + (filter (λ (x) x) + (map (λ (group) + (if (list? group) + (match (car group) + [(regexp #rx"^#") + #f] + [(regexp #px"^\\.section\\s+(.*)$" (list _ x)) + (list 'section x)] + [(regexp #px"^\\.repeated\\s+section\\s+(.*)$" (list _ x)) + (list 'repeated-section x)] + [#".end" + (list 'end)] + [#".or" + (list 'or)] + [(regexp #px"^\\.alternates\\s+with$") + (list 'alternates-with)] + [_ + (list* 'substitute group)]) + group)) + groups))) + +(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))))) + +(struct section + (name + body + alternative) + #:transparent) + +(struct repeated-section section + (alternates-with) + #:transparent) + +(struct substitution + (name + formatter + arguments) + #:transparent) + +(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) '())) + (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 inner-loop ([subsections '()] + [rest (cdr parsed-groups)]) + (let-values ([(stuff reason new-rest) + (parse-structure rest)]) + (when (false? 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 (repeated-section x + (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))))] + [(list 'substitute x) + (loop (cdr parsed-groups) + (cons (substitution x #f '()) clauses))] + [(list 'substitute x y arg ...) + (loop (cdr parsed-groups) + (cons (substitution x y arg) clauses))] + [x + (loop (cdr parsed-groups) + (cons x clauses))])))) + +(define (parse-structure* x) + (let-values ([(stuff reason rest) (parse-structure x)]) + stuff)) + +(define (read-template #:meta-left [meta-left "{"] + #:meta-right [meta-right "}"] + #:default-formatter [default-formatter "raw"] + #:format-char [format-char "|"]) + (let ([template + (parse-structure* + (remove-spurious-newlines-from-token-groups + (parse-token-groups + (group-tokens + (read-and-tokenize meta-left meta-right format-char) + meta-left + meta-right + format-char))))]) + (λ (context) + (expand-template template (list context) default-formatter)))) + +(define (name->path bytename) + (let ([name (bytes->string/utf-8 bytename)]) + (if (string=? name "@") + '() + (regexp-split #rx"\\." 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 (gensym)]) + (if (null? path) + (values context #t) + (cond + [(hash? context) + (let ([y (hash-ref context (car path) nothing)]) + (if (eq? y nothing) + (values #f #f) + (resolve-path-in-object y (cdr path))))] + [(list? context) + (let* ([x (car path)] + [y (assf (λ (key) + (or (and (symbol? key) + (string=? (symbol->string key) x)) + (and (string? key) + (string=? key x)))) + context)]) + (if y + (resolve-path-in-object (cdr y) (cdr path)) + (values #f #f)))] + [else + (values #f #f)])))) + +(define (find-formatter name) + (cdr (assoc (if (string? name) + name + (bytes->string/utf-8 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 + (cons context stack) + default-formatter)) + (let ([first-iteration? #t]) + (for ([value context]) + (when alternates-with + (if first-iteration? + (set! first-iteration? #f) + (expand-template alternates-with + stack + default-formatter))) + (expand-template body + (cons value stack) + default-formatter)))))] + [(section name body alternative) + (let ([context (resolve-path stack (name->path name))]) + (if context + (expand-template body + (cons context stack) + default-formatter) + (when alternative + (expand-template alternative + (cons context stack) + default-formatter))))] + [(substitution name formatter args) + (display ((find-formatter (or formatter default-formatter)) + (resolve-path stack (name->path name))))] + [_ + (display thing)]))) + + + +(define (make-escaper replacements) + (let* ([escapees (map car replacements)] + [escapings (map cdr replacements)] + [re (regexp + (string-append "^(.*?)" + "(?:(" + (foldl (λ (x acc) + (string-append acc + ")|(" + (regexp-quote (string x)))) + (regexp-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))))))))))) + + +(define (escape-for-uri thing) + (with-output-to-string + (λ () + (for ([char (in-string (if (string? thing) + thing + (format "~a" thing)))]) + (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) + ;; 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) + (printf "%0~x" cnum) + (printf "%~x" cnum)))))))) + + +(define formatters + (make-parameter + `(("html" . ,(make-escaper '((#\< . "<") + (#\> . ">") + (#\& . "&")))) + ("html-attr-value" . ,(make-escaper '((#\< . "<") + (#\> . ">") + (#\& . "&") + (#\' . "'") + (#\" . """)))) + ("url-param-value" . ,escape-for-uri) + ("raw" . ,(λ (x) x))))) + + +;;#; +(let ([template (with-input-from-string + " +

{title|html}

+{.section people} + +{.or} +

No one's registered.

+{.end}" + (λ () (read-template)))]) + (template '((title . "") + (people . + (((name . "Nathalie") (age . 24)) + ((name . "Heinrich") (age . 28)) + ((name . "Hans") (age . 25))))))) -- cgit v1.2.3