diff options
Diffstat (limited to 'json-template.rkt')
| -rwxr-xr-x | json-template.rkt | 332 |
1 files changed, 0 insertions, 332 deletions
diff --git a/json-template.rkt b/json-template.rkt deleted file mode 100755 index fe596c4..0000000 --- a/json-template.rkt +++ /dev/null @@ -1,332 +0,0 @@ -;;; -*- mode: scheme; coding: utf-8 -*- -;;; Copyright 2011, Matthias Andreas Benkard. -#lang racket - -(provide read-template - formatters) - -(define (template-string->chunks input meta-left meta-right) - (let* ([meta-left-re (regexp-quote meta-left)] - [meta-right-re (regexp-quote meta-right)] - [re (regexp - (string-append "(" meta-left-re ")|(" meta-right-re ")"))]) - (regexp-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)) - -(define (classify-chunks chunks format-char) - (flip-flop-map (λ (x) x) - (λ (x) (parse-directive x format-char)) - chunks)) - -(define (parse-directive directive format-char) - (match directive - [(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 (regexp-split (regexp-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))))) - -(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)) - -(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 "|"]) - (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))))) - -(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)]) - (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 (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 - #<<EOF -<h1>{title|html}</h1> -{.section people} -<ul> -{.repeated section @} - <li>{name} ({age} years)</li> -{.end} -</ul> -{.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))))))) |