From eb40e8b576341f48e5fa503802aa714cc790029a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 15 May 2022 13:46:01 -0700 Subject: [PATCH] use quad-copy instead of struct-copy because struct-copy is evil --- quad2/linearize.rkt | 28 +++++++++------ quad2/quad.rkt | 87 +++++++++++++++++++++++++++++++-------------- 2 files changed, 78 insertions(+), 37 deletions(-) diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index 93892ea9..bbb1b39b 100644 --- a/quad2/linearize.rkt +++ b/quad2/linearize.rkt @@ -13,10 +13,10 @@ #:post (list-of simple-quad?) (append* (for/list ([q (in-list qs)]) - (match q - [(quad _ _ (list (? string? str)) _) + (match (quad-elems q) + [(list (? string? str)) (for/list ([c (in-string str)]) - (struct-copy quad q [elems (list (string c))]))] + (quad-copy q [elems (list (string c))]))] [_ (list q)])))) (define-pass (linearize qs) @@ -62,7 +62,9 @@ [(null? head) e0] [else (define qs-to-merge (cons e0 head)) - (struct-copy quad e0 [elems (list (string-join (append-map quad-elems qs-to-merge) ""))])]) + (define merged-str (string-join (append-map quad-elems qs-to-merge) "")) + (set-quad-elems! e0 (list merged-str)) + e0]) (merge tail))]))) (module+ test @@ -84,7 +86,8 @@ ;; so we just ignore those. (for/list ([(substr idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))] #:unless (zero? (string-length substr))) - (struct-copy quad q [elems (list (if (even? idx) substr word-space))]))] + (set-quad-elems! q (list (if (even? idx) substr word-space))) + q)] [_ (list q)])))) (module+ test @@ -106,11 +109,16 @@ (define-pass (append-bop-and-eop qs) ;; force document to have one page #:pre (list-of simple-quad?) - #:post (λ (qs) (match qs - [(list (? bop-quad?) (? simple-quad?) ... (? eop-quad?)) #true] - [_ #false])) - (define bop (bop-quad #f (quad-attrs (first qs)) null #f)) - (define eop (eop-quad #f (quad-attrs (last qs)) null #f)) + #:post (λ (qs) + (unless (bop-quad? (first qs)) + (error 'not-a-bop-quad)) + (unless (eop-quad? (last qs)) + (error 'not-an-eop-quad)) + ((list-of simple-quad?) (drop-right (cdr qs) 1))) + (define bop (bop-quad)) + (define eop (eop-quad)) + (set-quad-attrs! bop (quad-attrs (first qs))) + (set-quad-attrs! eop (quad-attrs (last qs))) (append (list bop) qs (list eop))) (define-pass (append-boq-and-eoq qs) diff --git a/quad2/quad.rkt b/quad2/quad.rkt index 76df388a..dee355f5 100644 --- a/quad2/quad.rkt +++ b/quad2/quad.rkt @@ -2,6 +2,9 @@ (require racket/contract racket/match racket/hash + racket/list + racket/string + racket/format txexpr (for-syntax racket/base racket/syntax) "constants.rkt" @@ -15,18 +18,36 @@ (define current-wrap-width (make-parameter 5)) (define current-page-size (make-parameter ($size 10 10))) -(define (list-of proc) (λ (x) (and (list? x) (andmap proc x)))) - -(struct quad (tag attrs elems posn) #:transparent #:mutable - #:constructor-name quad-constructor - #:guard (λ (tag attrs elems posn name) - (unless (match (list tag attrs elems) - [(list (? quad-tag?) - (? quad-attrs?) - (? quad-elems?)) #true] - [_ #false]) - (raise-user-error 'quad-constructor (format "failed: ~v" (list tag attrs elems posn)))) - (values tag attrs elems posn))) +(define (list-of proc) + (λ (x) + (and (list? x) + (for/and ([xi (in-list x)]) + (or (proc xi) + (let ([procname (object-name proc)]) + (raise-argument-error + (string->symbol (format "list-of ~a" procname)) + (symbol->string procname) xi))))))) + +(define-syntax-rule (auto-struct NAME (FIELD ...) . ARGS) + (struct NAME (FIELD ...) . ARGS)) + +(auto-struct quad (tag attrs elems origin size) + #:transparent #:mutable + #:constructor-name quad-new + #:methods gen:custom-write + [(define (write-proc val out mode) + (let* ([fields (filter-map (λ (f) (f val)) (list quad-tag quad-attrs quad-elems quad-origin quad-size))] + [fields (if (null? fields) (list #f) fields)]) + (fprintf out (format "<~a ~a>" + (or (car fields) "quad") + (string-join (map ~v (cdr fields)) " ")))))]) + +(define (quad-new-default) + (apply quad-new (make-list (procedure-arity quad-new) #f))) + +(define-syntax-rule (quad-copy Q . ARGS) + ;; TODO: struct-copy is questionable + (struct-copy quad Q . ARGS)) (define (quad-tag? x) (match x [(or (? symbol?) #false) #true] @@ -50,7 +71,14 @@ [(list? attrs) (loop (apply hasheq attrs))] [(immutable? attrs) (make-hasheq (hash->list attrs))] [else attrs]))]) - (quad-constructor tag attrs elems #false))) + (define newq (quad-new-default)) + (when tag (set-quad-tag! newq tag)) + (when attrs (set-quad-attrs! newq attrs)) + (when elems (set-quad-elems! newq elems)) + newq)) + +(define (initialize-attrs! q) + (set-quad-attrs! q (make-hasheq))) (define (quad-ref q-or-qs key [default-val (λ () (error (format "quad-ref: no value for key ~a" key)))] @@ -58,10 +86,15 @@ (unless (attr-key? key) (raise-argument-error 'quad-ref "attr-key?" key)) (define hash-reffer (if set-default-if-missing? hash-ref! hash-ref)) - (hash-reffer (quad-attrs (match q-or-qs - [(? quad? q) q] - [(cons q _) q] - [_ (raise-argument-error 'quad-ref "quad or list of quads" q-or-qs)])) key default-val)) + (define q (match q-or-qs + [(? quad? q) q] + [(cons q _) q] + [_ (raise-argument-error 'quad-ref "quad or list of quads" q-or-qs)])) + (when (and set-default-if-missing? (not (quad-attrs q))) + (set-quad-attrs! q (make-hasheq))) + (match (quad-attrs q) + [(? quad-attrs? attrs) (hash-reffer attrs key default-val)] + [_ (default-val)])) (define (quad-set! q key val) (hash-set! (quad-attrs q) key val)) @@ -87,10 +120,12 @@ #;(define-quad-field posn) (define (simple-quad? x) - (and (quad? x) (<= (length (quad-elems x)) 1))) + (and (quad? x) (if (list? (quad-elems x)) + (<= (length (quad-elems x)) 1) + #true))) (define (has-no-position? q) (not (has-position? q))) -(define (has-position? q) (quad-posn q)) +(define (has-position? q) (quad-origin q)) (define (txexpr->quad x) (match x @@ -112,11 +147,9 @@ (module+ test (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine")))) -(define boq (let () - (struct boq-quad quad ()) - (boq-quad #f (make-hasheq) null #f))) -(define eoq (let () - (struct eoq-quad quad ()) - (eoq-quad #f (make-hasheq) null #f))) -(struct bop-quad quad ()) -(struct eop-quad quad ()) +(define boq (make-quad #:tag 'boq-quad)) +(define eoq (make-quad #:tag 'eoq-quad)) +(define (bop-quad) (make-quad #:tag 'bop-quad)) +(define (bop-quad? x) (and (quad? x) (eq? (quad-tag x) 'bop-quad))) +(define (eop-quad) (make-quad #:tag 'eop-quad)) +(define (eop-quad? x) (and (quad? x) (eq? (quad-tag x) 'eop-quad)))