rerun

quad/qtest/hyphenate.rkt

@@ -14,13 +14,15 @@ At the command line:
 
 We said `raco pkg install hyphenate` dude
 
-What?!
 
 ```
 Code block
 Goes here
 ```
 
+
+What?!
+
 > Hyphenate `xexpr` by calculating hyphenation points and inserting
 `joiner` at those points. By default, `joiner` is the soft hyphen
 \(Unicode 00AD = decimal 173\). Words shorter than

quad/qtest/markdown.rkt

@@ -3,13 +3,25 @@
          pitfall quad sugar/debug pollen/tag)
 (provide (except-out (all-from-out racket/base) #%module-begin)
          (rename-out [mb #%module-begin])
-         p id strong em attr-list h1 h2 code pre a blockquote)
+         p id strong em attr-list h1 h2 h3 h4 h5 h6 
+         ol li ul rsquo lsquo rquo lquo hellip
+         hr
+         code pre a blockquote)
+
+(define rsquo "’")
+(define rquo "”")
+(define lsquo "‘")
+(define lquo "“")
+(define hellip "…")
 
 (define-tag-function (p attrs exprs)
   (qexpr attrs exprs))
 
+(define-tag-function (hr attrs exprs)
+  (qexpr (cons '(hrule "yes") attrs) '(" ")))
+
 (define-tag-function (blockquote attrs exprs)
-  (qexpr (cons '(container "bq") attrs) exprs))
+  (qexpr (list* '(container "bq") '(left-inset "5") attrs) exprs))
 
 (define id (default-tag-function 'id))
 (define class (default-tag-function 'class))
@@ -25,11 +37,16 @@
 
 (define-syntax-rule (attr-list . attrs) 'attrs)
 
-(define-tag-function (h1 attrs exprs)
-  (qexpr (append  '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs))
+(define (heading-base font-size attrs exprs)
+  (qexpr (append '((font "fira")(fontsize (number->string font-size))(line-height (number->string (+ 12 font-size)))) attrs) exprs))
+
+(define-tag-function (h1 attrs exprs) (heading-base 30 attrs exprs))
+(define-tag-function (h2 attrs exprs) (heading-base 24 attrs exprs))
+(define-tag-function (h3 attrs exprs) (heading-base 18 attrs exprs))
 
-(define-tag-function (h2 attrs exprs)
-  (qexpr (append '((font "fira")(fontsize "24")(line-height "36")) attrs)  exprs))
+(define h4 h3)
+(define h5 h3)
+(define h6 h3)
 
 (define-tag-function (code attrs exprs)
   (qexpr (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs)  exprs))
@@ -41,7 +58,18 @@
                                  [str (in-list (string-split (car (get-elements expr)) "\n"))])
                                 `(,(get-tag expr) ,(get-attrs expr) ,str))
                      lbr))
-  (qexpr attrs new-exprs))
+  (qexpr (list* '(container "codeblock") '(left-inset "12") '(right-inset "12") attrs) new-exprs))
+
+(define (list-base attrs exprs [bullet-val #f])
+  (qexpr (list* '(left-inset "20") attrs)
+         (add-between
+          (for/list ([(expr idx) (in-indexed exprs)])
+                    (list* (get-tag expr) (cons (list 'list-index (or bullet-val (format "~a." (add1 idx)))) (get-attrs expr)) (get-elements expr)))
+          pbr)))
+
+(define-tag-function (ol attrs exprs) (list-base attrs exprs))
+(define-tag-function (ul attrs exprs) (list-base attrs exprs "•"))
+(define-tag-function (li attrs exprs) (qexpr attrs exprs))  
 
 (define q:string (q #:in 'bi
                     #:out 'bo ;; align to baseline
@@ -59,7 +87,7 @@
                              (match-define (list x y) (quad-origin q))
                              (text doc str x y #:bg (hash-ref (quad-attrs q) 'bg #f)
                                    #:link (hash-ref (quad-attrs q) 'link #f)))
-                    #:draw-end (λ (q doc)  (draw-debug q doc "#99f" "#ccf"))))
+                    #:draw-end (λ (q doc) (draw-debug q doc "#99f" "#ccf"))))
 
 (define-runtime-path charter "fonts/charter.ttf")
 (define-runtime-path charter-bold "fonts/charter-bold.ttf")
@@ -96,9 +124,9 @@
               (define str (car (quad-elems q)))
               (pt (string-width doc str) (current-line-height doc)))])]))
 
-(define draw? #f)
+(define draw-debug? #t)
 (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
-  (when draw?
+  (when draw-debug?
     (save doc)
     (line-width doc 0.5)
     (apply rect doc (append (quad-origin q) (size q)))
@@ -121,8 +149,7 @@
 (define q:line-spacer (q #:type line-spacer
                          #:size (pt 380 (* line-height 0.6))
                          #:out 'sw
-                         #:printable (λ (q sig)
-                                       (not (memq sig '(start end))))
+                         #:printable (λ (q sig) (not (memq sig '(start end))))
                          #:draw-start draw-debug))
 
 (define softies (map string '(#\space #\- #\u00AD)))
@@ -150,39 +177,66 @@
 ;; treat paragraph break as special kind of line break
 (define-quad para-break line-break ())
 (define pbr (make-para-break #:printable #f))
+(define-quad hr-break para-break ())
+(define hrbr (make-hr-break #:printable #t))
 
 (module+ test
   (check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
   (check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
 
-(define (line-wrap xs size)
-  (wrap xs size
+(define (line-wrap xs wrap-size)
+  (wrap xs (λ (q idx) (- wrap-size (string->number (quad-ref q 'left-inset "0"))
+                         (string->number (quad-ref q 'right-inset "0"))))                        
         #:hard-break line-break?
         #:soft-break soft-break-for-line?
-        #:finish-wrap (λ (pcs q idx)
-                        (define new-elems (consolidate-runs pcs))
-                        (append
-                         (list (struct-copy quad q:line
-                                            [attrs (let ([attrs (hash-copy (quad-attrs q:line))])
-                                                     (define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f))
-                                                     (when (and container-val
-                                                                (for/and ([elem (in-list (cdr new-elems))])
-                                                                         (equal? (hash-ref (quad-attrs elem) 'container #f)
-                                                                                 container-val)))
-                                                       (hash-set! attrs 'container container-val))
-                                                     attrs)]
-                                            [size (let ()
-                                                    (define line-heights
-                                                      (filter-map
-                                                       (λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN")))
-                                                       pcs))
-                                                    (match-define (list w h) (quad-size q:line))
-                                                    ;; when `line-heights` is empty, this is just h
-                                                    (pt w (apply max (cons h line-heights))))]
-                                            [elems new-elems]))
-                         (if (para-break? q)
-                             (list q:line-spacer)
-                             null)))))
+        #:finish-wrap
+        (λ (pcs q idx)
+          (define new-elems (consolidate-runs pcs))
+          (append
+           (list (struct-copy quad q:line
+                              [attrs (let ([attrs (hash-copy (quad-attrs q:line))])
+                                       (define container-val (quad-ref (car new-elems) 'container))
+                                       (when (and container-val
+                                                  (for/and ([elem (in-list (cdr new-elems))])
+                                                           (equal? (quad-ref elem 'container)
+                                                                   container-val)))
+                                         (hash-set! attrs 'container container-val))
+                                       attrs)]
+                              [size (let ()
+                                      (define line-heights
+                                        (filter-map
+                                         (λ (q) (string->number (quad-ref q 'line-height "NaN")))
+                                         pcs))
+                                      (match-define (list w h) (quad-size q:line))
+                                      ;; when `line-heights` is empty, this is just h
+                                      (pt w (apply max (cons h line-heights))))]
+                              [elems new-elems]
+                              [offset (pt
+                                       (string->number (quad-ref (car new-elems) 'left-inset "0"))
+                                       (second (quad-offset q:line)))]
+                              [draw-start (if (quad-ref (car new-elems) 'hrule)
+                                                (λ (dq doc)
+                                                  (save doc)
+                                                  (match-define (list left top) (quad-origin dq))
+                                                  (match-define (list right bottom) (size dq))
+                                                  (translate doc left (+ top (/ bottom 2)))
+                                                  (move-to doc 0 0)
+                                                  (line-to doc wrap-size 0)
+                                                  (line-width doc 3)
+                                                  (stroke doc "#999")
+                                                  (restore doc))
+                                                void)]
+[draw-end (match (and (or (para-break? q) (not q))
+                      (quad-ref (car new-elems) 'list-index))
+            [#false void]
+            [val (λ (q doc)
+                   (save doc)
+                   (translate doc (- (string->number (quad-ref (car new-elems) 'left-inset "0"))) 0)
+                   (text doc val)
+                   (restore doc))])]))
+(if (para-break? q)
+    (list q:line-spacer)
+    null)))))
 
 (define top-margin 60)
 (define bottom-margin 120)
@@ -221,6 +275,35 @@
                     (fill-and-stroke doc "#eee" "#999")
                     (restore doc))))
 
+(define (make-codeblock pcs)
+  (q #:attrs (hasheq 'type "codeblock")
+     #:in 'nw
+     #:out 'sw
+     #:elems pcs
+     #:size (delay (pt (pt-x (size (car pcs)))
+                       (for/sum ([pc (in-list pcs)])
+                                (pt-y (size pc)))))
+     #:draw-start (λ (q doc)
+                    (save doc)
+                    (match-define (list left top) (quad-origin q))
+                    (match-define (list right bottom) (size q))
+                    (translate doc (- left 4) (+ top 6)) ; reset origin to top left of quad
+                    (rect doc 0 0 right (+ bottom 2))
+                    (fill doc "aliceblue")
+                    (define vert-line-width 6)
+                    (move-to doc (/ vert-line-width 2) 0) ; affirmatively move cursor
+                    (line-to doc (/ vert-line-width 2) bottom) ; strictly vert line
+                    (line-width doc vert-line-width)
+                    (stroke doc "#669")
+                    #;(move-to doc 0 0) ; affirmatively move cursor
+                    #;(line-to doc 0 bottom) ; strictly horiz line
+                    #;(stroke doc "gray")
+                    #;(translate doc 0 (+ bottom 2)) ; reset origin
+                    #;(move-to doc 0 0) ; move again
+                    #;(line-to doc right 0) ; same line, translated
+                    (stroke doc "gray")
+                    (restore doc))))
+
 (define (contiguous-group-by pred xs)
   ;; like `group-by`, but only groups together contiguous xs with the same pred value.
   (let loop ([xs xs][groups null])
@@ -263,6 +346,7 @@
             (define lns-and-containers (append* (for/list ([grp (in-list groups)])
                                                           (match (hash-ref (quad-attrs (car grp)) 'container #f)
                                                             ["bq" (list (make-blockquote grp))]
+                                                            ["codeblock" (list (make-codeblock grp))]
                                                             [_ grp]))))
             (struct-copy quad page [elems lns-and-containers])))
 
@@ -275,7 +359,7 @@
   (define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
   (let* ([x (time-name atomize (atomize (qexpr->quad xs)))]
          [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
-         [x (time-name line-wrap (line-wrap x line-width))]
+         [x (time-name line-wrap #R (line-wrap x line-width))]
          [x (time-name page-wrap (page-wrap x vertical-height path))]
          [x (time-name insert-containers (insert-containers x))]
          [x (time-name position (position (struct-copy quad q:doc [elems x])))])
@@ -285,7 +369,8 @@
   (syntax-case stx ()
     [(_ PDF-PATH . STRS)
      #'(#%module-begin
-        (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (list . STRS) pbr)))
+        ;; stick an nbsp in the strings so we have one printing char
+        (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (cons " " (list . STRS)) pbr)))
         (run qx PDF-PATH))]))
 
 (module+ reader
@@ -310,7 +395,7 @@
                             #:inside? #t
                             #:command-char #\◊))
     (define stx (quad-at-reader path-string p))
-    (define parsed-stx (datum->syntax stx (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
+    (define parsed-stx (datum->syntax stx #R (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
     (strip-context
      (with-syntax ([PT parsed-stx]
                    [PDF-PATH (path-replace-extension path-string #".pdf")])

quad/quad/qexpr.rkt

@@ -79,7 +79,10 @@
       [(cons (? valid-tag?) rest)
        (match rest
          [(list (? txexpr-attrs? attrs) (? qexpr? elems) ...)
-          (q #:attrs (attrs->hash attrs) #:elems (map loop elems))]
+          (define mheq (make-hash))
+          (for ([attr-pair (in-list attrs)])
+               (apply hash-set! mheq attr-pair))
+          (q #:attrs mheq #:elems (map loop elems))]
          [(list (? qexpr? elems) ...)
           (q #:elems (map loop elems))])]
       [_ x])))

quad/quad/quad.rkt

@@ -6,7 +6,7 @@
 
 (define (size q)
   (match (quad-size q)
-    [(? procedure? proc) (proc q)]
+    [(? procedure? proc) #R proc (proc q)]
     [(? promise? prom) (force prom)]
     [val val]))
 
@@ -59,6 +59,9 @@
    (define (hash-proc h recur) (equal-hash-code h))
    (define (hash2-proc h recur) (equal-secondary-hash-code h))])
 
+(define (quad-ref q key [default-val #f])
+  (hash-ref (quad-attrs q) key default-val))
+
 (define (default-printable q [sig #f]) #t)
 
 (define (default-draw q surface)

quad/quad/wrap.rkt

@@ -18,12 +18,16 @@
   (append partial (dropf wrap nonprinting-soft-break-in-middle?)))
 
 (define (wrap qs
-              [target-size (current-wrap-distance)]
+              [target-size-proc-arg (current-wrap-distance)]
               [debug #f]
               #:hard-break [hard-break? (λ (x) #f)]
               #:soft-break [soft-break? (λ (x) #f)]
               #:wrap-anywhere? [wrap-anywhere? #f]
               #:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))])
+  (define target-size-proc
+    (match target-size-proc-arg
+      [(? procedure? proc) proc]
+      [val (λ (q idx) val)]))
   ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things)
   (define (finish-wrap qs wrap-idx [wrap-triggering-q (car qs)])
     ;; reverse because quads accumulated in reverse
@@ -81,7 +85,7 @@
                      other-qs)])]
          [else ; cases that require computing distance
           (define dist (if (printable? q) (distance q) 0))
-          (define would-overflow? (and current-dist (> (+ dist current-dist) target-size)))
+          (define would-overflow? (and current-dist (> (+ dist current-dist) (target-size-proc q wrap-idx))))
           (cond
             [would-overflow?
              (cond