From 6ce38652b732d65bd82bbe45c67a68cd8c09b2c0 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 3 Aug 2013 19:23:58 -0700 Subject: [PATCH] Sat afternoon --- main-helper.rkt | 19 +- main.rkt | 4 +- readability.rkt | 220 ++-------------- tools.rkt | 661 ++++++------------------------------------------ 4 files changed, 112 insertions(+), 792 deletions(-) diff --git a/main-helper.rkt b/main-helper.rkt index 65bd57d..c72c9be 100644 --- a/main-helper.rkt +++ b/main-helper.rkt @@ -5,9 +5,8 @@ (planet mb/pollen/world)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Look for a pp-requires directory local to the source file. +;; Look for a EXTRAS_DIR directory local to the source file. ;; If it exists, get list of rkt files ;; and require + provide them. ;; This will be resolved in the context of current-directory. @@ -28,7 +27,7 @@ (letrec ([files (map make-complete-path (filter is-rkt-file? (directory-list EXTRAS_DIR)))] [files-in-require-form - (map (ƒ(x) `(file ,(path->string x))) files)]) + (map (λ(x) `(file ,(path->string x))) files)]) (datum->syntax stx `(begin (require ,@files-in-require-form) @@ -43,7 +42,7 @@ (letrec ([files (map make-complete-path (filter is-rkt-file? (directory-list EXTRAS_DIR)))] [files-in-require-form - (map (ƒ(x) `(file ,(path->string x))) files)]) + (map (λ(x) `(file ,(path->string x))) files)]) (datum->syntax stx `(begin (require ,@files-in-require-form)))) @@ -63,14 +62,14 @@ (set! ccr (car ccr))) ; in which case, just grab the path from the front (if (equal? 'pollen-lang-module ccr) ; what happens if the file isn't yet saved in drracket 'nowhere ; thus you are nowhere - (let-values ([(here-dir here-name ignored) (split-path ccr)]) - (path->string (remove-ext here-name))))))) + (match-let-values ([(_ here-name _) (split-path ccr)]) + (path->string (remove-all-ext here-name))))))) ; then, apply a separate syntax transform to the identifier itself ; can't do this in one step, because if the macro goes from identifier to function definition, ; macro processor will evaluate the body at compile-time, not runtime. (define-syntax here - (ƒ(stx) (datum->syntax stx '(get-here)))) + (λ(stx) (datum->syntax stx '(get-here)))) ; function to strip metas out of body and consolidate them separately @@ -89,4 +88,8 @@ [else x])) (values (remove-empty (&split-metas body)) (reverse meta-list))) -(provide (all-defined-out)) \ No newline at end of file +(provide (all-defined-out)) + +(module+ test + (require rackunit) + (check-equal? (get-here) "test-main-helper")) \ No newline at end of file diff --git a/main.rkt b/main.rkt index edee26e..a57d1f0 100644 --- a/main.rkt +++ b/main.rkt @@ -25,7 +25,7 @@ ; use same requires as top of main.rkt ; (can't import them from surrounding module due to submodule rules) (require (planet mb/pollen/tools) - (planet mb/pollen/main-helper)) ; for split-metas and get-here + (planet mb/pollen/main-helper)) (require-and-provide-extras) ; brings in the project require files ; #%top binding catches ids that aren't defined @@ -53,7 +53,7 @@ (provide main) - (module+ main + (module+ main (print main) (displayln "") (displayln (format "named-xexpr? ~a" (named-xexpr? main)))))) diff --git a/readability.rkt b/readability.rkt index 712470a..3ca8a47 100644 --- a/readability.rkt +++ b/readability.rkt @@ -1,200 +1,28 @@ #lang racket/base -(require (only-in racket/list empty? range)) -(require (only-in racket/format ~a ~v)) -(require (only-in racket/string string-join)) -(require (prefix-in williams: (planet williams/describe/describe))) -(require racket/date) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Utility functions for readability -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require racket/contract) +(require (only-in racket/list empty?)) +(require (only-in racket/format ~a)) (provide (all-defined-out)) -; lambda alias -; won't work as simple define because λ is specially handled in reader -(define-syntax-rule (ƒ x ...) (λ x ...)) - -(define (describe x) - (williams:describe x) - x) - -; report the current value of the variable, then return it -(define-syntax-rule (report var) - (begin - (message 'var "=" var) - var)) - -; debug utilities -(define (message . x) - (define (zfill s n) - (set! s (as-string s)) - (if (> (string-length s) n) - s - (string-append (make-string (- n (string-length s)) #\0) s))) - - (define (make-date-string) - (define d (current-date)) - (define df (map (ƒ(x) (zfill x 2)) (list (date-month d)(date-day d)(date-year d)(modulo (date-hour d) 12)(date-minute d)(date-second d)(if (< (date-hour d) 12) "am" "pm")))) - - (apply format "[~a.~a.~a ~a:~a:~a~a]" df)) - (displayln (string-join `(,(make-date-string) ,@(map (ƒ(x)(if (string? x) x (~v x))) x))) (current-error-port))) - - - -(define (exists? x) - ; neither empty nor false - (and (not (empty? x)) x)) - - - -#|(define (=str . xs) - (let ([tester (car xs)]) - (all (ƒ(x) (equal? tester x)) (map as-string (cdr xs)))))|# - -(define (=str . xs) - (let* ([xs (map as-string xs)] - [tester (car xs)]) - (all (ƒ(x) (equal? tester x)) (cdr xs)))) - -(define (int x) - (cond - [(integer? x) x] - [(boolean? x) (if x 1 0)] - [(real? x) (floor x)] - [(string? x) (if (= (len x) 1) - (int (car (string->list x))) ; treat as char - (int (string->number x)))] - [(symbol? x) (int (as-string x))] - [(char? x) (char->integer x)] - [(empty? x) 0] - [(or (list? x) (hash? x) (vector? x)) (len x)] - [else (error "Can't convert to integer:" x)])) - -(define (str . x) - (string-join (map as-string x) "")) - -(define (len x) - (cond - [(list? x) (length x)] - [(string? x) (string-length x)] - [(symbol? x) (len (as-string x))] - [(vector? x) (vector-length x)] - [(hash? x) (len (hash-keys x))] - [else #f])) - -(define (change x i value) - ; general-purpose mutable data object setter - (cond - [(vector? x) (vector-set! x i value)] - [(hash? x) (hash-set! x i value)] - [else (error "Can't set this datatype using !")])) - -(define (get x i [j #f]) - (when (and (or (list? x) (string? x) (vector? x)) j) - (cond - [(and (real? j) (< j 0)) (set! j (+ (len x) j))] - [(equal? j 'end) (set! j (len x))])) - - (cond - [(list? x) (if j - (for/list ([index (range i j)]) - (get x index)) - (list-ref x i))] - [(vector? x) (if j - (for/vector ([index (range i j)]) - (get x index)) - (vector-ref x i))] - [(string? x) (if j - (substring x i j) - (get x i (add1 i)))] - [(symbol? x) (as-symbol (get (as-string x) i j))] - [(hash? x) (if j - (error "get: third arg not supported for hash") - (hash-ref x i))] - [else #f])) - -(define (in? container element) - (cond - [(list? container) (member element container)] - [(hash? container) (hash-has-key? container element)] - ; todo: should this handle arbitrary-length substrings? - ; leaning toward no, because it breaks the string-as-array-of-characters abstraction - [(string? container) (let ([result (in? (map as-string (string->list container)) (as-string element))]) - (if result - (string-join result "") - #f))] - [(symbol? container) (let ([result (in? (as-string container) element)]) - (if result - (as-symbol result) - result))] - [else #f])) - -(define (to-lc x) - (string-downcase x)) - -(define (to-uc x) - (string-upcase x)) - -; python-style string testers -(define (starts-with? string starter) - (if (<= (len starter) (len string)) - (equal? (get string 0 (len starter)) starter) - #f)) - -(define (ends-with? string ender) - (if (<= (len ender) (len string) ) - (equal? (get string (- (len string) (len ender)) 'end) ender) - #f)) - -; coercions -(define (as-path thing) - (set! thing - (if (string? thing) - (string->path thing) - thing)) - (when (not (path? thing)) (error (format "Can't make ~a into path" thing))) - thing) - -(define (as-list thing) - (set! thing - (if (not (list? thing)) - (list thing) - thing)) - (when (not (list? thing)) (error (format "Can't make ~a into list" thing))) - thing) - -; nice way of converting to string -(define (as-string x) - (set! x (cond - [(empty? x) ""] - [(symbol? x) (symbol->string x)] - [(number? x) (number->string x)] - [(path? x) (path->string x)] - [(char? x) (~a x)] - [else x])) - (when (not (string? x)) (error (format "Can't make ~a into string" x))) - x) - -; nice way of converting to symbol -; todo: on bad input, it will pop a string error rather than symbol error -(define (as-symbol thing) - (string->symbol (as-string thing))) - -; nice way of converting to path -(define (as-complete-path thing) - (path->complete-path (as-path thing))) - -; any & all & none -(define (any tests things) - (ormap (ƒ(test) (ormap test (as-list things))) (as-list tests))) - -(define (all tests things) - (andmap (ƒ(test) (andmap test (as-list things))) (as-list tests))) - -(define (none test things) (not (any test things))) - - -; Other possibilities -; trim -; split \ No newline at end of file +;; general way of coercing to string +(define/contract (as-string x) + (any/c . -> . string?) + (cond + [(empty? x) ""] + [(symbol? x) (symbol->string x)] + [(number? x) (number->string x)] + [(path? x) (path->string x)] + [(char? x) (~a x)] + [else (error (format "Can't make ~a into string" x))])) + + +(module+ test + (require rackunit) + (check-equal? (as-string '()) "") + (check-equal? (as-string 'foo) "foo") + (check-equal? (as-string 123) "123") + (define file-name-as-text "foo.txt") + (check-equal? (as-string (string->path file-name-as-text)) file-name-as-text) + (check-equal? (as-string #\¶) "¶") + ) \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index 537b986..c722468 100644 --- a/tools.rkt +++ b/tools.rkt @@ -1,598 +1,87 @@ #lang racket/base -(require racket/list) -(require xml) -(require (only-in racket/function thunk)) -(require racket/string) -(require racket/file) -(require xml/path) -(require (only-in racket/format ~a ~s ~v)) -(require (prefix-in scribble: (only-in scribble/decode whitespace?))) +(require "readability.rkt") +(require racket/contract racket/match) (require (only-in racket/path filename-extension)) -(require (only-in (planet mb/pollen/library/html) inline-tags)) -(require (planet mb/pollen/world)) -(require (planet mb/pollen/readability)) -;(require (planet mb/pollen/hyphenate)) - - -(define nbsp " ") ; use this for readability in code -(define lozenge "◊") ; use this instead of escape syntax - -(provide (all-defined-out) - describe whitespace? xexpr->string xexpr? filter-not flatten - (all-from-out (planet mb/pollen/readability))) - -(define (hash-ref-or hash key [default #f]) - (if (in? hash key) - (get hash key) - default)) - -(define (make-meta-hash x) - (define keys (se-path*/list '(meta #:name) x)) - (define values (se-path*/list '(meta #:content) x)) - (define meta-hash (make-hash)) - ;todo: convert this to for/list because map does not guarantee ordering - ; probably want to keep it in sequence - (map (ƒ(key value) (change meta-hash (as-symbol key) (as-string value))) keys values) - meta-hash) - - -(define (magic-directory? path) - (and (directory-exists? path) - (or (ends-with? (path->string path) "requires") - (ends-with? (path->string path) "compiled") - ))) - -(define (filename-of path) - (let-values ([(dir filename ignored) (split-path path)]) - filename)) - -(define (pollen-script? path) - (let ([path-string (path->string (filename-of path))]) - (or (starts-with? path-string "pollen_") (starts-with? path-string "pollen-")))) - -(define (racket-file? path) - (has-ext? path 'rkt)) - -(define (pmap-source? path) - (has-ext? path POLLEN_MAP_EXT)) - -(define (template-source? path) - (starts-with? (path->string (filename-of path)) (~a TEMPLATE_FILE_PREFIX))) - -(define (preproc-source? path) - (has-ext? path POLLEN_PREPROC_EXT)) - -(define (make-preproc-in-path path) - (add-ext path POLLEN_PREPROC_EXT)) - -(define (make-preproc-out-path path) - (remove-ext path)) - -(define (has-preproc-source? path) - (file-exists? (make-preproc-in-path path))) - - -(define (pollen-source? path) - (has-ext? path POLLEN_SOURCE_EXT)) - -(define (make-pollen-source-path thing) - (add-ext (remove-ext (as-path thing)) POLLEN_SOURCE_EXT)) - -(define (has-pollen-source? path) - (file-exists? (make-pollen-source-path path))) - - - - -(define (insert-subdir path [subdir-in OUTPUT_SUBDIR]) - (let-values ([(dir filename ignored) (split-path path)]) - (when (equal? dir 'relative) - (set! dir (string->path "."))) - (letrec ([subdir-name (string->path (~a subdir-in))] - [subdir (build-path dir subdir-name)]) - (when (not (directory-exists? subdir)) - (make-directory subdir)) - (build-path subdir filename)))) - - -;;;;;;;;;;;;;; -; Moved from template.rkt -;;;;;;;;;;;;;; - -; All from* functions should return a named-xexpr - -(define (from x query) - ; cache x - (let ([x (put x)]) - ; try finding it in metas, if not, find it in main, if not then return false - (or (from-metas x query) (from-main x query)))) - -(define (from-main x query) ; this used to be plain from - ; check results first - (let* ([x (put x)] - [results (se-path*/list (list query) x)]) - ; if results exist, send back xexpr as output - (if (not (empty? results)) - `(,query ,@results) ; todo: why use query as tag? - #f))) - -(define (from-metas x key) - (let* ([x (put x)] - [meta-hash (make-meta-hash x)] - [key (as-symbol key)]) - (if (in? meta-hash key) - `(value ,(get meta-hash key)) ;todo: why use value as tag? - #f))) - - -(define (put x) - ; handles either xexpr or pollen file as input - (cond - ; pass through xexpr as is - ; put is optional for xexprs. - ; it's only here to make the idiom smooth. - [(named-xexpr? x) x] - ; todo: how to externalize pollen main tag into world name? - [(file-exists? (as-path x)) (dynamic-require x 'main)] - ; also try adding pollen file extension - ; this makes put compatible with map references - [(let ([x (make-pollen-source-path x)]) - (when (file-exists? x) - (put x)))] - [else (error "put: need named xexpr or pollen file, but got" x)])) - - -(define (merge x) - (cond - [(named-xexpr? x) - ; return content of xexpr. - ; pollen language rules will splice these into the main flow. - (if (empty? x) - "" - (let-values([(name attr content) (xexplode x)]) - content))] - [(string? x) (list x)])) - - -#|(define (merge-strings x) - (when (empty? x) (error "merge-strings got empty x")) - ;todo: filter metas? - ; leaning toward no. Simplest behavior. - ; function is not intended to be used with whole pollen body anyhow. - (let ([x (merge x)]) - (string-join (filter string? (flatten x)) " ")))|# - -(define (merge-strings x) - (string-join (filter string? (flatten x)) " ")) - - -(define (make-html x) - (if (named-xexpr? x) - (xexpr->string x) - (let ([x (as-list x)]) - (when (all xexpr? x) - (string-join (map xexpr->string x) ""))))) - -; generate *-as-html versions of functions -(define-values (put-as-html merge-as-html merge-strings-as-html) - (apply values (map (ƒ(proc) (ƒ(x) (make-html (proc x)))) (list put merge merge-strings)))) - - -(define (as-literal x) - (set! x (flatten (list x))) ; coerce text or list to new list - (merge `(literal-thing ,@x))) - -(define (make-url x) - (if (exists? x) - (str x ".html") - "#")) ; funny null url that means "stay here" - - -;;;;;;;;;;;;;;;;;;;;;;;;; - - -; make these independent of local includes -(define (map-topic topic . subtopics) - `(,(string->symbol topic) ,@(filter-not whitespace? subtopics))) - -(define (meta key value) - `(meta ((name ,(as-string key))(content ,(as-string value))))) - -; scribble's whitespace function misses trailing spaces wrapped in a list -(define (whitespace? x) - (cond - [(list? x) (all scribble:whitespace? x)] - [else (scribble:whitespace? x)])) - - - -; remove empty elements -(define (remove-empty x) - (cond - [(list? x) (map remove-empty (filter-not empty? x))] - [else x])) - -(define (remove-void x) - (cond - [(list? x) (map remove-void (filter-not void? x))] - [else x])) - -; common idiom with lists: -; if list is empty, return empty -; otherwise do procedure -(define (empty/else thing proc) - (if (empty? thing) - empty - (proc thing))) - -; common idiom with files: -; if the file exists, do procedure with it -(define (file-exists?/do path proc) - (if (file-exists? path) - (proc path) - #f)) - -; simple timer -(define-syntax-rule (time expr) - (begin - (define start-time (current-inexact-milliseconds)) - (define result expr) - (define stop-time (current-inexact-milliseconds)) - (message "Time for" 'expr "=" (- stop-time start-time)) - result)) - - -; utilities for working with file extensions -(define (.+ x) (format ".~a" x)) - -(define (get-ext path) - (bytes->string/utf-8 (filename-extension path))) - -(define (has-ext? path ext) - (let ([path-ext (filename-extension path)]) - ; returns true if f-ext exists, and equals ext, otherwise false - (and path-ext (equal? (bytes->string/utf-8 path-ext) (~a ext))))) - -(define (remove-ext path) +(require (only-in racket/format ~a)) +(require (only-in xml xexpr?)) +(provide (all-defined-out)) + +;; setup for test cases +(module+ test + (require rackunit) + (define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt")) + (define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (apply values (map string->path foo-path-strings))) + ;; test the sample paths before using them for other tests + (define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path)) + (for-each check-equal? (map path->string foo-paths) foo-path-strings)) + + +;; does path have a certain extension +(define/contract (has-ext? path ext) + (path? symbol? . -> . boolean?) + (define ext-of-path (filename-extension path)) + (and ext-of-path (equal? (bytes->string/utf-8 ext-of-path) (as-string ext)))) + +(module+ test + (check-equal? (has-ext? foo-path 'txt) #f) + (check-equal? (has-ext? foo.txt-path 'txt) #t) + (check-equal? (has-ext? foo.bar.txt-path 'txt) #t)) + + +;; take one extension off path +(define/contract (remove-ext path) + (path? . -> . path?) (path-replace-suffix path "")) -(define (add-ext path ext) - (string->path (string-append (path->string path) (.+ ext)))) - -; find all xexpr names within another xexpr -(define (gather-xexpr-names x) - (cond - [(named-xexpr? x) - (let-values([(name attr content) (xexplode x)]) - (flatten (cons name (map gather-xexpr-names content))))] - [else empty])) - - - -; shorthand for define + dynamic require -(define-syntax-rule (define-from module symbol) - (define symbol (dynamic-require module 'symbol))) +(module+ test + (check-equal? (remove-ext foo-path) foo-path) + (check-equal? (remove-ext foo.txt-path) foo-path) + (check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)) -; dynamic require or return false if not found -; allows constructs like: -; (or (require-now module symbol) "default value") -(define (require-now module symbol) - (dynamic-require module symbol (thunk #f))) +;; take all extensions off path +(define/contract (remove-all-ext path) + (path? . -> . path?) + (define path-with-removed-ext (remove-ext path)) + (if (equal? path path-with-removed-ext) + path + (remove-all-ext path-with-removed-ext))) -; define & provide in one easy step -(define-syntax-rule (define/provide name expr ...) - (begin (define name expr ...)(provide name))) +(module+ test + (check-equal? (remove-all-ext foo-path) foo-path) + (check-equal? (remove-all-ext foo.txt-path) foo-path) + (check-equal? (remove-all-ext foo.bar.txt-path) foo-path)) -; xexpr->html -(define (xexpr->html x) - ; (string-join (map xexpr->string x))) - (xexpr->string x)) -(define (html->xexpr . stuff) - (string->xexpr (string-join stuff ""))) - -; do a set of actions on same item -(define ((tee . procs) thing) - (apply values (map (ƒ(proc)(proc thing)) procs))) - -; python-style try/except syntax -(define-syntax-rule (try body (except tests ...)) - (with-handlers (tests ...) body)) - -; xexpr shortcut; map tag across items -(define (map-tag tag-name xs) - (map (ƒ(x) (list tag-name x)) xs)) - - -; trim from beginning & end of list -(define (trim things test) - (dropf-right (dropf things test) test)) - -; trim whitespace from beginning & end of list -(define (trim-whitespace things) - (trim things whitespace?)) - - -; ---------------------------- -; DECODER -; ---------------------------- - -(define (splice-xexpr-content x [acc '()]) - ; takes a list and splices top-level sublists into main list - ; used by merge function - (cond - [(empty? x) acc] - [(and (xexpr-content? (car x)) (not (named-xexpr? (car x)))) (splice-xexpr-content (cdr x) `(,@acc ,@(car x)))] - [else (splice-xexpr-content (cdr x) `(,@acc ,(car x)))])) - - -(define (named-xexpr? x) - ; meets basic xexpr contract, and is also a list starting with a symbol - ; todo: rewrite this using match? - ; todo: rewrite this recurively so errors can be pinpointed (for debugging) - (and (xexpr? x) (list? x) (symbol? (car x)))) - -(define (xexpr-attr-list? x) +;; is it an xexpr attributes? +(define/contract (xexpr-attrs? x) + (any/c . -> . boolean?) (define (attr-pair? x) ; list with two elements: first element is a symbol, second is a string - (and (list? x) (= (length x) 2) (symbol? (car x)) (string? (second x)))) + (and (list? x) (= (length x) 2) (symbol? (car x)) (string? (cadr x)))) ; a list where elements are attr pairs - (and (list? x) (all attr-pair? x))) - -(define (xexpr-content? x) - ; it's a list whose elements meet xexpr contract - (and (list? x) (all xexpr? x))) - -(define (xexpr-has-attrs? x) - (and (named-xexpr? x) (> (length x) 1) (xexpr-attr-list? (second x)))) - -(define (make-xexpr name (attr empty) (content empty)) - (when (not (symbol? name)) (error "make-xexpr: need a name, dude")) - (when (not (xexpr-attr-list? attr)) - (error "make-xexpr: attr must be list of attr pairs")) - ; todo: fix xexpr-content? test so I can use it here - ; (when (not (xexpr-content? content)) content) - (when (not (list? content)) (error "make-xexpr: content must be a list")) - - (define xexpr `(,name)) - (when (exists? attr) (set! xexpr `(,@xexpr ,attr))) - (when (exists? content) (set! xexpr `(,@xexpr ,@content))) - xexpr) - -(define (xexplode x) - (when (not (named-xexpr? x)) (error (format "xexplode: ~v not a named-xexpr" x))) - (define-values (name attr content) (values (car x) empty empty)) - (if (xexpr-has-attrs? x) - (set!-values (attr content) (values (second x) (cddr x))) ; attr comes back as a list of lists - (set! content (cdr x))) ; content always comes back as a list - (values name attr content)) - -; block 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))))) - -(define (wrap-paragraph x) ; x is a list containing paragraph pieces - ; if paragraph is just one block-level xexpr - (if (and (= (length x) 1) (block-xexpr? (car x))) - (car x) ; leave it - `(p ,@x))) ; otherwise wrap in p tag - - - -; wrap initial quotes for hanging punctuation -; todo: improve this -; does not handle

