diff options
| -rwxr-xr-x | json-template.rkt | 167 |
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) |