;;; -*- 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)])
(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
"
{title|html}
{.section people}
{.repeated section @}
- {name} ({age} years)
{.end}
{.or}
No one's registered.
{.end}"
(λ () (read-template)))])
(template '((title . "")
(people .
(((name . "Nathalie") (age . 24))
((name . "Heinrich") (age . 28))
((name . "Hans") (age . 25)))))))