contract-render.rkt (7287B)
1 #lang racket/base 2 (require racket/class racket/match 3 (prefix-in text: "text-render.rkt") 4 "base-render.rkt" 5 "core.rkt" 6 file/convertible 7 racket/serialize) 8 (provide override-render-mixin-single 9 override-render-mixin-multi) 10 11 (define (override-render-mixin multi?) 12 (mixin (render<%>) () 13 (super-new) 14 (define/override (render srcs dests ri) 15 (super render srcs dests ri) 16 17 (for ([part (in-list srcs)] 18 [dest (in-list dests)]) 19 (define p (open-output-string)) 20 (define index-table (make-hash)) 21 (port-count-lines! p) 22 (parameterize ([the-renderer text-renderer] 23 [the-part part] 24 [the-ri ri] 25 [the-text-p p]) 26 (r-part part 'block index-table)) 27 (define table-str (format "~s\n" (serialize index-table))) 28 (define cb.rktd 29 (cond 30 [multi? 31 (build-path dest "blueboxes.rktd")] 32 [else 33 (define-values (base name dir?) (split-path dest)) 34 (build-path base "blueboxes.rktd")])) 35 (call-with-output-file cb.rktd 36 (λ (port) 37 (fprintf port "~a\n" (string-utf-8-length table-str)) 38 (display table-str port) 39 (display (get-output-string p) port)) 40 #:exists 'truncate))) 41 42 (inherit get-dest-directory) 43 (define text-renderer (new (text:render-mixin render%) 44 [dest-dir (get-dest-directory)])))) 45 46 (define the-renderer (make-parameter #f)) 47 (define the-part (make-parameter #f)) 48 (define the-ri (make-parameter #f)) 49 (define the-text-p (make-parameter #f)) 50 51 ;; mode is either 52 ;; 'block -- search for the blue blocks 53 ;; or (cons number number) -- search for tags in a block 54 (define (r-parts parts mode index-table) 55 (for ([part (in-list parts)]) 56 (r-part part mode index-table))) 57 58 (define (r-part part mode index-table) 59 (r-blocks (part-blocks part) mode index-table) 60 (r-parts (part-parts part) mode index-table)) 61 62 (define (r-blocks blocks mode index-table) 63 (for ([block (in-list blocks)]) 64 (r-block block mode index-table))) 65 66 (define (r-block block mode index-table) 67 (match block 68 [(struct nested-flow (style blocks)) 69 (check-and-continue style block mode index-table r-blocks blocks)] 70 [(struct compound-paragraph (style blocks)) 71 (check-and-continue style block mode index-table r-blocks blocks)] 72 [(paragraph style content) 73 (check-and-continue style block mode index-table r-content content)] 74 [(itemization style blockss) 75 (check-and-continue style block mode index-table r-blockss blockss)] 76 [(table style cells) 77 (check-and-continue style block mode index-table r-blockss+cont cells)] 78 [(delayed-block resolve) 79 (r-block (delayed-block-blocks block (the-ri)) mode index-table)] 80 [(traverse-block _) 81 (r-block (traverse-block-block block (the-ri)) mode index-table)])) 82 83 (define (check-and-continue style block mode index-table sub-f sub-p) 84 (cond 85 [(and (pair? mode) (equal? (style-name style) "RBackgroundLabelInner")) 86 (define background-label-port (car mode)) 87 (parameterize ([current-output-port background-label-port]) 88 (send (the-renderer) render-block block (the-part) (the-ri) #f)) 89 (sub-f sub-p mode index-table)] 90 [(and (eq? mode 'block) (eq? (style-name style) 'boxed) (table? block)) 91 (cond 92 [(for/and ([cells (in-list (table-blockss block))]) 93 (and (not (null? cells)) 94 (null? (cdr cells)) 95 (let ([fst (car cells)]) 96 (and (table? fst) 97 (equal? (style-name (table-style fst)) "together"))))) 98 (for ([cells (in-list (table-blockss block))]) 99 (handle-one-block style (car cells) mode index-table r-block (car cells)))] 100 [else 101 (handle-one-block style block mode index-table sub-f sub-p)])] 102 [else 103 (sub-f sub-p mode index-table)])) 104 105 (define (handle-one-block style block mode index-table sub-f sub-p) 106 ;(printf "-----\n") ((dynamic-require 'racket/pretty 'pretty-write) block) 107 (define block-port (open-output-string)) 108 (define background-label-port (open-output-string)) 109 (define ents (make-hash)) 110 (define new-mode (cons background-label-port ents)) 111 (port-count-lines! block-port) 112 (port-count-lines! background-label-port) 113 (parameterize ([current-output-port block-port]) 114 (send (the-renderer) render-block block (the-part) (the-ri) #f)) 115 (sub-f sub-p new-mode index-table) 116 117 ;; we just take the first one here 118 (define background-label-p (open-input-string (get-output-string background-label-port))) 119 (define background-label-line (read-line background-label-p)) 120 121 (define text-p (the-text-p)) 122 (define-values (before-line _1 _2) (port-next-location text-p)) 123 (define before-position (file-position text-p)) 124 (fprintf text-p "~a\n" 125 (if (eof-object? background-label-line) 126 "" 127 background-label-line)) 128 129 ;; dump content of block-port into text-p, but first trim 130 ;; the spaces that appear at the ends of the lines 131 (let ([p (open-input-string (get-output-string block-port))]) 132 (let loop () 133 (define l (read-line p)) 134 (unless (eof-object? l) 135 (display (regexp-replace #rx" *$" l "") text-p) 136 (newline text-p) 137 (loop)))) 138 139 (define-values (after-line _3 _4) (port-next-location text-p)) 140 (define txt-loc (cons before-position (- after-line before-line))) 141 (define ri (the-ri)) 142 (for ([(k v) (in-hash ents)]) 143 (let ([k (tag-key k ri)]) 144 (hash-set! index-table k (cons txt-loc (hash-ref index-table k '())))))) 145 146 (define (r-blockss+cont blockss mode index-table) 147 (for ([blocks (in-list blockss)]) 148 (for ([block (in-list blocks)]) 149 (unless (eq? block 'cont) 150 (r-block block mode index-table))))) 151 152 (define (r-blockss blockss mode index-table) 153 (for ([blocks (in-list blockss)]) 154 (r-blocks blocks mode index-table))) 155 156 (define (r-content content mode index-table) 157 (cond 158 [(element? content) (r-element content mode index-table)] 159 [(list? content) 160 (for ([content (in-list content)]) 161 (r-content content mode index-table))] 162 [(string? content) (void)] 163 [(symbol? content) (void)] 164 [(convertible? content) (void)] 165 [(delayed-element? content) 166 (r-content (delayed-element-content content (the-ri)) mode index-table)] 167 [(traverse-element? content) 168 (r-content (traverse-element-content content (the-ri)) mode index-table)] 169 [(part-relative-element? content) 170 (r-content (part-relative-element-content content (the-ri)) mode index-table)] 171 [(multiarg-element? content) 172 (r-content (multiarg-element-contents content) mode index-table)] 173 [else (error 'r-content "unknown content: ~s\n" content)])) 174 175 (define (r-element element mode index-table) 176 (when (index-element? element) 177 (when (pair? mode) 178 (define ents (cdr mode)) 179 (define key (index-element-tag element)) 180 (hash-set! ents (tag-key key (the-ri)) #t))) 181 (r-content (element-content element) mode index-table)) 182 183 184 (define override-render-mixin-multi (override-render-mixin #t)) 185 (define override-render-mixin-single (override-render-mixin #f))