You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad2/quad.rkt

68 lines
2.4 KiB
Racket

#lang debug racket/base
(require racket/contract
racket/match
racket/hash
(for-syntax racket/base racket/syntax))
(provide (all-defined-out))
(struct $point (x y) #:transparent #:mutable)
(struct $size (width height) #:transparent #:mutable)
(struct $rect (origin size) #:transparent #:mutable)
(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])
(error 'no-dice))
(values tag attrs elems posn)))
(define (quad-tag? x) (match x
[(or (? symbol?) #false) #true]
[_ #false]))
(define (make-quad-attrs [alist null]) (make-hasheq alist))
(define (quad-attrs-union . attrss)
(define qas (make-quad-attrs))
(apply hash-union! #:combine (λ (v1 v2) v2) qas attrss)
qas)
(define (quad-attrs? x) (hash-eq? x))
(define (quad-elems? x) (list? x))
(define/contract (make-quad #:tag [tag #false]
#:attrs [attrs (make-quad-attrs null)]
#:elems [elems null])
(() (#:tag quad-tag? #:attrs quad-attrs? #:elems quad-elems?) . ->* . quad?)
(let ([attrs (if (immutable? attrs) (make-hasheq (hash->list attrs)) attrs)])
(quad-constructor tag attrs elems #false)))
(define (quad-ref q key [default-val #false])
(hash-ref (quad-attrs q) key default-val))
(define (quad-set! q key val)
(hash-set! (quad-attrs q) key val))
(define-syntax (define-quad-field stx)
(syntax-case stx ()
[(_ FIELD)
(with-syntax ([GETTER (format-id stx "quad-~a" #'FIELD)]
[SETTER (format-id stx "set-quad-~a!" #'FIELD)])
#'(begin
(define (GETTER q) (quad-ref q 'FIELD))
(define (SETTER q val) (quad-set! q 'FIELD val))))]))
#;(define-quad-field posn)
(define (has-no-position? q) (not (has-position? q)))
(define (has-position? q) (quad-posn q))
(module+ test
(define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))