qexpring

quad/quad/qexpr.rkt

@@ -1,5 +1,5 @@
-#lang racket/base
-(require xml racket/contract racket/match racket/list txexpr)
+#lang debug racket/base
+(require xml racket/contract racket/string racket/match racket/list txexpr "quad.rkt")
 (provide (all-defined-out))
 
 (module+ test (require rackunit))
@@ -10,26 +10,33 @@
   (any/c . -> . boolean?)
   (define (valid-tag? tag) (and (memq tag '(q quad)) #t))
   (match x
-    [(? txexpr?) (valid-tag? (get-tag x))]
-    [(list (? symbol? tag) (? char? c)) (valid-tag? tag)]
+    [(? txexpr?) #t]
+    [(list (? symbol? tag) (? char? c)) #t]
     [(? string?) #t]
     [else #f]))
 
+
 (module+ test
   (check-true (qexpr? "Hello world"))
   (check-true (qexpr? '(q "Hello world")))
   (check-true (qexpr? '(quad "Hello world")))
-  (check-false (qexpr? '(div "Hello world")))
+  #;(check-false (qexpr? '(div "Hello world")))
   (check-true (qexpr? '(q #\H)))
   (check-true (qexpr? '(quad #\H)))
-  (check-false (qexpr? '(span #\H)))
+  #;(check-false (qexpr? '(span #\H)))
   (check-true (qexpr? '(quad "Hello world")))
   (check-false (qexpr? 'q)))
 
+(define (quad-name q)
+  (string->symbol (string-trim (symbol->string (vector-ref (struct->vector q) 0)) "struct:$")))
+
 (define/contract (qexpr #:clean-attrs? [clean-attrs? #f]
+                        #:name [name 'q]
                         attrs . elems)
-  ((txexpr-attrs?) (#:clean-attrs? any/c) #:rest txexpr-elements? . ->* . qexpr?)
-  (txexpr 'q (if clean-attrs? (remove-duplicates attrs #:key car) attrs) elems))
+  ((txexpr-attrs?) (#:clean-attrs? any/c #:name txexpr-tag?) #:rest (or/c txexpr-elements? (list/c char?)) . ->* . qexpr?)
+  (txexpr name (if clean-attrs? (remove-duplicates attrs #:key car) attrs) (match elems
+                                                                             [(list (? char? c)) (list (string c))]
+                                                                             [else elems])))
 
 (module+ test
   (check-equal? (qexpr null "foo") '(q "foo"))
@@ -37,6 +44,15 @@
   (check-equal? (qexpr '((k "v2")(k "v1")) "foo") '(q ((k "v2")(k "v1")) "foo"))
   (check-equal? (qexpr #:clean-attrs? #t '((k "v2")(k "v1")) "foo") '(q ((k "v2")) "foo")))
 
+
+
+(define/contract (quad->qexpr q)
+  (quad? . -> . qexpr?)
+  (let loop ([x q])
+    (cond
+      [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->attrs (qa x)) (map loop (qe x)))]
+      [else x])))
+
 (define/contract (qml->qexpr x)
   (string? . -> . qexpr?)
   (parameterize ([permissive-xexprs #t]

quad/quad/typewriter.rkt

@@ -1,10 +1,11 @@
 #lang debug br/quicklang
-(require racket/promise "quad.rkt" "atomize.rkt" "break.rkt")
+(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt")
 (provide (rename-out [mb #%module-begin]))
 
 (define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space)))))
-(struct $slug $quad () #:transparent)
-(define (slug . xs) ($slug (hasheq) xs))
+(struct $line $quad () #:transparent)
+(struct $page $quad () #:transparent)
+(struct $doc $quad () #:transparent)
 (struct $break $quad () #:transparent)
 (define (break . xs) ($break (hasheq 'size (delay (values 0 0 0))) xs))
 (define (lbs xs size [debug #f])
@@ -16,16 +17,17 @@
                                                                             (delay (values 0 1 0))
                                                                             (delay (values 1 1 1)))))])
                                       (if (promise? val) (force val) (val))))
-                 #:finish-segment-proc (λ (pcs) (list ($slug (hasheq) pcs)))))
+                 #:finish-segment-proc (λ (pcs) (list ($line (hasheq) pcs)))))
 
 (define (pbs xs size [debug #f])
   (insert-breaks xs size debug
                  #:break-val (break #\page)
                  #:optional-break-proc $break?
-                 #:size-proc (λ (q) (force (hash-ref (qa q) 'size (λ () (delay (values 1 1 1))))))))
+                 #:size-proc (λ (q) (force (hash-ref (qa q) 'size (λ () (delay (values 1 1 1))))))
+                 #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs))))))
 
 (define (typeset args)
-  (pbs (lbs (atomize (apply quad #f args)) 3) 2))
+  (quad->qexpr ($doc (hasheq) (filter-not $break? (pbs (lbs (atomize (apply quad #f args)) 3) 2)))))
 
 (define-syntax-rule (mb lang-line-config-arg . args)
   (#%module-begin