From b9439d96fce0efd6c288bf5d74894bc9ffe1107d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 4 Aug 2013 23:05:32 -0700 Subject: [PATCH] sun eve --- debug.rkt | 38 +++++++++++++++ decode.rkt | 88 +++++++++++++++++++++++++++++++++++ main-helper.rkt | 1 + main.rkt | 34 +++++++++----- tests/requires/include-me.rkt | 11 ++++- tools.rkt | 40 +++------------- 6 files changed, 166 insertions(+), 46 deletions(-) create mode 100644 debug.rkt create mode 100644 decode.rkt diff --git a/debug.rkt b/debug.rkt new file mode 100644 index 0000000..ce739fc --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/decode.rkt b/decode.rkt new file mode 100644 index 0000000..c4a2d4f --- /dev/null +++ b/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))))) diff --git a/main-helper.rkt b/main-helper.rkt index b7a12f0..a441c4a 100644 --- a/main-helper.rkt +++ b/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)))) diff --git a/main.rkt b/main.rkt index 9888e6f..1fef9a6 100644 --- a/main.rkt +++ b/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 - (define inner-here here) ; set up a hook for identifier 'here' (different name to avoid macrofication) + expr ... ; body of module + + ;; 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 - (define main (append - ; different setup depending on whether we have - (if (named-xexpr? text) - `(main ,text) ; a whole xexpr or - `(main ,@text)) ; just xexpr content - (list (meta "here" inner-here)))) ; append inner-here as meta + ;; Policy: here in the core lang, do as little to main as possible. + ;; The point is just to set it up for further processing. + ;; One of the annoyances of Scribble is its insistence on decoding. + ;; Better just to pass through the minimally processed data. + ;; Root is treated as a function. + ;; If it's not defined elsewhere, it just hits #%top and becomes a named-xexpr. + (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) diff --git a/tests/requires/include-me.rkt b/tests/requires/include-me.rkt index fdee865..e13a984 100644 --- a/tests/requires/include-me.rkt +++ b/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") \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index 836d79c..9e89a6f 100644 --- a/tools.rkt +++ b/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"))))