summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xjson-template.rkt167
1 files changed, 97 insertions, 70 deletions
diff --git a/json-template.rkt b/json-template.rkt
index fe596c4..ffb135d 100755
--- a/json-template.rkt
+++ b/json-template.rkt
@@ -1,54 +1,76 @@
;;; -*- mode: scheme; coding: utf-8 -*-
;;; Copyright 2011, Matthias Andreas Benkard.
-#lang racket
+#lang typed/racket
(provide read-template
- formatters)
+ formatters
+ meta-left
+ meta-right
+ default-formatter
+ format-char)
-(define (template-string->chunks input meta-left meta-right)
+(define meta-left (make-parameter "{"))
+(define meta-right (make-parameter "}"))
+(define default-formatter (make-parameter "raw"))
+(define format-char (make-parameter "|"))
+
+(define: (template-string->chunks [input : String]
+ [meta-left : String]
+ [meta-right : String]) : (Listof String)
(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)))
+(: flip-flop-map
+ (All (a b)
+ (a -> b) (a -> b) (Listof a) -> (Listof b)))
(define (flip-flop-map f1 f2 lst)
"Like map, but alternate between f1 and f2 as the function to apply."
- (define (flip items)
+ (define: (flip [items : (Listof a)]) : (Listof b)
(match items
['() '()]
[(list* x xs) (cons (f1 x) (flop xs))]))
- (define (flop items)
+ (define: (flop [items : (Listof a)]) : (Listof b)
(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))
+
+(struct: directive
+ ([type : Symbol]
+ [arguments : (Listof String)])
+ #:transparent)
+(define-type Group (U String directive))
+
+(define: (classify-chunks [chunks : (Listof String)]
+ [format-char : String]) : (Listof Group)
+ (flip-flop-map (λ: ([x : String]) x)
+ (λ: ([x : String]) (parse-directive x format-char))
chunks))
-(define (parse-directive directive format-char)
- (match directive
- [(regexp #rx"^#")
- #f]
+(define: (parse-directive [text : String]
+ [format-char : String]) : directive
+ (match text
[(regexp #px"^\\.section\\s+(.*)$" (list _ x))
- (list 'section x)]
+ (directive 'section (list x))]
[(regexp #px"^\\.repeated\\s+section\\s+(.*)$" (list _ x))
- (list 'repeated-section x)]
+ (directive 'repeated-section (list x))]
[#".end"
- (list 'end)]
+ (directive 'end '())]
[#".or"
- (list 'or)]
+ (directive 'or '())]
[(regexp #px"^\\.alternates\\s+with$")
- (list 'alternates-with)]
+ (directive 'alternates-with '())]
[_
- (list* 'substitute (regexp-split (regexp-quote format-char)
- directive))]))
-
-(define (remove-spurious-newlines-from-token-groups groups)
- (let ([last-was-directive? #f])
+ (directive 'substitute
+ (regexp-split (regexp-quote format-char) text))]))
+
+(define: (remove-spurious-newlines-from-token-groups [groups : (Listof Group)])
+ : (Listof Group)
+ (let: ([last-was-directive? : Boolean #f])
(for/list ([group groups])
(if last-was-directive?
(begin
@@ -60,33 +82,37 @@
(set! last-was-directive? (pair? group))
group)))))
-(struct section
- (name
- body
- alternative)
+(define-type Part (U section substitution String))
+
+(struct: section
+ ([name : String]
+ [body : (Listof Part)]
+ [alternative : (Listof Part)])
#:transparent)
-(struct repeated-section section
- (alternates-with)
+(struct: repeated-section section
+ ([alternates-with : (Listof Part)])
#:transparent)
-(struct substitution
- (name
- formatter
- arguments)
+(struct: substitution
+ ([name : String]
+ [formatter : String]
+ [arguments : (Listof String)])
#:transparent)
-(define (parse-structure parsed-groups)
- (let loop ([parsed-groups parsed-groups]
- [clauses '()])
+(define: (parse-structure [parsed-groups : (Listof Group)])
+ : (values (Listof Part) (U Symbol False) (Listof Group))
+ (let: loop : (values (Listof Part) (U Symbol False) (Listof Group))
+ ([parsed-groups : (Listof Group) parsed-groups]
+ [clauses : (Listof Part) '()])
(if (or (null? parsed-groups)
- (and (pair? (car parsed-groups))
- (memq (caar parsed-groups) '(end or alternates-with))))
+ (and (directive? (car parsed-groups))
+ (memq (directive-type parsed-groups) '(end or alternates-with))))
(values (reverse clauses)
- (and (pair? parsed-groups) (caar parsed-groups))
+ (if (directive? parsed-groups) (caar parsed-groups) #f))
(if (pair? parsed-groups) (cdr parsed-groups) '()))
(match (car parsed-groups)
- [(list 'section x)
+ [(directive 'section (list x))
(let-values ([(stuff reason rest)
(parse-structure (cdr parsed-groups))])
(case reason
@@ -96,7 +122,7 @@
(loop rest2 (cons (section x stuff stuff2) clauses)))]
[(end)
(loop rest (cons (section x stuff #f) clauses))]))]
- [(list 'repeated-section x)
+ [(directive 'repeated-section (list x))
(let inner-loop ([subsections '()]
[rest (cdr parsed-groups)])
(let-values ([(stuff reason new-rest)
@@ -106,8 +132,8 @@
(if (eq? reason 'end)
(let inner-inner-loop
([subsections (cons (cons 'end stuff) subsections)]
- [alternative #f]
- [alternates-with #f])
+ [alternative (list)]
+ [alternates-with (list)])
(if (null? (cdr subsections))
(loop new-rest
(cons (repeated-section x
@@ -127,44 +153,46 @@
[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)
+ [(directive 'substitute (list x))
(loop (cdr parsed-groups)
(cons (substitution x #f '()) clauses))]
- [(list 'substitute x y arg ...)
+ [(directive 'substitute (list x y arg ...))
(loop (cdr parsed-groups)
(cons (substitution x y arg) clauses))]
[x
(loop (cdr parsed-groups)
- (cons x clauses))]))))
+ (cons x clauses))])))
-(define (parse-structure* x)
+(define: (parse-structure* [x : (Listof Group)]) : (Listof Part)
(let-values ([(stuff reason rest) (parse-structure x)])
stuff))
-(struct template (expander)
+(struct: template ([expander : (Any -> String)])
#: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: (read-template #:meta-left [meta-left "{"]
+;; #:meta-right [meta-right "}"]
+;; #:default-formatter [default-formatter "raw"]
+;; #:format-char [format-char "|"])
+(define: (read-template [input-string : String]) : template
(let ([template-data
(parse-structure*
(remove-spurious-newlines-from-token-groups
- (classify-chunks (template-string->chunks (current-input-port)
- meta-left meta-right)
+ (classify-chunks (template-string->chunks input-string
+ 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: (name->path [name : String]) : (Listof String)
+ (if (string=? name "@")
+ '()
+ (regexp-split #rx"\\." name)))
-(define (resolve-path stack path)
+(define: (resolve-path [stack : (Listof Any)] [path : (Listof String)]) : Any
(if (null? stack)
#f
(let-values ([(value success?)
@@ -173,7 +201,7 @@
value
(resolve-path (cdr stack) path)))))
-(define (resolve-path-in-object context path)
+(define: (resolve-path-in-object [context : Any] [path : (Listof String)]) : (values Any Boolean)
(let ([nothing (gensym)])
(cond [(null? path)
(values context #t)]
@@ -190,13 +218,12 @@
[else
(values #f #f)])))
-(define (find-formatter name)
- (cdr (assoc (if (string? name)
- name
- (bytes->string/utf-8 name))
- (formatters))))
+(define: (find-formatter [name : String]) : (String -> String)
+ (cdr (assoc name (formatters))))
-(define (expand-template template stack default-formatter)
+(define: (expand-template [template : (Listof Part)]
+ [stack : (Listof Any)]
+ [default-formatter : String]) : Void
(for ([thing template])
(match thing
[(repeated-section name body alternative alternates-with)
@@ -230,13 +257,13 @@
default-formatter))))]
[(substitution name formatter args)
(display ((find-formatter (or formatter default-formatter))
- (resolve-path stack (name->path name))))]
+ (format "~a" (resolve-path stack (name->path name)))))]
[_
(display thing)])))
-(define (make-escaper replacements)
+(define: (make-escaper [replacements : List]) : (String -> String)
(let* ([escapees (map car replacements)]
[escapings (map cdr replacements)]
[re (regexp
@@ -258,7 +285,7 @@
thing
(format "~a" thing))
(λ ()
- (let loop ()
+ (let: loop : Void ()
(unless (eof-object? (peek-byte))
(match-let ([(list* _ raw-text escapee-matches)
(regexp-match re (current-input-port))])
@@ -271,7 +298,7 @@
(loop)))))))))))
-(define (escape-for-uri thing)
+(define: (escape-for-uri [thing : String]) : String
(with-output-to-string
(λ ()
(for ([char (in-string (if (string? thing)