generic

quad/quad/atomize.rkt

@@ -1,6 +1,6 @@
 #lang debug racket/base
 (require racket/contract racket/match racket/list txexpr racket/dict sugar/list racket/function
-         "quad.rkt" "qexpr.rkt" "param.rkt")
+         "quad.rkt" "qexpr.rkt" "param.rkt" "generic.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
@@ -13,7 +13,7 @@
    ((hasheq 'foo "bar" 'zim "zam") . update-with .  (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
    '#hasheq((zim . "BANG") (foo . "zay") (toe . "jam"))))
 
-(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (qe aq))))])
+(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (elems aq))))])
   ;; collapse each sequence of whitespace aqs to the first one, and make it a space
   ;; also drop leading & trailing whitespaces
   ;; (same behavior as web browsers)
@@ -25,7 +25,7 @@
           (loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws)
                                       (pair? bs) ;; we follow bs
                                       (pair? ws)) ;; we have ws
-                                 (quad (qa (car ws)) #\space)
+                                 (quad (attrs (car ws)) #\space)
                                  null)) rest)))))
 
 (module+ test

quad/quad/break.rkt

@@ -1,6 +1,6 @@
 #lang debug racket/base
 (require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt)
-         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt")
+         "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt")
 
 (define+provide/contract (insert-breaks xs
                                 [target-size (current-line-width)]
@@ -65,15 +65,15 @@
 (define d (q (hasheq 'size (delay (values 1 1 1))) #\d))
 (define sp (q (hasheq 'size (delay (values 0 1 0))) #\space))
 (define br (q (hasheq 'size (delay (values 0 0 0))) #\newline))
-(define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space)))))
+(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space)))))
 
 (define (lbs xs size [debug #f])
   (insert-breaks xs size debug
                  #:break-val 'lb
-                 #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (qe q)) '(#\newline))))
+                 #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
                  #:optional-break-proc optional-break?
-                 #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ ()
-                                                                        (if (memv (car (qe q)) '(#\space))
+                 #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
+                                                                        (if (memv (car (elems q)) '(#\space))
                                                                             (delay (values 0 1 0))
                                                                             (delay (values 1 1 1)))))])
                                       (if (promise? val) (force val) (val))))))
@@ -141,7 +141,7 @@
   (define (visual-breaks str int)
     (apply string (for/list ([b (in-list (lbs (atomize str) int))])
                     (cond
-                      [(quad? b) (car (qe b))]
+                      [(quad? b) (car (elems b))]
                       [else #\|]))))
 
   (test-case
@@ -167,7 +167,7 @@
   (define (pbs xs size [debug #f])
     (insert-breaks xs size debug
                    #:break-val 'pb
-                   #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (qe x)) '(#\page))))
+                   #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
                    #:optional-break-proc (λ (x) (eq? x 'lb))
                    #:size-proc (λ (q) (case q
                                         [(lb) (values 0 0 0)]
@@ -206,10 +206,10 @@
 (define (lbs2 xs size [debug #f])
   (insert-breaks xs size debug
                  #:break-val 'lb
-                 #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (qe q)) '(#\newline))))
+                 #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
                  #:optional-break-proc optional-break?
-                 #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ ()
-                                                                        (if (memv (car (qe q)) '(#\space))
+                 #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
+                                                                        (if (memv (car (elems q)) '(#\space))
                                                                             (delay (values 0 1 0))
                                                                             (delay (values 1 1 1)))))])
                                       (if (promise? val) (force val) (val))))

quad/quad/generic.rkt

@@ -0,0 +1,12 @@
+#lang debug racket/base
+(require racket/generic)
+(provide (all-defined-out))
+
+(define-generics quad
+  (elems quad)
+  (attrs quad)
+  (entrance-point quad)
+  (exit-point quad)
+  (inner-point quad)
+  (size quad)
+  (draw quad))

quad/quad/qexpr.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require xml racket/contract racket/string racket/match racket/list txexpr "quad.rkt")
+(require xml racket/contract racket/string racket/match racket/list txexpr "quad.rkt" "generic.rkt")
 (provide (all-defined-out))
 
 (module+ test (require rackunit))
@@ -27,8 +27,7 @@
   (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 (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$")))
 
 (define/contract (qexpr #:clean-attrs? [clean-attrs? #f]
                         #:name [name 'q]
@@ -50,7 +49,7 @@
   (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)))]
+      [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->attrs (attrs x)) (map loop (elems x)))]
       [else x])))
 
 (define/contract (qml->qexpr x)

quad/quad/quad.rkt

@@ -1,10 +1,18 @@
-#lang sugar/debug racket/base
-(require racket/match racket/function)
+#lang debug racket/base
+(require racket/match racket/function "generic.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
-(struct $quad (attrs elems) #:transparent)
-(define quad? $quad?)
+(struct $quad (attrs elems) #:transparent
+  #:methods gen:quad
+  [(define (elems q) ($quad-elems q))
+   (define (attrs q) ($quad-attrs q))
+   (define (entrance-point q) (hash-ref (attrs q) 'entrance 'entrance))
+   (define (exit-point q) (hash-ref (attrs q) 'exit 'exit))
+   (define (inner-point q) (hash-ref (attrs q) 'inner 'inner))
+   (define (size q) (length (elems q)))
+   (define (draw q) "<···>")])
+
 (define (quad-attrs? x) (and (hash? x) (hash-eq? x)))
 (define (quad-elem? x) (or (char? x) (string? x) ($quad? x)))
 (define (quad-elems? xs) (and (pair? xs) (andmap quad-elem? xs)))
@@ -14,8 +22,9 @@
     [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (type attrs elems)]
     [(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)]
     [else (error 'bad-quad-input)]))
+(define q quad)
 (define (quads? xs) (andmap quad? xs))
-(define (atomic-quad? x) (and (quad? x) (match (qe x)
+(define (atomic-quad? x) (and (quad? x) (match (elems x)
                                           [(list (? char?)) #t]
                                           [else #f])))
 (define (atomic-quads? xs) (andmap atomic-quad? xs))
@@ -23,15 +32,8 @@
   (check-true (atomic-quad? ($quad '#hasheq() '(#\H))))
   (check-true (atomic-quads? (list ($quad '#hasheq() '(#\H))))))
 
-(define quad-attrs $quad-attrs)
-(define quad-elems $quad-elems)
-
-(define q quad)
-(define q? quad?)
-(define qs? quads?)
-(define qa quad-attrs)
-(define qe quad-elems)
 
 (struct $break $quad () #:transparent)
 (define (break . xs) (apply quad #:type $break xs))
 (define b break)
+

quad/quad/typewriter.rkt

@@ -1,11 +1,11 @@
 #lang debug br/quicklang
-(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt")
+(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt" "generic.rkt")
 (provide (rename-out [mb #%module-begin]))
 
-(define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space)))))
+(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space)))))
 (struct $shim $quad () #:transparent)
 (struct $char $quad () #:transparent)
-(define (charify q) ($char (qa q) (qe q)))
+(define (charify q) ($char (attrs q) (elems q)))
 (define (shimify xs) (add-between (map charify xs)
                                   (list ($shim (hasheq) null))
                                   #:splice? #t
@@ -20,8 +20,8 @@
   (insert-breaks xs size debug
                  #:break-val (break #\newline)
                  #:optional-break-proc optional-break?
-                 #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ ()
-                                                                        (if (memv (car (qe q)) '(#\space))
+                 #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ ()
+                                                                        (if (memv (car (elems q)) '(#\space))
                                                                             (delay (values 0 1 0))
                                                                             (delay (values 1 1 1)))))])
                                       (if (promise? val) (force val) (val))))
@@ -31,7 +31,7 @@
   (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 (attrs q) 'size (λ () (delay (values 1 1 1))))))
                  #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs))))))
 
 (define (typeset args)