progression

quad/core-types.rkt

@@ -37,6 +37,7 @@
 (define-type+predicate QuadName Symbol)
 (define-type+predicate QuadAttrKey Symbol)
 (define-type+predicate QuadAttrValue (U Float Index String Symbol Boolean Quad QuadAttrs QuadList Integer))
+
 ;; QuadAttr could be a list, but that would take twice as many cons cells.
 ;; try the economical approach.
 (define-type+predicate QuadAttr (Pairof QuadAttrKey QuadAttrValue))
@@ -48,7 +49,8 @@
 
 (define-type QuadListItem (U String Quad))
 (define-type+predicate QuadList (Listof QuadListItem))
-(define-type+predicate GroupQuadList (Listof Quad))
+(define-type GroupQuadListItem Quad)
+(define-type+predicate GroupQuadList (Listof GroupQuadListItem))
 (define-type (Treeof A) (Rec as (U A (Listof as))))
 
 
@@ -56,9 +58,12 @@
 (define-type+predicate Quad (List* QuadName QuadAttrs QuadList))
 (define-type+predicate GroupQuad (List* QuadName QuadAttrs GroupQuadList))
 (define-predicate quad? Quad)
-(define/typed (quad name attrs items)
-  (QuadName QuadAttrs QuadList . -> . Quad)
-  `(,name ,attrs ,@items))
+
+;; quad wants to be generic
+;; if it's a function, it must impose a type on its output value
+;; whereas if it's syntax, it can avoid demanding or imposing any typing
+(define-syntax-rule (quad name attrs items)
+  (list* name attrs items))
 
 (define-type+predicate QuadSet (List QuadName QuadAttrs (Listof Quad)))
 

quad/quads-typed.rkt

@@ -17,8 +17,6 @@
   (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i))
     x))
 
-
-
 (define/typed (quad-name q)
   (Quad . -> . QuadName)
   (car q))
@@ -139,35 +137,32 @@
 
 (define-syntax (define-quad-type stx)
   (syntax-case stx ()
-    [(_ id) 
+    [(_ id)
+     #'(define-quad-type id #f)]
+    [(_ id wants-group?) 
      (with-syntax ([id? (format-id #'id "~a?" #'id)]
-              ;;     [id-integer (string->number (symbol->string (gensym "")))]
-                   [idsym (format-id #'id "~asym" #'id)]
                    [IdQuad (format-id #'id "~aQuad" (string-titlecase (symbol->string (syntax->datum #'id))))]
                    [IdQuad? (format-id #'id "~aQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))]
-                   [IdGroupQuad (format-id #'id "~aGroupQuad" (string-titlecase (symbol->string (syntax->datum #'id))))]
-                   [IdGroupQuad? (format-id #'id "~aGroupQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))]
                    [quads->id (format-id #'id "quads->~a" #'id)])
-       #'(begin
+       #`(begin
            ;; quad converter
            (define/typed (quads->id qs)
-             ((Listof Quad) . -> . Quad)
+             ((Listof Quad) . -> . IdQuad)
              (apply id (gather-common-attrs qs) qs))
-
-        ;;   (define-type IdInteger id-integer) ; for experimental quad names (= faster, smaller fixnum names)
-           (define-type IdQuad (List* 'id QuadAttrs (Listof (U String Quad))))
+        
+           (define-type IdQuad (List* 'id QuadAttrs #,(if (syntax->datum #'wants-group?)
+                                                          #'GroupQuadList
+                                                          #'QuadList)))
            (define-predicate IdQuad? IdQuad)
-
-           ;; group version of quad has no strings in its quad-list
-           (define-type IdGroupQuad (List* 'id QuadAttrs (Listof Quad)))
-           (define-predicate IdGroupQuad? IdGroupQuad)
            (define id? IdQuad?)
            
            (define/typed (id [attrs '()] #:zzz [zzz 0] . xs)
-             (() ((U QuadAttrs HashableList) #:zzz Zero) #:rest QuadListItem . ->* . Quad)
+             (() ((U QuadAttrs HashableList) #:zzz Zero) #:rest #,(if (syntax->datum #'wants-group?)
+                                                          #'GroupQuadListItem
+                                                          #'QuadListItem) . ->* . IdQuad)
              (quad 'id (if (QuadAttrs? attrs)
-                           attrs
-                           (make-quadattrs attrs)) xs))))]))
+                            attrs
+                            (make-quadattrs attrs)) xs))))]))
 
 (define/typed (whitespace? x [nbsp? #f])
   ((Any) (Boolean) . ->* . Boolean)  
@@ -183,7 +178,9 @@
 
 (define-syntax (define-break-type stx)
   (syntax-case stx ()
-    [(_ id) 
+    [(_ id)
+     #'(define-break-type id #f)]
+    [(_ id wants-group?)  
      (with-syntax ([split-on-id-breaks (format-id #'id "split-on-~a-breaks" #'id)]
                    [id-break (format-id #'id "~a-break" #'id)]
                    [id-break? (format-id #'id "~a-break?" #'id)]
@@ -191,9 +188,9 @@
                    [multi-id? (format-id #'id "multi~a?" #'id)]
                    [quads->multi-id (format-id #'id "quads->multi~a" #'id)])
        #'(begin
-           (define-quad-type id)
-           (define-quad-type id-break)
-           (define-quad-type multi-id)
+           (define-quad-type id wants-group?)
+           (define-quad-type id-break) ; break is not necessarily a group
+           (define-quad-type multi-id wants-group?) ; multi-id is always a group
            ;; breaker
            (: split-on-id-breaks ((Listof Quad) . -> . (Listof (Listof Quad))))
            (define (split-on-id-breaks xs)
@@ -231,7 +228,7 @@
 (define-quad-type flag)
 (define-quad-type doc)
 (define-quad-type input)
-(define-quad-type piece)
+(define-quad-type piece #t)
 (define-quad-type run)
 
 
@@ -242,8 +239,9 @@
   (if (and (not (null? ql)) (string? (car ql)))
       (car ql)
       ""))
-(define-break-type page)
-(define-break-type column)
-(define-break-type block)
-(define-break-type line)
 
+
+(define-break-type page #t)
+(define-break-type column #t)
+(define-break-type block #t)
+(define-break-type line #t)

quad/utils-typed.rkt

@@ -66,7 +66,7 @@
 ;; ordinary flatten won't work because a quad is a bare list,
 ;; and flatten will go too far.
 ;; this version adds a check for quadness to the flattener.
-(define/typed (flatten-quadtree quad-tree)
+(define/typed+provide (flatten-quadtree quad-tree)
   ((Treeof Quad) . -> . (Listof Quad))
   (let loop ([sexp quad-tree][acc : (Listof Quad) null])
     (cond [(null? sexp) acc]
@@ -171,25 +171,43 @@
       result))
 
 
+;; these helper functions isolate the generic functionality.
+;; problem with quad-attr-set and other Quad->Quad functions
+;; is that they strip out type.
+;; whereas these "surgical" alternatives can be used when preserving type is essential
+(define/typed+provide (attr-change qas kvs)
+  (QuadAttrs HashableList . -> . QuadAttrs)
+  (merge-attrs qas kvs))
+
+(define/typed+provide (attr-delete qas . ks)
+  (QuadAttrs QuadAttrKey * . -> . QuadAttrs)
+  (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) qas))
+
+
 ;; functionally update a quad attr. Similar to hash-set
 (define/typed+provide (quad-attr-set q k v)
-  (Quad QuadAttrKey QuadAttrValue . -> . Quad)
+  (case->
+   (GroupQuad QuadAttrKey QuadAttrValue . -> . GroupQuad)
+  (Quad QuadAttrKey QuadAttrValue . -> . Quad))
   (quad-attr-set* q (list k v)))
 
 
 ;; functionally update multiple quad attrs. Similar to hash-set*
 (define/typed+provide (quad-attr-set* q kvs)
-  (Quad HashableList . -> . Quad)
-  (quad (quad-name q) (merge-attrs (quad-attrs q) kvs) (quad-list q)))
-
+  (case->
+   (GroupQuad HashableList . -> . GroupQuad)
+   (Quad HashableList . -> . Quad))
+  (quad (quad-name q) (attr-change (quad-attrs q) kvs) (quad-list q)))
 
 
 ;; functionally remove multiple quad attrs. Similar to hash-remove*
 (define/typed+provide (quad-attr-remove* q . ks)
-  (Quad QuadAttrKey * . -> . Quad)
+  (case->
+   (GroupQuad QuadAttrKey * . -> . GroupQuad)
+   (Quad QuadAttrKey * . -> . Quad))
   (if (not (empty? (quad-attrs q)))
       ;; test all ks as a set so that iteration through attrs only happens once
-      (quad (quad-name q) (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) (quad-attrs q)) (quad-list q))
+      (quad (quad-name q) (apply attr-delete (quad-attrs q) ks) (quad-list q))
       q))
 
 

quad/wrap-typed.rkt

@@ -1,11 +1,12 @@
 #lang typed/racket/base
 (require (for-syntax racket/base racket/syntax))
 (require/typed sugar/list [slicef-after ((Listof Quad) (Quad . -> . Boolean) . -> . (Listof (Listof Quad)))]
-               [shift ((Listof Any) (Listof Integer) . -> . (Listof Any))]
-               [break-at ((Listof Quad) (Listof Nonnegative-Integer) . -> . (Listof (Listof Quad)))])
+               ;; shift: need False in type because shift fills with #f
+               [shift ((Listof Quad) (Listof Integer) . -> . (Listof (Listof (U False Quad))))]
+               [break-at ((Listof PieceQuad) (Listof Nonnegative-Integer) . -> . (Listof (Listof PieceQuad)))])
 (require math/flonum (except-in racket/list flatten) racket/vector math/statistics racket/bool)
 (require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))])
-(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt")
+(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt" "utils-typed.rkt")
 
 ;; predicate for the soft hyphen
 (define/typed (soft-hyphen? x)
@@ -77,15 +78,15 @@
 ;; meaning, a line can wrap at a piece boundary, but not elsewhere.
 ;; hyphenation produces more, smaller pieces, which means more linebreak opportunities
 ;; but this also makes wrapping slower.
-(define-type Make-Pieces-Type ((Listof Quad) . -> . (Listof Quad)))
+(define-type Make-Pieces-Type ((Listof Quad) . -> . (Listof PieceQuad)))
 (define/typed (make-pieces qs)
   Make-Pieces-Type
   (define-values (breakable-items items-to-make-unbreakable) (split-at-right qs (min world:minimum-last-line-chars (length qs))))
   (define unbreak-qs (append breakable-items (map make-unbreakable items-to-make-unbreakable)))
   (define lists-of-quads (slicef-after unbreak-qs (λ([q : Quad]) (and (possible-word-break-quad? q) (not (quad-attr-ref q world:unbreakable-key #f))))))
-  (define-values (first-lists-of-quads last-list-of-quads) ((inst split-last (Listof Quad)) lists-of-quads))
+  (define-values (first-lists-of-quads last-list-of-quads) (split-last lists-of-quads))
   (define/typed (make-first-pieces qs)
-    ((Listof Quad) . -> . Quad) 
+    ((Listof Quad) . -> . PieceQuad) 
     (let-values ([(first-qs last-q) ((inst split-last Quad) qs)])
       (apply piece (list world:word-break-key (convert-to-word-break last-q)) first-qs)))
   (append (map make-first-pieces first-lists-of-quads) 
@@ -115,7 +116,7 @@
     [(ormap (λ([pred : (Any . -> . Boolean)]) (pred q)) (list char? run? word? word-break?)) 
      (apply measure-text (word-string q) 
             (font-attributes-with-defaults q))]
-    [(LineGroupQuad? q) (foldl fl+ 0.0 (map quad-width (quad-list q)))]
+    [(LineQuad? q) (foldl fl+ 0.0 (map quad-width (quad-list q)))]
     [else 0.0]))
 
 ;; get the ascent (distance from top of text to baseline)
@@ -140,15 +141,15 @@
 ;; and thus give correct behavior to trailing word spaces, soft hyphens, etc.
 
 (define/typed (render-piece p [before-break? #f])
-  ((Quad) (Boolean) . ->* . Quad)
+  ((PieceQuad) (Boolean) . ->* . PieceQuad)
   ;; a piece doesn't necessarily have a word-break item in it.
   ;; only needs it if the appearance of the piece changes based on location.
   ;; so words are likely to have a word-break item; boxes not.
   ;; the word break item contains the different characters needed to finish the piece.
-  (define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Quad? v)))))
-  (let ([p (quad-attr-remove p world:word-break-key)]) ; so it doesn't propagate into subquads
+  (define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Word-BreakQuad? v)))))
+  (let ([p (apply piece (attr-delete (quad-attrs p) world:word-break-key) (quad-list p))]) ; so it doesn't propagate into subquads
     (if the-word-break
-        (quad (quad-name p) (quad-attrs p) 
+        (apply piece (quad-attrs p) 
               (append (quad-list p) (let ([rendered-wb ((if before-break? 
                                                             word-break->before-break 
                                                             word-break->no-break) the-word-break)])
@@ -160,26 +161,26 @@
 
 ;; shorthand 
 (define/typed (render-piece-before-break p)
-  (Quad . -> . Quad)
+  (PieceQuad . -> . PieceQuad)
   (render-piece p #t))
 
 
 ;; helper macro to convert quad into word-break.
 ;; look up the break character and convert the quad based on what is found.
 (define/typed (render-word-break wb key)
-  (Quad Symbol . -> . Quad)
+  (Word-BreakQuad Symbol . -> . Quad)
   (let ([break-char (quad-attr-ref wb key)])
     (quad (if (whitespace? break-char) 'word-break 'word)
           (quad-attrs (quad-attr-remove* wb world:no-break-key world:before-break-key)) (list (assert (quad-attr-ref wb key) string?)))))
 
 ;; uses macro above in no-break mode.
 (define/typed (word-break->no-break wb)
-  (Quad . -> . Quad)
+  (Word-BreakQuad . -> . Quad)
   (render-word-break wb world:no-break-key))
 
 ;; uses macro above in before-break mode.
 (define/typed (word-break->before-break wb)
-  (Quad . -> . Quad)
+  (Word-BreakQuad . -> . Quad)
   (render-word-break wb world:before-break-key))
 
 ;; is this the last line? compare current line-idx to total lines 
@@ -208,11 +209,10 @@
   (cond
     [(not (empty? exploded-line-quads))
      ;; after exploding, each quad will have a string with one character.
-     (define shifted-lists (shift exploded-line-quads '(1 0 -1)))
-     (define lefts (cast (first shifted-lists) (Listof (U Quad False)))) ;; need False in type because shift fills with #f
-     (define centers (cast (second shifted-lists) (Listof Quad))) ;; don't need False because shift is 0 (no fill)
-     (define rights (cast (third shifted-lists) (Listof (U Quad False)))) ;; need False in type because shift fills with #f
-     (for/list : (Listof Quad) ([(q-left q q-right) (in-parallel lefts centers rights)])
+     (define shifted-lists (shift exploded-line-quads '(1 -1)))
+     (define lefts (first shifted-lists))
+     (define rights (second shifted-lists))
+     (for/list : (Listof Quad) ([(q-left q q-right) (in-parallel lefts exploded-line-quads rights)])
        (if (optical-kern? q)
            (quad-attr-set q world:width-key (fl+ (overhang-width q-left) (overhang-width q-right)))
            q))]
@@ -223,17 +223,17 @@
 ;; spacers are used to soak up extra space left over in a line.
 ;; depending on where the spacers are inserted, different formatting effects are achieved.
 ;; e.g., left / right / centered / justified.
-(define/typed+provide (insert-spacers-in-line line [alignment-override #f])
-  ((Quad) ((Option Symbol)) . ->* . Quad)
+(define/typed+provide (insert-spacers-in-line line-in [alignment-override #f])
+  ((LineQuad) ((Option Symbol)) . ->* . LineQuad)
   ;; important principle: avoid peeking into quad-list to get attributes.
   ;; because non-attributed quads may be added.
   ;; here, we know that common attributes are hoisted into the line.
   ;; so rely on line attributes to get horiz alignment.
-  (define key-to-use (if (and (last-line? line) (quad-has-attr? line world:horiz-alignment-last-line-key))
+  (define key-to-use (if (and (last-line? line-in) (quad-has-attr? line-in world:horiz-alignment-last-line-key))
                          world:horiz-alignment-last-line-key 
                          world:horiz-alignment-key))
   
-  (define horiz-alignment (or alignment-override (quad-attr-ref line key-to-use (world:horiz-alignment-default))))
+  (define horiz-alignment (or alignment-override (quad-attr-ref line-in key-to-use (world:horiz-alignment-default))))
   (define default-spacer (spacer))
   (define-values (before middle after) (case horiz-alignment
                                          [(left) (values #f #f default-spacer)]
@@ -249,18 +249,14 @@
                                 (quad-attrs (apply quad-attr-remove* attr-source keys-to-ignore))))
     (quad (quad-name q) (merge-attrs (or filtered-attrs null) q) (quad-list q)))
   
-  (quad (quad-name line) 
-        (quad-attrs line) 
-        (cast (flatten (let ([qs (cast (quad-list line) (Listof Quad))])
-                         ;; (first qs) is a single quad, but wrap it in a list to make it spliceable
-                         `(,@(cast (if before (list (copy-with-attrs before (first qs))) null) (Listof Quad))
-                           ,@(map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) 
-                                                     (let ([interleaver (copy-with-attrs middle q)])
-                                                       (list interleaver q interleaver)) 
-                                                     q)) qs) 
-                           ;; (last qs) is a single quad, but wrap it in a list to make it spliceable
-                           ,@(cast (if after (list (copy-with-attrs after (last qs))) null) (Listof Quad))
-                           ))) QuadList)))
+  (apply line (quad-attrs line-in) 
+        (flatten-quadtree (let ([qs (quad-list line-in)])
+                            (list (if before (copy-with-attrs before (first qs)) null)
+                                  (map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) 
+                                                          (let ([interleaver (copy-with-attrs middle q)])
+                                                            (list interleaver q interleaver)) 
+                                                          (list q))) qs)
+                                  (if after (copy-with-attrs after (last qs)) null))))))
 
 
 ;; installs the width in the quad.
@@ -276,9 +272,9 @@
 
 ;; helper function: doesn't need contract because it's already covered by the callers
 (define/typed (render-pieces ps)
-  ((Listof Quad) . -> . (Listof Quad))
-  (define-values (initial-ps last-p) (split-last ps))
-  (snoc ((inst map Quad Quad) render-piece (cast initial-ps (Listof Quad))) (render-piece-before-break (cast last-p Quad))))
+  ((Listof PieceQuad) . -> . (Listof PieceQuad))
+  (define-values (initial-ps last-p) ((inst split-last PieceQuad) ps))
+  (snoc (map render-piece initial-ps) (render-piece-before-break last-p)))
 
 
 (define/typed (calc-looseness total-width measure)
@@ -290,7 +286,7 @@
 ;; take the contents of the rendered pieces and merge them.
 ;; compute looseness for line as a whole.
 ;; also add ascent to each component quad, which can be different depending on font & size.
-(define-type Compose-Line-Type ((Listof Quad) (Quad . -> . Float) . -> . Quad))
+(define-type Compose-Line-Type ((Listof PieceQuad) (Quad . -> . Float) . -> . LineQuad))
 (define/typed (pieces->line ps measure-quad-proc)
   Compose-Line-Type
   
@@ -326,13 +322,13 @@
   (let* ([new-line-quads (map embed-width merged-quads merged-quad-widths)] 
          [new-line-quads (map record-ascent new-line-quads)] 
          [new-line (quads->line new-line-quads)] 
-         [new-line (quad-attr-set new-line world:line-looseness-key looseness)])
+         [new-line (apply line (attr-change (quad-attrs new-line) (list world:line-looseness-key looseness)) (quad-list new-line))])
     new-line))
 
 
 ;; a faster line-measuring function used by the wrapping function to test lines.
 (define/typed (measure-potential-line ps)
-  ((Listof Quad) . -> . Float)
+  ((Listof PieceQuad) . -> . Float)
   (cast (for*/sum : (U Float Zero) 
           ([rendered-piece (in-list (render-pieces ps))]
            [piece-quad (in-list (quad-list rendered-piece))])
@@ -363,11 +359,11 @@
                                    qs
                                    ((inst map Quad Quad) (λ(q) (quad-attr-set q world:measure-key measure)) qs))])
       (log-quad-debug "wrapping on measure = ~a" measure)
-      (define pieces : (Listof Quad) (make-pieces-proc qs)) 
+      (define pieces : (Listof PieceQuad) (make-pieces-proc qs)) 
       (define bps : (Listof Nonnegative-Integer) (find-breakpoints-proc (list->vector pieces) measure)) 
-      (define broken-pieces : (Listof (Listof Quad)) (break-at pieces bps)) 
+      (define broken-pieces : (Listof (Listof PieceQuad)) (break-at pieces bps)) 
       #; (define-type Compose-Line-Type ((Listof Quad) (Quad . -> . Float) . -> . Quad))
-      (map (λ([broken-piece : (Listof Quad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) ; 80% of runtime
+      (map (λ([broken-piece : (Listof PieceQuad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) ; 80% of runtime
 
 (define width? flonum?)
 (define measure? flonum?)
@@ -566,8 +562,9 @@
 
 ;; build quad out to a given width by distributing excess into spacers
 ;; todo: adjust this to work recursively, so that fill operation cascades down
+;; and broaden type from just LineQuad
 (define/typed+provide (fill starting-quad [target-width? #f])
-  ((Quad) ((Option Float)) . ->* . Quad)
+  ((LineQuad) ((Option Float)) . ->* . LineQuad)
   (define target-width (fl (or target-width? (cast (quad-attr-ref starting-quad world:measure-key) Float)))) 
   (define subquads (cast (quad-list starting-quad) (Listof Quad)))
   (define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers.
@@ -584,7 +581,7 @@
                                                                 (quad-attr-set q world:width-key width-per-flexible-quad)
                                                                 q)) subquads))
           
-          (quad (quad-name starting-quad) (quad-attrs (quad-attr-set starting-quad world:width-key target-width)) new-quad-list)]))
+          (apply line (quad-attrs (quad-attr-set starting-quad world:width-key target-width)) new-quad-list)]))
 
 
 ;; add x positions to a list of fixed-width quads