From b9a826c87be75ca5c59cde6dc6cd7503dad53f4d Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Wed, 22 Jun 2011 11:53:02 +0200 Subject: Begin translation to Typed Racket. --- json-template.rkt | 167 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 97 insertions(+), 70 deletions(-) (limited to 'json-template.rkt') 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) -- cgit v1.2.3 From d5266513238a4360e95732271eff8af510f626a5 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Wed, 22 Jun 2011 20:46:07 +0200 Subject: Finish Typed Racket implementation. --- json-template.rkt | 229 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 134 insertions(+), 95 deletions(-) (limited to 'json-template.rkt') diff --git a/json-template.rkt b/json-template.rkt index ffb135d..6a2a049 100755 --- a/json-template.rkt +++ b/json-template.rkt @@ -1,14 +1,27 @@ +#lang typed/racket ;;; -*- mode: scheme; coding: utf-8 -*- ;;; Copyright 2011, Matthias Andreas Benkard. -#lang typed/racket -(provide read-template +(require/typed racket + [regexp-split (Regexp String -> (Listof String))] + ;;[sequence->list (All (a) (Sequenceof a) -> (Listof a))] + [sequence->list (All (a) Any -> (Listof a))] ;FIXME + [regexp-replace (Regexp String String -> String)] + [sequence? (Any -> Boolean)] + [with-input-from-string (All (a) (String (-> a) -> a))] + [dict-ref (Any Any Any -> Any)] + [dict? (Any -> Boolean)]) + +(provide make-template formatters meta-left meta-right default-formatter format-char) +#; +(provide: ...) + (define meta-left (make-parameter "{")) (define meta-right (make-parameter "}")) (define default-formatter (make-parameter "raw")) @@ -55,18 +68,22 @@ [format-char : String]) : directive (match text [(regexp #px"^\\.section\\s+(.*)$" (list _ x)) - (directive 'section (list x))] + (case x + [(#f) (error "Syntax error: Expected section name after \".section\"")] + [else (directive 'section (list x))])] [(regexp #px"^\\.repeated\\s+section\\s+(.*)$" (list _ x)) - (directive 'repeated-section (list x))] - [#".end" + (case x + [(#f) (error "Syntax error: Expected section name after \".repeated section\"")] + [else (directive 'repeated-section (list x))])] + [".end" (directive 'end '())] - [#".or" + [".or" (directive 'or '())] [(regexp #px"^\\.alternates\\s+with$") (directive 'alternates-with '())] [_ (directive 'substitute - (regexp-split (regexp-quote format-char) text))])) + (regexp-split (regexp (regexp-quote format-char)) text))])) (define: (remove-spurious-newlines-from-token-groups [groups : (Listof Group)]) : (Listof Group) @@ -74,12 +91,12 @@ (for/list ([group groups]) (if last-was-directive? (begin - (set! last-was-directive? (pair? group)) + (set! last-was-directive? (directive? group)) (if (or (string? group) (bytes? group)) (regexp-replace #rx"^\n" group "") group)) (begin - (set! last-was-directive? (pair? group)) + (set! last-was-directive? (directive? group)) group))))) (define-type Part (U section substitution String)) @@ -96,7 +113,7 @@ (struct: substitution ([name : String] - [formatter : String] + [formatter : (U String #f)] [arguments : (Listof String)]) #:transparent) @@ -107,9 +124,13 @@ [clauses : (Listof Part) '()]) (if (or (null? parsed-groups) (and (directive? (car parsed-groups)) - (memq (directive-type parsed-groups) '(end or alternates-with)))) + (memq (directive-type (car parsed-groups)) + '(end or alternates-with)))) (values (reverse clauses) - (if (directive? parsed-groups) (caar parsed-groups) #f)) + (if (null? parsed-groups) + #f + (let ([first-group (car parsed-groups)]) + (if (directive? first-group) (directive-type first-group) #f))) (if (pair? parsed-groups) (cdr parsed-groups) '())) (match (car parsed-groups) [(directive 'section (list x)) @@ -121,19 +142,27 @@ (parse-structure rest)]) (loop rest2 (cons (section x stuff stuff2) clauses)))] [(end) - (loop rest (cons (section x stuff #f) clauses))]))] + (loop rest (cons (section x stuff '()) clauses))] + [else (error "Values of beta will give rise to dom!" reason)]))] [(directive 'repeated-section (list x)) - (let inner-loop ([subsections '()] - [rest (cdr parsed-groups)]) + (let: inner-loop : (values (Listof Part) (U Symbol False) (Listof Group)) + ([subsections% : (Listof (Pairof (U Symbol False) (Listof Part))) '()] + [rest : (Listof Group) + (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 (list)] - [alternates-with (list)]) + (let: inner-inner-loop : (values (Listof Part) (U Symbol False) (Listof Group)) + ([subsections : (Listof (Pairof (U Symbol False) + (Listof Part))) + (let: ([tmp : (Pairof (U Symbol False) + (Listof Part)) + (cons 'end stuff)]) + (cons tmp subsections%))] + [alternative : (Listof Part) (list)] + [alternates-with : (Listof Part) (list)]) (if (null? (cdr subsections)) (loop new-rest (cons (repeated-section x @@ -152,40 +181,47 @@ 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))))] + (inner-loop (cons (ann (cons reason stuff) + (Pairof (U Symbol False) (Listof Part))) + subsections%) + new-rest))))] [(directive 'substitute (list x)) (loop (cdr parsed-groups) (cons (substitution x #f '()) clauses))] [(directive 'substitute (list x y arg ...)) - (loop (cdr parsed-groups) - (cons (substitution x y arg) clauses))] + (let ([d (car parsed-groups)]) + (with-asserts ([d directive?]) + (loop (cdr parsed-groups) + (cons (substitution x y (cddr (directive-arguments d))) + ;"arg" doesn't work because Typed Racket thinks it's a (Listof Any). + clauses))))] [x - (loop (cdr parsed-groups) - (cons x clauses))]))) + (if (string? x) + (loop (cdr parsed-groups) + (cons x clauses)) + (error "Expected a string here."))])))) (define: (parse-structure* [x : (Listof Group)]) : (Listof Part) (let-values ([(stuff reason rest) (parse-structure x)]) stuff)) -(struct: template ([expander : (Any -> String)]) - #:property prop:procedure (struct-field-index expander)) +;;(struct: template ([expander : (Any -> Void)]) +;; #: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 [input-string : String]) : template +(define-type template (Any -> Void)) + +(define: (make-template [input-string : String]) : template (let ([template-data (parse-structure* (remove-spurious-newlines-from-token-groups (classify-chunks (template-string->chunks input-string - meta-left - meta-right) - format-char)))]) - (template - (λ (context) - (expand-template template-data (list context) default-formatter))))) + (meta-left) + (meta-right)) + (format-char))))]) + (let ([default-formatter% (default-formatter)]) + (λ (context) + (expand-template template-data (list context) default-formatter%))))) (define: (name->path [name : String]) : (Listof String) (if (string=? name "@") @@ -219,7 +255,10 @@ (values #f #f)]))) (define: (find-formatter [name : String]) : (String -> String) - (cdr (assoc name (formatters)))) + (let ([formatter (assoc name (formatters))]) + (cdr (if formatter + formatter + (error "Formatter \"~a\" not found" name))))) (define: (expand-template [template : (Listof Part)] [stack : (Listof Any)] @@ -229,13 +268,13 @@ [(repeated-section name body alternative alternates-with) (let ([context (resolve-path stack (name->path name))]) (if (or (false? context) - (null? (sequence->list context))) + (null? context)) (when alternative (expand-template alternative (cons context stack) default-formatter)) - (let ([first-iteration? #t]) - (for ([value context]) + (let: ([first-iteration? : Boolean #t]) + (for ([value (in-list context)]) (when alternates-with (if first-iteration? (set! first-iteration? #f) @@ -263,67 +302,68 @@ -(define: (make-escaper [replacements : List]) : (String -> String) - (let* ([escapees (map car replacements)] - [escapings (map cdr replacements)] +(define: (make-escaper [replacements : (Listof (Pairof Char String))]) : (String -> String) + (let* ([escapees (map (inst car Char String) replacements)] + [escapings (map (inst cdr Char String) replacements)] [re (regexp (string-append "^(.*?)" "(?:(" - (foldl (λ (x acc) - (string-append acc - ")|(" - (regexp-quote (string x)))) + (foldl (λ: ([x : Char] + [acc : String]) + (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 : Void () - (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))))))))))) + (with-output-to-string + (λ () + (with-input-from-string + (if (string? thing) + thing + (format "~a" thing)) + (λ () + (let: loop : Void () + (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 (in-list escapee-matches)] + [y (in-list escapings)]) + (when x + (display y))) + (loop))))))))))) (define: (escape-for-uri [thing : String]) : String (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 + (λ () + (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 : (Parameterof (Listof (Pairof String (String -> String)))) (make-parameter `(("html" . ,(make-escaper '((#\< . "<") (#\> . ">") @@ -334,12 +374,10 @@ (#\' . "'") (#\" . """)))) ("url-param-value" . ,escape-for-uri) - ("raw" . ,(λ (x) x))))) + ("raw" . ,(λ: ([x : String]) x))))) -#; -(let ([template (with-input-from-string - #<{title|html} {.section people}
    @@ -351,7 +389,8 @@

    No one's registered.

    {.end} EOF - (λ () (read-template)))]) + ] + [template (make-template template-string)]) (template '((title . "") (people . (((name . "Nathalie") (age . 24)) -- cgit v1.2.3 From 619cc7ed168d47f942b7d4c2190562ac6eafea8b Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Wed, 22 Jun 2011 20:47:22 +0200 Subject: Comment the example code snippet out again. --- json-template.rkt | 1 + 1 file changed, 1 insertion(+) (limited to 'json-template.rkt') diff --git a/json-template.rkt b/json-template.rkt index 6a2a049..9729159 100755 --- a/json-template.rkt +++ b/json-template.rkt @@ -377,6 +377,7 @@ ("raw" . ,(λ: ([x : String]) x))))) +#; (let* ([template-string #<{title|html} {.section people} -- cgit v1.2.3 From 46e931cf02951d23ab208ae92c2516764db6d914 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Fri, 24 Jun 2011 18:35:48 +0200 Subject: Move public type declarations and definitions to the top of the file. --- json-template.rkt | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) (limited to 'json-template.rkt') diff --git a/json-template.rkt b/json-template.rkt index 9729159..f1a1b54 100755 --- a/json-template.rkt +++ b/json-template.rkt @@ -12,15 +12,16 @@ [dict-ref (Any Any Any -> Any)] [dict? (Any -> Boolean)]) -(provide make-template - formatters - meta-left - meta-right - default-formatter - format-char) +(provide: [make-template (String -> Template)] + [formatters (Parameterof (Listof (Pairof String (String -> String))))] + [meta-left (Parameterof String)] + [meta-right (Parameterof String)] + [default-formatter (Parameterof String)] + [format-char (Parameterof String)]) +(provide Template) -#; -(provide: ...) + +(define-type Template (Any -> Void)) (define meta-left (make-parameter "{")) (define meta-right (make-parameter "}")) @@ -209,9 +210,7 @@ ;; #:property prop:procedure (struct-field-index expander)) -(define-type template (Any -> Void)) - -(define: (make-template [input-string : String]) : template +(define (make-template input-string) (let ([template-data (parse-structure* (remove-spurious-newlines-from-token-groups @@ -363,7 +362,7 @@ (printf "%~x" cnum)))))))) -(define: formatters : (Parameterof (Listof (Pairof String (String -> String)))) +(define formatters (make-parameter `(("html" . ,(make-escaper '((#\< . "<") (#\> . ">") -- cgit v1.2.3