From af2209a0bae2a2c2c8c67c88da1258d7f1aa699f Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 7 Feb 2014 17:43:33 -0800 Subject: [PATCH] updates --- debug.rkt | 26 ++++++++++++++++++++++--- file-tools.rkt | 4 ++++ lang/reader.rkt | 6 +++--- readability.rkt | 8 +++++--- template.rkt | 33 +++++++++++++++++++++----------- tests/template/{put.p => put.pd} | 2 +- top.rkt | 7 +++++++ 7 files changed, 65 insertions(+), 21 deletions(-) rename tests/template/{put.p => put.pd} (53%) diff --git a/debug.rkt b/debug.rkt index a4414e3..02e2408 100644 --- a/debug.rkt +++ b/debug.rkt @@ -4,14 +4,15 @@ (require racket/format) -(provide describe report message make-datestamp make-timestamp) +(provide describe report message make-datestamp make-timestamp display-stack-trace) ; todo: contracts, tests, docs (require (prefix-in williams: (planet williams/describe/describe))) (define (describe x) - (williams:describe x) + (parameterize ([current-output-port (current-error-port)]) + (williams:describe x)) x) ; debug utilities @@ -75,4 +76,23 @@ (define-syntax-rule (report var) (begin (basic-message 'var "=" var) - var)) \ No newline at end of file + var)) + + + +(define (exn+stack->string exn) + (string-append + (string-append "Exception: " (exn-message exn)) + "\n" + "Stack:\n" + (string-join + (map (lambda (x) + (format "'~a' ~a ~a" + (if (car x) (car x) "") + (if (cdr x) (srcloc-source (cdr x)) "") + (if (cdr x) (srcloc-line (cdr x)) ""))) + (continuation-mark-set->context (exn-continuation-marks exn))) + "\n"))) + +(define (display-stack-trace exn) + (displayln (exn+stack->string exn))) \ No newline at end of file diff --git a/file-tools.rkt b/file-tools.rkt index 805bfef..e07f4c9 100644 --- a/file-tools.rkt +++ b/file-tools.rkt @@ -303,4 +303,8 @@ (symbol? . -> . (listof complete-path?)) (map ->complete-path (filter (λ(i) (has-ext? i ext)) (directory-list PROJECT_ROOT)))) +;; to identify unsaved sources in DrRacket +(define (unsaved-source? path-string) + ((substring (->string path-string) 0 7) . equal? . "unsaved")) + ;; todo: write tests for project-files-with-ext diff --git a/lang/reader.rkt b/lang/reader.rkt index e763d5f..9c866b4 100644 --- a/lang/reader.rkt +++ b/lang/reader.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (only-in scribble/reader make-at-reader) (only-in "../world.rkt" EXPRESSION_DELIMITER) - (only-in "../file-tools.rkt" preproc-source?)) + (only-in "../file-tools.rkt" preproc-source? unsaved-source?)) (provide (rename-out [mb-read read] [mb-read-syntax read-syntax]) @@ -23,10 +23,10 @@ (define (mb-read-syntax path-string p) - (define i (read-inner path-string p)) + (define i (read-inner path-string p)) (datum->syntax i ;; select pollen dialect based on file type - `(module pollen-lang-module ,(if (preproc-source? path-string) + `(module pollen-lang-module ,(if (or (preproc-source? path-string) (unsaved-source? path-string)) 'pollen/main-preproc 'pollen/main) ,@i) diff --git a/readability.rkt b/readability.rkt index 8a511b5..219a83b 100644 --- a/readability.rkt +++ b/readability.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/contract net/url) +(require racket/contract net/url xml) (require (only-in racket/list empty? range splitf-at dropf dropf-right)) (require (only-in racket/format ~a)) (require (only-in racket/string string-join)) @@ -31,9 +31,10 @@ [(empty? x) ""] [(symbol? x) (symbol->string x)] [(number? x) (number->string x)] - [(url? x) (->string (->path x))] + [(url? x) (->string (->path x))] ; todo: a url is more than just a path-string ... it has character encoding issues [(path? x) (path->string x)] [(char? x) (~a x)] + [(xexpr? x) (xexpr->string x)] ; put this last so other xexprish things don't get caught [else (error (format "Can't make ~a into string" x))])) (module+ test @@ -44,7 +45,8 @@ (check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html") (define file-name-as-text "foo.txt") (check-equal? (->string (string->path file-name-as-text)) file-name-as-text) - (check-equal? (->string #\¶) "¶")) + (check-equal? (->string #\¶) "¶") + (check-equal? (->string '(foo "bar")) "bar")) ;; general way of coercing to symbol diff --git a/template.rkt b/template.rkt index 085806b..41a91f5 100644 --- a/template.rkt +++ b/template.rkt @@ -17,7 +17,7 @@ (any/c . -> . boolean?) (or (tagged-xexpr? x) (has-pollen-source? x) - (has-pollen-source? (pnode->url x)))) + (and (pnode->url x) (has-pollen-source? (pnode->url x))))) (define/contract (query-key? x) (any/c . -> . boolean?) @@ -33,20 +33,21 @@ (module+ test (check-equal? (put '(foo "bar")) '(foo "bar")) - (check-equal? (put "tests/template/put.p") + (check-equal? (put "tests/template/put.pd") '(root "\n" "\n" (em "One") " paragraph" "\n" "\n" "Another " (em "paragraph") "\n" "\n"))) -(define/contract (find px query) - (puttable-item? query-key? . -> . (or/c xexpr-elements? false?)) - (or (find-in-metas px query) (find-in-main px query))) +(define/contract (find query px) + (query-key? puttable-item? . -> . (or/c xexpr-element? false?)) + (define result (or (find-in-metas px query) (find-in-main px query))) + (and result (car result))) ;; return false or first element (module+ test (parameterize ([current-directory "tests/template"]) - (check-false (find "put" "nonexistent-key")) - (check-equal? (find "put" "foo") (list "bar")) - (check-equal? (find "put" "em") (list "One" "paragraph")))) + (check-false (find "nonexistent-key" "put")) + (check-equal? (find "foo" "put") "bar") + (check-equal? (find "em" "put") "One"))) (define/contract (find-in-metas px key) (puttable-item? query-key? . -> . (or/c xexpr-elements? false?)) @@ -59,9 +60,8 @@ (parameterize ([current-directory "tests/template"]) (check-equal? (find-in-metas "put" "foo") (list "bar")) (let* ([metas (dynamic-require (->pollen-source-path 'put) 'metas)] - [here (find-in-metas 'put 'here)] - [here-relative (list (->string (find-relative-path (current-directory) (car here))))]) - (check-equal? here-relative (list "put"))))) + [here (find-in-metas 'put 'here)]) + (check-equal? here (list "tests/template/put"))))) (define/contract (find-in-main px query) @@ -108,3 +108,14 @@ ; generate *-as-html versions of functions (define-values (put-as-html splice-as-html) (apply values (map (λ(proc) (λ(x) (make-html (proc x)))) (list put splice)))) + +(define ->html put-as-html) + + +;; improves the syntax for conditional blocks in templates +;; ordinarily it would be ◊when[condition]{◊list{stuff ...}} +;; now it can be ◊when/block[condition]{stuff ...} +(define (when/block condition . strings) + (if condition (string-append* strings) "")) + + diff --git a/tests/template/put.p b/tests/template/put.pd similarity index 53% rename from tests/template/put.p rename to tests/template/put.pd index 9a17da4..564af9d 100644 --- a/tests/template/put.p +++ b/tests/template/put.pd @@ -1,4 +1,4 @@ -#lang planet mb/pollen +#lang pollen ◊em{One} paragraph diff --git a/top.rkt b/top.rkt index 27d65a2..ede73cb 100644 --- a/top.rkt +++ b/top.rkt @@ -1,5 +1,12 @@ #lang racket +;; Changes the default behavior of #%top. +;; Unbound identifiers are allowed, and treated as the +;; tag in a tagged-xexpr (with the rest of the expression treated as the body) +;; To suppress this behavior, use bound/c to wrap any name. +;; If that name isn't already defined, you'll get the usual syntax error. + + (provide (except-out (all-defined-out) top~) (rename-out (top~ #%top)))