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

156 lines
5.6 KiB
Racket

#lang debug racket/base
(require racket/contract
racket/match
racket/hash
racket/list
racket/string
racket/format
txexpr
(for-syntax racket/base racket/syntax)
"constants.rkt"
"struct.rkt")
(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)
(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]
[_ #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) (and (hash? 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 (or/c quad-attrs? (listof any/c)) #:elems quad-elems?) . ->* . quad?)
(let ([attrs (let loop ([attrs attrs])
(cond
[(list? attrs) (loop (apply hasheq attrs))]
[(immutable? attrs) (make-hasheq (hash->list attrs))]
[else attrs]))])
(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)))]
#:set-default-if-missing [set-default-if-missing? #false])
(unless (attr-key? key)
(raise-argument-error 'quad-ref "attr-key?" key))
(define hash-reffer (if set-default-if-missing? hash-ref! hash-ref))
(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))
(define (quad-update! q key updater)
(hash-update! (quad-attrs q) key updater))
(define (quad-ref! q-or-qs key default-val)
(quad-ref q-or-qs key default-val #:set-default-if-missing #true))
(define (quad-has-key? q-or-qs key)
(not (eq? (quad-ref q-or-qs key no-value-signal) no-value-signal)))
(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 (simple-quad? x)
(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-origin q))
(define (txexpr->quad x)
(match x
[(txexpr tag attrs elems)
(make-quad #:tag tag
#:attrs (attrs->hash attrs)
#:elems (map txexpr->quad elems))]
[_ x]))
(define (bootstrap-input x)
;; turn a simple string into a quad for testing layout.
(let loop ([x x])
(match x
[(? quad? q) (list q)]
[(and (list (? quad?) ...) qs) (loop (make-quad #:elems qs))]
[(? txexpr? tx) (loop (txexpr->quad tx))]
[(? string? str) (loop (make-quad #:elems (list str)))])))
(module+ test
(define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))
(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)))