updates

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))
+    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)))

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

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)

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")) "<foo>bar</foo>"))
 
 
 ;; general way of coercing to symbol

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) ""))
+
+

tests/template/put.pd

@@ -1,4 +1,4 @@
-#lang planet mb/pollen
+#lang pollen
 
 ◊em{One} paragraph
 

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)))