sun eve

debug.rkt

@@ -0,0 +1,38 @@
+#lang racket/base
+(require racket/date)
+(require racket/string)
+(require racket/format)
+
+(require "readability.rkt")
+
+(provide (all-defined-out))
+
+; todo: contracts, tests, docs
+
+; debug utilities
+(define (message . items)
+  (define (zero-fill str count)
+    (set! str (~a str))
+    (if (> (string-length str) count)
+        str
+        (string-append (make-string (- count (string-length str)) #\0) str)))
+  
+  (define (make-date-string)
+    (define date (current-date))
+    (define date-fields (map (λ(x) (zero-fill x 2)) 
+                             (list (date-month date)
+                                   (date-day date)
+                                   (date-year date)
+                                   (modulo (date-hour date) 12)
+                                   (date-minute date)
+                                   (date-second date)
+                                   (if (< (date-hour date) 12) "am" "pm"))))    
+    (apply format "[~a.~a.~a ~a:~a:~a~a]" date-fields))
+  (displayln (string-join `(,(make-date-string) ,@(map (λ(x)(if (string? x) x (~v x))) items))) (current-error-port)))
+
+
+; report the current value of the variable, then return it
+(define-syntax-rule (report var)
+  (begin 
+    (message 'var "=" var) 
+    var))

decode.rkt

@@ -0,0 +1,88 @@
+#lang racket/base
+(require racket/contract)
+(require racket/list)
+(require racket/string)
+
+(module+ test (require rackunit))
+
+(require "tools.rkt")
+(provide (all-defined-out))
+
+;; Find adjacent newline characters in a list and merge them into one item
+;; Scribble, by default, makes each newline a separate list item
+;; In practice, this is worthless.
+(define/contract (merge-newlines x)
+  (list? . -> . list?)
+  (define (newline? x)
+    (and (string? x) (equal? "\n" x)))
+  (define (not-newline? x)
+    (not (newline? x)))
+  
+  (define (really-merge-newlines xs [acc '()])
+    (if (empty? xs)
+        acc
+        ;; Try to peel the newlines off the front.
+        (let-values ([(leading-newlines remainder) (splitf-at xs newline?)])
+          (if (not (empty? leading-newlines)) ; if you got newlines ...
+              ;; combine them into a string and append them to the accumulator, 
+              ;; and recurse on the rest
+              (really-merge-newlines remainder (append acc (list (string-join leading-newlines ""))))
+              ;; otherwise peel off elements up to the next newline, append them to accumulator,
+              ;; and recurse on the rest
+              (really-merge-newlines (dropf remainder not-newline?) 
+                               (append acc (takef remainder not-newline?)))))))
+  
+  (cond
+    [(list? x) (really-merge-newlines (map merge-newlines x))]
+    [else x]))
+
+(module+ test
+  (check-equal? (merge-newlines '(p "\n" "foo" "\n" "\n" "bar" (em "\n" "\n" "\n"))) 
+                '(p "\n" "foo" "\n\n" "bar" (em "\n\n\n"))))
+
+
+; Mon Aug 5: start here
+
+; A block-xexpr is a named expression that's not on the inline list
+; todo: bear in mind that browsers take the opposite view:
+; that only elements on the block list are blocks
+; and otherwise are treated as inline 
+(define (block-xexpr? x)
+  (and (named-xexpr? x) (not (in? inline-tags (car x)))))
+
+
+
+; default content decoder for pollen
+(define/contract (decode x)
+  (named-xexpr? . -> . named-xexpr?)
+  
+  (define (&decode x)
+    (cond
+      [(named-xexpr? x)
+       (let-values([(name attr content) (break-named-xexpr x)]) 
+         (define decoded-x (make-named-xexpr name attr (&decode content)))
+         (if (block-xexpr? decoded-x)
+             ; add nonbreaking-last-space to the next line when ready
+             (wrap-hanging-quotes (nonbreaking-last-space decoded-x)) ; do special processing for block xexprs
+             decoded-x))]
+      [(xexpr-content? x) ; a list of xexprs
+       (let ([x (prep-paragraph-flow x)]) 
+         (map &decode (if (any paragraph-break? x) ; need this condition to prevent infinite recursion
+                          (map wrap-paragraph (splitf-at* x paragraph-break?)) ; split into ¶¶
+                          x)))]     
+      [(string? x) (typogrify x)]
+      [else x]))
+  
+  (define (stringify x) ; convert numbers to strings
+    (cond
+      [(list? x) (map stringify x)]
+      [(number? x) (~a x)]
+      [else x]))
+  
+  (let* ([x (stringify x)]
+         [x (trim-whitespace x)])
+    (if (named-xexpr? x)
+        (&decode x)
+        ;todo: improve this error message, more specific location
+        ; now, it just spits out the whole defective content
+        (error (format "decode: ~v not a full named-xexpr" x)))))

main-helper.rkt

@@ -17,6 +17,7 @@
      ;; So when called from outside the project directory, 
      ;; current-directory must be properly set with 'parameterize'
      (define (make-complete-path path)
+       ;; todo: document why this function is necessary (it definitely is, but I forgot why)
        (define-values (start_dir name _ignore) (split-path (path->complete-path path)))
        (build-path start_dir EXTRAS_DIR name))
      (define files (map make-complete-path (filter (λ(i) (has-ext? i 'rkt)) (directory-list EXTRAS_DIR))))

main.rkt

@@ -1,4 +1,5 @@
 #lang racket/base
+(require racket/match)
 (require (planet mb/pollen/tools)
          (planet mb/pollen/main-helper))
 
@@ -36,21 +37,32 @@
      (define-syntax-rule (#%top . id)
        (λ x `(id ,@x)))
      
-     expr ... ; body of module   
+     expr ... ; body of module  
-     (define inner-here here) ; set up a hook for identifier 'here' (different name to avoid macrofication)
+     
+     ;; set up a hook for identifier 'here'
+     ;; (but under a different name to avoid macrofication)
+     (define inner-here here)  
      (provide (all-defined-out))) 
    
-   (require 'pollen-inner) ; provides 'doc
+   (require 'pollen-inner) ; provides doc & #%top, among other things
    
-   (define text (merge-newlines (as-list doc))) ; if single line, text will be a string
+   ;; Policy: here in the core lang, do as little to main as possible.
-   (define main (append
+   ;; The point is just to set it up for further processing.
-                 ; different setup depending on whether we have
+   ;; One of the annoyances of Scribble is its insistence on decoding.
-                 (if (named-xexpr? text) 
+   ;; Better just to pass through the minimally processed data.
-                     `(main ,text) ; a whole xexpr or
+   ;; Root is treated as a function. 
-                     `(main ,@text)) ; just xexpr content 
+   ;; If it's not defined elsewhere, it just hits #%top and becomes a named-xexpr.
-                 (list (meta "here" inner-here)))) ; append inner-here as meta
+   (define main (apply root
+                        (append 
+                         (cond
+                           [(string? doc) (list doc)] ; doc is probably a list, but might be a single string
+                           [(named-xexpr? doc) (list doc)] ; if it's a single nx, just leave it
+                           [(list? doc) doc]) ; if it's nx content, splice it in
+                         (list `(meta "here" ,inner-here))))) ; append inner-here as meta
    
-   (provide main)
+   (provide main
+            (except-out (all-from-out 'pollen-inner) inner-here) ; everything from user 
+            (rename-out (inner-here here))) ; change identifier back (now safe from macrofication)
    
    (module+ main
      (print main)

tests/requires/include-me.rkt

@@ -1,7 +1,16 @@
 #lang racket/base
+(require racket/contract)
+(require (planet mb/pollen/tools) (planet mb/pollen/decode))
 
 (provide (all-defined-out))
 
-(define foo "bar")
+(module+ test (require rackunit))
 
+(define (root . items)
+  (named-xexpr? . -> . named-xexpr?)
+  `(root ,@(merge-newlines items)))
 
+(module+ test
+  (check-equal? (root "foo" "\n" "\n") '(root "foo" "\n\n")))
+
+(define foo "bar")

tools.rkt

@@ -1,12 +1,13 @@
 #lang racket/base
-(require "readability.rkt")
 (require racket/contract racket/match)
 (require (only-in racket/path filename-extension))
 (require (only-in racket/format ~a))
 (require (only-in racket/list empty empty? second filter-not splitf-at takef dropf))
 (require (only-in racket/string string-join))
 (require (only-in xml xexpr?))
-(provide (all-defined-out) (all-from-out "readability.rkt"))
+
+(require "readability.rkt" "debug.rkt")
+(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt"))
 
 ;; setup for test cases
 (module+ test
@@ -158,7 +159,7 @@
   (procedure? list? . -> . list?)
   (define (remove-empty x)
     (cond
-      [(list? x) (map remove-empty (filter-not empty? x))]
+      [(list? x) (filter-not empty? (map remove-empty x))]
       [else x]))
   
   (define (filter-tree-inner proc tree)
@@ -171,7 +172,8 @@
 (module+ test
   (check-equal? (filter-tree string? '(p)) empty)
   (check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar"))
-  (check-equal? (filter-tree string? '(p "foo" (p "bar"))) '("foo" ("bar"))))
+  (check-equal? (filter-tree string? '(p "foo" (p "bar"))) '("foo" ("bar")))
+  (check-equal? (filter-tree (λ(i) (and (string? i) (equal? i "\n"))) '("\n" (foo "bar") "\n")) '("\n" "\n"))) 
 
 ;; apply filter-not proc recursively
 (define/contract (filter-not-tree proc tree)
@@ -184,34 +186,4 @@
   (check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p))))
 
 
-;; Find adjacent newline characters in a list and merge them into one item
-;; Scribble, by default, makes each newline a separate list item
-;; In practice, this is worthless.
-(define/contract (merge-newlines x)
-  (list? . -> . list?)
-  (define (newline? x)
-    (and (string? x) (equal? "\n" x)))
-  (define (not-newline? x)
-    (not (newline? x)))
-  
-  (define (really-merge-newlines xs [acc '()])
-    (if (empty? xs)
-        acc
-        ;; Try to peel the newlines off the front.
-        (let-values ([(leading-newlines remainder) (splitf-at xs newline?)])
-          (if (not (empty? leading-newlines)) ; if you got newlines ...
-              ;; combine them into a string and append them to the accumulator, 
-              ;; and recurse on the rest
-              (really-merge-newlines remainder (append acc (list (string-join leading-newlines ""))))
-              ;; otherwise peel off elements up to the next newline, append them to accumulator,
-              ;; and recurse on the rest
-              (really-merge-newlines (dropf remainder not-newline?) 
-                               (append acc (takef remainder not-newline?)))))))
-  
-  (cond
-    [(list? x) (really-merge-newlines (map merge-newlines x))]
-    [else x]))
 
-(module+ test
-  (check-equal? (merge-newlines '(p "\n" "foo" "\n" "\n" "bar" (em "\n" "\n" "\n"))) 
-                '(p "\n" "foo" "\n\n" "bar" (em "\n\n\n"))))