“thing properly -(define (wrap-hanging-quotes x) ; x is one paragraph - (define-values (name attr content) (xexplode x)) - (cond - [(and (not (empty? content)) - (string? (car content)) - (> (string-length (car content)) 1)) - (let ([new-car - (letrec ([x (car content)] - [first (get x 0)] - [rest (get x 1 'end)]) - (cond - [(member first '("\"" "“")) - ; this has to be span so that it's explicitly - ; an inline element. If not, - ; things like linebreak detection won't work. - `(span ((class "dquo")) ,(~a #\“) ,rest)] - [(member first '("\'" "‘")) - `(span ((class "squo")) ,(~a #\‘) ,rest)] - [else x]))]) - (make-xexpr name attr (cons new-car (cdr content))))] - [(and (exists? content) (named-xexpr? (car content))) - (make-xexpr name attr (cons (wrap-hanging-quotes (car content)) (cdr content)))] - [else x])) - - - -; how a list-item break is denoted: three or more newlines -(define (list-item-break? x) - (and (string? x) (regexp-match #rx"^\n\n\n+$" x))) - -; how a paragraph break is denoted: two or more newlines -(define (paragraph-break? x) - ; (equal? x PARAGRAPH_BREAK) ; obsolete: two newlines only - (and (string? x) (regexp-match #rx"^\n\n+$" x))) - -; convert single newline to br tag -; only if neither adjacent tag is a block -; otherwise delete -(define (convert-linebreaks x) ; x is list - (remove-empty - (for/list ([i (len x)]) - (cond - [(equal? (get x i) LINE_BREAK) - (if (none block-xexpr? (list (get x (sub1 i)) (get x (add1 i)))) - '(br) - '())] - [else (get x i)])))) - -; find two or more adjacent newlines and bring them together -; works on any number of newlines -(define (merge-newlines x) - (define (newline? x) - (and (string? x) (equal? "\n" x))) - (define (not-newline? x) - (not (newline? x))) - - (define (merge-newlines-inner x [acc '()]) ; x is list - (if (empty? x) - acc - (let-values ([(leading-newlines remainder) (splitf-at x newline?)]) - (if (not (empty? leading-newlines)) - (merge-newlines-inner remainder `(,@acc ,(string-join leading-newlines ""))) - (merge-newlines-inner (dropf remainder not-newline?) `(,@acc ,@(takef remainder not-newline?))))))) - - (cond - ((list? x) (merge-newlines-inner (map merge-newlines x))) - (else x))) - -(define (typogrify string) - ; make set of functions for replacers - (define (make-replacers query+subs) - (map (ƒ(q+s) (ƒ(str) (regexp-replace* (first q+s) str (second q+s)))) query+subs)) - - ; just store the query strings + replacement strings - (define dashes - ; fix em dashes first, else they'll be mistaken for en dashes - ; [\\s ] is whitespace + nonbreaking space - '((#px"[\\s ]*(---|—)[\\s ]*" "—") ; em dash - (#px"[\\s ]*(--|–)[\\s ]*" "–"))) ; en dash - - (define smart-quotes - '((#px"(?<=\\w)'(?=\\w)" "’") ; apostrophe - (#px"(?list str))]) - (define-values (last-word-chars other-chars) - (splitf-at reversed-str-list (λ(i) (not (eq? i #\space))))) - (list->string (reverse (append last-word-chars - ; OK for long words to be on their own line. - (if (< (len last-word-chars) minimum-word-length) - ; first char of other-chars will be the space, so use cdr - (cons nbsp (cdr other-chars)) - other-chars))))) - str)) - - (define (find-last-word-space x) ; recursively traverse xexpr - (cond - [(string? x) (replace-last-space x)] - [(named-xexpr? x) - (let-values([(name attr content) (xexplode x)]) - (if (> (length content) 0) ; content is list of xexprs - (let-values ([(all-but-last last) (split-at content (sub1 (length content)))]) - (make-xexpr name attr `(,@all-but-last ,(find-last-word-space (car last))))) - x))] - [else x])) - - (if (in? tags-to-pay-attention-to (car x)) - (find-last-word-space x) - x)) - -(define (prep-paragraph-flow x) - (convert-linebreaks (merge-newlines (trim-whitespace x)))) - -(define (map-xexpr-content proc x #:only [only-proc (ƒ(x) x)]) - ; why map and not apply? Because map guarantees a list of the same length. - ; whereas apply does not. So it works as an implied constraint. - (if (named-xexpr? x) - (let-values([(name attr content) (xexplode x)]) - (make-xexpr name attr (map (ƒ(x) (if (only-proc x) (proc x) x)) content))) - (error "map-xexpr-content: Input is not a named xexpr and has no content:" x))) - - -; Main decode function -(define (decode x) - (define (&decode x) - (cond - [(named-xexpr? x) - (let-values([(name attr content) (xexplode x)]) - (define decoded-x (make-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))))) - - -(define (splitf-at* pieces test) - ; split list into list of sublists using test - (define (splitf-at*-inner pieces [acc '()]) ; use acc for tail recursion - (if (empty? pieces) - acc - (let-values ([(item rest) - (splitf-at (dropf pieces test) (compose1 not test))]) - (splitf-at*-inner rest `(,@acc ,item))))) - (splitf-at*-inner (trim pieces test))) - -(define (make-missing-source-files map-xexpr) - ; use cdr to omit body tag - (define source-names (map (ƒ(x) (add-ext (string->path (as-string x)) POLLEN_SOURCE_EXT)) (flatten (cdr map-xexpr)))) - (define (make-source-if-missing x) - (if (not (file-exists? x)) - (begin - (display-to-file MISSING_FILE_BOILERPLATE x) - (format "Created file: ~a" x)) - (format "Already exists: ~a" x))) - (display (string-join (map make-source-if-missing source-names) "\n"))) - + (and (list? x) (andmap attr-pair? x))) + +;; is it xexpr content? +(define/contract (xexpr-content? x) + (any/c . -> . boolean?) + (and (list? x) (andmap xexpr? x))) + +;; is it a named x-expression? +;; todo: rewrite this recurively so errors can be pinpointed (for debugging) +(define/contract (named-xexpr? x) + (any/c . -> . boolean?) + (and (xexpr? x) ; meets basic xexpr contract + (match x + [(list (? symbol? name) rest ...) ; is a list starting with a symbol + (or (xexpr-content? rest) ; the rest is content or ... + (and (xexpr-attrs? (car rest)) (xexpr-content? (cdr rest))))] ; attributes followed by content + [else #f]))) + +(module+ test + (check-equal? (named-xexpr? "foo") #f) + (check-equal? (named-xexpr? '(p "foo" "bar")) #t) + (check-equal? (named-xexpr? '(p ((key "value")) "foo" "bar")) #t) + (check-equal? (named-xexpr? '(p "foo" "bar" ((key "value")))) #f) + (check-equal? (named-xexpr? '("p" "foo" "bar")) #f) + (check-equal? (named-xexpr? '(p 123)) #t)) ; why is this so?