From 49611c8053388a087e9b2db78b17f844e9305420 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 8 Aug 2013 17:21:35 -0700 Subject: [PATCH] Upgrading decode --- decode.rkt | 99 ++++++++++++++++++++++++++++++----- readability.rkt | 30 ++++++----- tests/pollen-lang-test.p | 2 + tests/requires/include-me.rkt | 23 +++++++- tools.rkt | 6 ++- 5 files changed, 130 insertions(+), 30 deletions(-) diff --git a/decode.rkt b/decode.rkt index cd7426b..29fd43f 100644 --- a/decode.rkt +++ b/decode.rkt @@ -1,7 +1,5 @@ #lang racket/base -(require racket/contract) -(require racket/list) -(require racket/string) +(require racket/contract racket/list racket/string racket/match) (require (only-in racket/format ~a)) (require (only-in racket/bool nor)) (require (only-in xml xexpr/c)) @@ -52,7 +50,7 @@ ;; todo: make sure this is what I want. ;; this is, however, more consistent with browser behavior ;; (browsers assume that tags are inline by default) - (->boolean (in block-tags (named-xexpr-name nx)))) + (->boolean ((named-xexpr-name nx) . in . block-tags))) (module+ test (check-true (block-xexpr? '(p "foo"))) @@ -61,7 +59,9 @@ (check-false (block-xexpr? '(barfoo "foo")))) -(define (stringify x) ; convert numbers to strings +;; convert numbers to strings +;; maybe this isn't necessary +(define (stringify x) (map-tree (λ(i) (if (number? i) (->string i) i)) x)) (module+ test @@ -94,18 +94,91 @@ (check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n"))))) -;; default content decoder for pollen -(define/contract (decode nx) +#| + +(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) + +|# + + +;; decoder wireframe +(define/contract (decode nx + #:exclude-xexpr-names [excluded-xexpr-names '()] + #:xexpr-name-proc [xexpr-name-proc (λ(x)x)] + #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)] + #:xexpr-content-proc [xexpr-content-proc #f] ; set this to &decode later + #:block-xexpr-proc [block-xexpr-proc (λ(x)x)] + #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)] + #:string-proc [string-proc (λ(x)x)] + #:meta-proc [meta-proc (λ(x)x)]) ;; use xexpr/c for contract because it gives better error messages - (xexpr/c . -> . named-xexpr?) + ((xexpr/c) (#:exclude-xexpr-names (λ(i) (or (symbol? i) (list? i))) + #:xexpr-name-proc procedure? + #:xexpr-attr-proc procedure? + #:xexpr-content-proc procedure? + #:block-xexpr-proc procedure? + #:inline-xexpr-proc procedure? + #:string-proc procedure? + #:meta-proc procedure?) + . ->* . named-xexpr?) + (when (not (named-xexpr? nx)) + (error (format "decode: ~v not a full named-xexpr" nx))) + + (define metas (list)) + (define/contract (is-meta? x) + (any/c . -> . (λ(i) (or (boolean? i) (list? i)))) + (match x + [`(meta ,(? string? key) ,(? string? value)) (list key value)] + [else #f])) - ;; weds aug 7: start here (define (&decode x) - x) + (cond + [(named-xexpr? x) (let-values([(name attr content) (break-named-xexpr x)]) + (if (name . in . (->list excluded-xexpr-names)) + x + (let ([decoded-xexpr + (apply make-named-xexpr (map &decode (list name attr content)))]) + (if (block-xexpr? decoded-xexpr) + (block-xexpr-proc decoded-xexpr) + (inline-xexpr-proc decoded-xexpr)))))] + [(xexpr-name? x) (xexpr-name-proc x)] + [(xexpr-attr? x) (xexpr-attr-proc x)] + [(xexpr-content? x) (let ([xexpr-content-proc (or xexpr-content-proc (λ(x) (map &decode x)))]) + (xexpr-content-proc x))] + [(string? x) (string-proc x)] + [else x])) - (&decode nx)) - -;(decode `(p ((key "value")) ,decode)) + ;; function to strip metas + ;; todo: would this be simpler using se-path*/list? + (define (split-metas nx) + (define meta-list '()) + (define (&split-metas x) + (cond + [(and (named-xexpr? x) (equal? 'meta (car x))) + (begin + (set! meta-list (cons x meta-list)) + empty)] + [(named-xexpr? x) ; handle named-xexpr + (let-values([(name attr body) (break-named-xexpr x)]) + (make-named-xexpr name attr (&split-metas body)))] + [(list? x) (filter-not empty? (map &split-metas x))] + [else x])) + (values (&split-metas nx) (reverse meta-list))) + + ;; put metas back on the end + (define (append-metas nx metas) + (named-xexpr? . -> . named-xexpr?) + (append nx (map meta-proc metas))) + + (let-values ([(nx metas) (split-metas nx)]) + (append-metas (&decode nx) metas))) #| ;; default content decoder for pollen diff --git a/readability.rkt b/readability.rkt index 1305172..c53d6d8 100644 --- a/readability.rkt +++ b/readability.rkt @@ -150,32 +150,34 @@ (check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'a) 1)) ;; general way of testing for membership (à la Python 'in') -(define/contract (in container item) +;; put item as first arg so function can use infix notation +;; (item . in . container) +(define/contract (in item container) (any/c any/c . -> . any/c) (cond [(list? container) (member item container)] ; returns #f or sublist beginning with item [(vector? container) (vector-member item container)] ; returns #f or zero-based item index [(hash? container) (and (hash-has-key? container item) (get container item))] ; returns #f or hash value - [(string? container) (let ([result (in (map ->string (string->list container)) (->string item))]) + [(string? container) (let ([result ((->string item) . in . (map ->string (string->list container)))]) (if result (string-join result "") #f))] ; returns #f or substring beginning with item - [(symbol? container) (let ([result (in (->string container) (->string item))]) + [(symbol? container) (let ([result ((->string item) . in . (->string container))]) (if result (->symbol result) result))] ; returns #f or subsymbol (?!) beginning with item [else #f])) (module+ test - (check-equal? (in '(1 2 3) 2) '(2 3)) - (check-false (in '(1 2 3) 4)) - (check-equal? (in (list->vector '(1 2 3)) 2) 1) - (check-false (in (list->vector '(1 2 3)) 4)) - (check-equal? (in (make-hash '((a . 1) (b . 2) (c . 3))) 'a) 1) - (check-false (in (make-hash '((a . 1) (b . 2) (c . 3))) 'x)) - (check-equal? (in "foobar" "o") "oobar") - (check-false (in "foobar" "z")) - (check-equal? (in 'foobar 'o) 'oobar) - (check-false (in 'foobar 'z)) - (check-false (in #\F "F"))) \ No newline at end of file + (check-equal? (2 . in . '(1 2 3)) '(2 3)) + (check-false (4 . in . '(1 2 3))) + (check-equal? (2 . in . (list->vector '(1 2 3))) 1) + (check-false (4 . in . (list->vector '(1 2 3)))) + (check-equal? ('a . in . (make-hash '((a . 1) (b . 2) (c . 3)))) 1) + (check-false ('x . in . (make-hash '((a . 1) (b . 2) (c . 3))))) + (check-equal? ("o" . in . "foobar") "oobar") + (check-false ("z" . in . "foobar")) + (check-equal? ('o . in . 'foobar) 'oobar) + (check-false ('z . in . 'foobar)) + (check-false ("F" . in . #\F))) \ No newline at end of file diff --git a/tests/pollen-lang-test.p b/tests/pollen-lang-test.p index d3563ed..ccaf70e 100644 --- a/tests/pollen-lang-test.p +++ b/tests/pollen-lang-test.p @@ -4,6 +4,8 @@ Hello world +◊em{Love} + Goodnight moon ◊foo \ No newline at end of file diff --git a/tests/requires/include-me.rkt b/tests/requires/include-me.rkt index 12551e4..7be7189 100644 --- a/tests/requires/include-me.rkt +++ b/tests/requires/include-me.rkt @@ -1,13 +1,32 @@ #lang racket/base -(require racket/contract) +(require racket/contract racket/list) (require (planet mb/pollen/tools) (planet mb/pollen/decode)) (provide (all-defined-out)) (module+ test (require rackunit)) +(define (meta-proc meta) + `(meta ((name ,(->string (second meta)))(content ,(->string (third meta)))))) + +(define (string-proc string) + "puppies") + +(define (xexpr-content-proc content) + (map (λ(i) "boing") content)) + (define (root . items) (named-xexpr? . -> . named-xexpr?) - (decode `(root ,@items))) + (decode (cons 'root items) + #:exclude-xexpr-names 'em +; #:xexpr-name-proc [xexpr-name-proc (λ(x)x)] +; #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)] + ; #:xexpr-content-proc xexpr-content-proc +; #:block-xexpr-proc [block-xexpr-proc (λ(x)x)] +; #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)] + ; #:string-proc string-proc + ; #:meta-proc meta-proc + )) + (define foo "bar") \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index 45e4aa1..012c41b 100644 --- a/tools.rkt +++ b/tools.rkt @@ -58,6 +58,10 @@ (check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext (check-equal? (remove-all-ext foo.bar.txt-path) foo-path)) +;; is it an xexpr name? +(define/contract (xexpr-name? x) + (any/c . -> . boolean?) + (symbol? x)) ;; is it an xexpr attributes? (define/contract (xexpr-attr? x) @@ -219,6 +223,6 @@ (module+ test (check-equal? (map-tree (λ(i) (if (number? i) (* 2 i) i)) '(p 1 2 3 (em 4 5))) '(p 2 4 6 (em 8 10))) - (check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5)))) + (check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5))))