Merge Typed Racket branch.

3 files changed, 320 insertions, 144 deletions

diff --git a/info.rkt b/info.rkt
new file mode 100644
index 0000000..5e17197
--- /dev/null
+++ b/info.rkt
@@ -0,0 +1,22 @@
+#lang setup/infotab
+(define name "JSON Template for Racket")
+(define blurb
+  '(p ()
+      "A Typed Racket implementation of "
+      (a ((href "http://json-template.googlecode.com/svn/trunk/doc/Introducing-JSON-Template.html"))
+         "JSON Template")
+      ", a minimalistic, yet powerful, template language."))
+(define categories '(misc))
+(define version "1.0")
+(define can-be-loadded-with 'all)
+(define primary-file "json-template.rkt")
+(define homepage "http://matthias.benkard.de/software/json-template-for-racket")
+(define scribblings '(("manual.scrbl" ())))
+
+#;
+(define release-notes
+  ...)
+
+#;
+(define required-core-version
+  ...)
diff --git a/json-template.rkt b/json-template.rkt
index fe596c4..f1a1b54 100755
--- a/json-template.rkt
+++ b/json-template.rkt
@@ -1,92 +1,140 @@
+#lang typed/racket
 ;;; -*- mode: scheme; coding: utf-8 -*-
 ;;; Copyright 2011, Matthias Andreas Benkard.
-#lang racket
 
-(provide read-template
-         formatters)
+(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)])
 
-(define (template-string->chunks input meta-left meta-right)
+(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)
+
+
+(define-type Template (Any -> Void))
+
+(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)]
+     (case x
+       [(#f) (error "Syntax error: Expected section name after \".section\"")]
+       [else (directive 'section (list x))])]
     [(regexp #px"^\\.repeated\\s+section\\s+(.*)$" (list _ x))
-     (list 'repeated-section x)]
-    [#".end"
-     (list 'end)]
-    [#".or"
-     (list 'or)]
+     (case x
+       [(#f) (error "Syntax error: Expected section name after \".repeated section\"")]
+       [else (directive 'repeated-section (list x))])]
+    [".end"
+     (directive 'end '())]
+    [".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 (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
-            (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)))))
 
-(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 : (U String #f)]
+   [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 (car parsed-groups))
+                       '(end or alternates-with))))
         (values (reverse clauses)
-                (and (pair? parsed-groups) (caar parsed-groups))
+                (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)
-          [(list 'section x)
+          [(directive 'section (list x))
            (let-values ([(stuff reason rest)
                          (parse-structure (cdr parsed-groups))])
              (case reason
@@ -95,19 +143,27 @@
                               (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)])
+                (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 : (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 #f]
-                        [alternates-with #f])
+                   (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
@@ -126,45 +182,52 @@
                                               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)
+                   (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))]
-          [(list 'substitute x y arg ...)
-           (loop (cdr parsed-groups)
-                 (cons (substitution x y arg) clauses))]
+          [(directive 'substitute (list x y arg ...))
+           (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)
+(define: (parse-structure* [x : (Listof Group)]) : (Listof Part)
   (let-values ([(stuff reason rest) (parse-structure x)])
     stuff))
 
-(struct template (expander)
-  #: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 (make-template input-string)
   (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)
+           (classify-chunks (template-string->chunks input-string
+                                                     (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 "@")
+      '()
+      (regexp-split #rx"\\." name)))
+
+(define: (resolve-path [stack : (Listof Any)] [path : (Listof String)]) : Any
   (if (null? stack)
       #f
       (let-values ([(value success?)
@@ -173,7 +236,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,25 +253,27 @@
           [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)
+  (let ([formatter (assoc name (formatters))])
+    (cdr (if formatter
+             formatter
+             (error "Formatter \"~a\" not found" name)))))
 
-(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)
        (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)
@@ -230,70 +295,71 @@
                                 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)
-  (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 ()
-                (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
+       (λ ()
+         (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))))))))
+   (λ ()
+     (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
@@ -307,12 +373,11 @@
                                            (#\' . "&#39;")
                                            (#\" . "&#34;"))))
      ("url-param-value" . ,escape-for-uri)
-     ("raw"             . ,(λ (x) x)))))
+     ("raw"             . ,(λ: ([x : String]) x)))))
 
 
 #;
-(let ([template (with-input-from-string
-                 #<<EOF
+(let* ([template-string #<<EOF
 <h1>{title|html}</h1>
 {.section people}
 <ul>
@@ -324,7 +389,8 @@
 <p>No one's registered.</p>
 {.end}
 EOF
-                  (λ () (read-template)))])
+                        ]
+       [template (make-template template-string)])
   (template '((title . "<Registered People>")
               (people .
                       (((name . "Nathalie") (age . 24))
diff --git a/manual.scrbl b/manual.scrbl
new file mode 100644
index 0000000..9f8b6b5
--- /dev/null
+++ b/manual.scrbl
@@ -0,0 +1,88 @@
+#lang scribble/manual

+@;@(require planet/scribble)

+@(require scribble/eval)

+@(require racket/sandbox)

+@(require (for-label racket))

+@(require (for-label "json-template.rkt"))

+@;@(require (for-label (this-package-in json-template)))

+

+@(define r6rs-evaluator

+   (call-with-trusted-sandbox-configuration

+    (lambda ()

+      (parameterize ([sandbox-output 'string]

+                     [sandbox-error-output 'string])

+        (make-evaluator

+         'r6rs

+         '(import (rnrs) (json-template)))))))

+@(define racket-evaluator

+   (call-with-trusted-sandbox-configuration

+    (lambda ()

+      (parameterize ([sandbox-output 'string]

+                     [sandbox-error-output 'string])

+        (make-evaluator

+         'racket/base

+         #:requires (list "json-template.rkt"))))))

+@(define typed-racket-evaluator

+   (call-with-trusted-sandbox-configuration

+    (lambda ()

+      (parameterize ([sandbox-output 'string]

+                     [sandbox-error-output 'string])

+        (make-evaluator

+         'typed/racket/base

+         #:requires (list "json-template.rkt"))))))

+

+

+@title{JSON Template for Racket (and Typed Racket)}

+@author{Matthias A. Benkard}

+

+

+@section{Installation}

+

+JSON Template for Racket is published as a PLaneT module.  Simply @racket[(require (planet mbenkard/json-template))] to get started.

+

+

+@section{Usage}

+

+@subsection{API}

+

+@defproc[(make-template [template-data string?]) procedure?]{

+  Create a template from @scheme[template-data], which must be in JSON Template syntax.

+

+  The returned procedure expects a single argument, the @italic{subtitution context}, and returns the expanded template as a string.  Three types of contexts are supported:

+

+  @itemlist[

+    @item{@bold{Primitive contexts.}  These may be of any form whatever (valid primitive contexts are lists, numbers, symbols, strings, etc.) and are not treated specially.  Their only purpose is being printed into the template expansion as plain text.  Note that a primitive context does not make a whole lot of sense when used as an argument to @scheme{make-template} (although it can be used as such and referenced as @scheme["@"]); it is much more commonly encountered as a nested context in a map.}

+    @item{@bold{Sequences.}  At present, these may only be lists.  They can be iterated over by the use of repeated sections.}

+    @item{@bold{Maps.}  These may be any kinds of <dict?> objects; in particular, association lists and hash tables are fine choices.  They can be indexed into by substitutions.}

+  ]

+  

+  @scheme[make-template]'s behavior can be customized by the parameters @scheme[formatters], @scheme[meta-left], @scheme[meta-right], @scheme[default-formatter], and @scheme[format-char].

+

+  For general information about JSON Template, see @url{http://json-template.googlecode.com/svn/trunk/doc/Introducing-JSON-Template.html} and @url{http://code.google.com/p/json-template/wiki/Reference}.

+}

+

+

+@subsection{Examples}

+

+@interaction[#:eval racket-evaluator

+(define template (make-template "

+<h1>{title|html}</h1>

+{.section people}

+<ul>

+{.repeated section @}

+  <li>{name} ({age} years)</li>

+{.end}

+</ul>

+{.or}

+<p>No one's registered.</p>

+{.end}

+"))

+(template '((title . "<Registered People>")

+            (people .

+                    (((name . "Nathalie") (age . 24))

+                     ((name . "Heinrich") (age . 28))

+                     ((name . "Hans")     (age . 25))))))

+(template '((title . "<Registered People>")

+            (people)))

+(template '((title . "<Registered People>")))

+]