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/quad/quads-typed.rkt

211 lines
7.6 KiB
Racket

10 years ago
#lang typed/racket/base
10 years ago
(require (for-syntax typed/racket/base racket/syntax racket/string))
10 years ago
(require/typed racket/list [empty? (All (A) ((Listof A) -> Boolean))]
[last ((Listof Any) . -> . Any)])
(require/typed sugar/list [trimf (All (A) ((Listof A) (A . -> . Boolean) -> (Listof A)))]
[filter-split (All (A) ((Listof A) (A . -> . Boolean) -> (Listof (Listof A))))])
10 years ago
(require/typed racket/string [string-append* ((Listof String) . -> . String)])
10 years ago
(require/typed sugar/string [ends-with? (String String . -> . Boolean)])
10 years ago
(require sugar/debug)
(provide (all-defined-out))
10 years ago
10 years ago
(define-syntax (define/typed stx)
(syntax-case stx ()
[(_ (proc-name arg ... . rest-arg) type-expr body ...)
#'(define/typed proc-name type-expr
(λ(arg ... . rest-arg) body ...))]
[(_ proc-name type-expr body ...)
#'(begin
(: proc-name type-expr)
(define proc-name body ...))]))
10 years ago
(: hashable-list? (Any . -> . Boolean))
(define (hashable-list? x) (and (list? x) (even? (length x))))
(define-type QuadName Symbol)
(define-predicate QuadName? QuadName)
10 years ago
(define-type QuadAttrKey Symbol)
10 years ago
(define-predicate QuadAttrKey? QuadAttrKey)
10 years ago
(define-type QuadAttrValue Any)
10 years ago
(define-predicate QuadAttrValue? QuadAttrValue)
10 years ago
(define-type QuadAttrs (HashTable QuadAttrKey QuadAttrValue))
10 years ago
(define-type HashableList (Rec duo (U Null (List* QuadAttrKey Any duo))))
(define-predicate HashableList? HashableList)
10 years ago
10 years ago
(: quad-attrs? (Any . -> . Boolean))
(define (quad-attrs? x)
(and (hash? x) (andmap QuadAttrKey? (hash-keys x))))
10 years ago
(define-type QuadListItem (U Quad String))
(define-type QuadList (Listof QuadListItem))
(define-type (Treeof A) (Rec as (U A (Listof as))))
10 years ago
10 years ago
(struct quad ([name : QuadName] [attrs : QuadAttrs] [list : QuadList]) #:transparent
#:property prop:sequence (λ(q) (quad-list q)))
(define-type Quad quad)
(define-predicate Quad? Quad)
10 years ago
10 years ago
(define quad-attr-ref
10 years ago
(case-lambda
[([q : Quad] [key : QuadAttrKey])
10 years ago
(hash-ref (quad-attrs q) key)]
10 years ago
[([q : Quad] [key : QuadAttrKey] [default : QuadAttrValue])
10 years ago
(hash-ref (quad-attrs q) key (λ() default))]))
10 years ago
10 years ago
(define-syntax (quad-attr-ref/parameter stx)
(syntax-case stx ()
[(_ q key)
(with-syntax ([world:key-default (format-id stx "~a-default" (string-trim (symbol->string (syntax->datum #'key)) "-key"))])
#'(quad-attr-ref q key (world:key-default)))]))
10 years ago
10 years ago
(define cannot-be-common-attrs '(width x y page))
10 years ago
(define attr-missing (gensym))
10 years ago
(define-type QuadAttrPair (Pairof QuadAttrKey QuadAttrValue))
10 years ago
(: quad-ends-with? (Quad String . -> . Boolean))
(define (quad-ends-with? q str)
(cond
[(not (empty? (quad-list q)))
(define last-item (last (quad-list q)))
(cond
[(string? last-item) (ends-with? last-item str)]
[(quad? last-item) (quad-ends-with? last-item str)]
[else #f])]
[else #f]))
(: quad-append (Quad QuadListItem . -> . Quad))
(define (quad-append q new-item)
(quad (quad-name q) (quad-attrs q) (append (quad-list q) (list new-item))))
10 years ago
(: quad->string (Quad . -> . String))
(define (quad->string x)
(let loop : String ([x : (U Quad String) x])
(cond
[(quad? x) (string-append* ((inst map String QuadListItem) loop (quad-list x)))]
[(string? x) x]
[else ""])))
10 years ago
10 years ago
(provide gather-common-attrs)
(: gather-common-attrs ((Listof Quad) . -> . (U False (Listof QuadAttrPair))))
10 years ago
(define (gather-common-attrs qs)
10 years ago
(: check-cap (QuadAttrPair . -> . Boolean))
(define (check-cap cap)
10 years ago
(equal? (quad-attr-ref (car qs) (car cap) attr-missing) (cdr cap)))
10 years ago
(let loop
([qs qs]
10 years ago
[common-attr-pairs : (Listof QuadAttrPair) (if (quad-attrs (car qs))
10 years ago
10 years ago
(for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))]
10 years ago
#:unless (member (car kv-pair) cannot-be-common-attrs))
kv-pair)
10 years ago
null)])
10 years ago
(cond
10 years ago
[(null? common-attr-pairs) #f]
[(null? qs) common-attr-pairs]
10 years ago
[else (loop (cdr qs) (filter check-cap common-attr-pairs))])))
10 years ago
10 years ago
(: quadattrs ((Listof Any) . -> . QuadAttrs))
(define (quadattrs xs)
(let-values ([(ks vs even?) (for/fold
([ks : (Listof Any) null][vs : (Listof Any) null][even? : Boolean #t])
([x (in-list xs)])
(if even?
(values (cons x ks) vs #f)
(values ks (cons x vs) #t)))])
(when (not even?) (error 'bad-input))
(cast (for/hash ([k (in-list ks)][v (in-list vs)])
10 years ago
(values k v)) QuadAttrs)))
10 years ago
10 years ago
(define-syntax (define-quad-type stx)
(syntax-case stx ()
10 years ago
[(_ id)
(with-syntax ([id? (format-id #'id "~a?" #'id)]
10 years ago
[quads->id (format-id #'id "quads->~a" #'id)])
10 years ago
#'(begin
;; quad converter
10 years ago
(: quads->id ((Listof Quad) . -> . Quad))
(define (quads->id qs)
10 years ago
(apply id (gather-common-attrs qs) qs))
10 years ago
10 years ago
(: id (case->
10 years ago
(-> Quad)
((Option (U QuadAttrs (Listof Any))) (U String Quad) * . -> . Quad)))
10 years ago
(define (id [attrs #f] . xs)
(quad 'id (if (quad-attrs? attrs) (cast attrs QuadAttrs) (quadattrs (if (list? attrs) attrs '()))) (cast xs QuadList)))
10 years ago
(: id? (Any . -> . Boolean))
(define (id? x)
(and (quad? x) (equal? (quad-name x) 'id)))
10 years ago
))]))
10 years ago
(: whitespace? ((Any) (Boolean) . ->* . Boolean))
(define (whitespace? x [nbsp? #f])
;((any/c)(boolean?) . ->* . coerce/boolean?)
(cond
10 years ago
[(quad? x) (whitespace? (quad-list x) nbsp?)]
10 years ago
[(string? x) (or (and (regexp-match #px"\\p{Zs}" x) ; Zs = unicode whitespace category
(or nbsp? (not (regexp-match #px"\u00a0" x)))))] ; 00a0: nbsp
[(list? x) (and (not (empty? x)) (andmap (λ(x) (whitespace? x nbsp?)) x))] ; andmap returns #t for empty lists
[else #f]))
(define (whitespace/nbsp? x)
(whitespace? x #t))
(define-syntax (define-break-type stx)
(syntax-case stx ()
10 years ago
[(_ id)
(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)]
[multi-id (format-id #'id "multi~a" #'id)]
[multi-id? (format-id #'id "multi~a?" #'id)]
[quads->multi-id (format-id #'id "quads->multi~a" #'id)])
10 years ago
#'(begin
10 years ago
(define-quad-type id)
10 years ago
(define-quad-type id-break)
(define-quad-type multi-id)
;; breaker
(: split-on-id-breaks ((Listof Quad) . -> . (Listof (Listof Quad))))
(define (split-on-id-breaks xs)
;; omit leading & trailing whitespace, because they're superfluous next to a break
(map (λ([xs : (Listof Quad)]) (trimf xs whitespace?)) (filter-split xs id-break?)))))]))
10 years ago
10 years ago
(define quad= equal?)
(: quad-has-attr? (Quad QuadAttrKey . -> . Boolean))
(define (quad-has-attr? q key)
10 years ago
(hash-has-key? (quad-attrs q) key))
(define-quad-type spacer)
(define-quad-type kern)
(define-quad-type optical-kern)
(define-quad-type flag)
(define-quad-type doc)
(define-quad-type input)
(define-quad-type piece)
(define-quad-type run)
(define-quad-type box)
(define-break-type word)
(: word-string (Quad . -> . String))
(define (word-string c)
(cast ((inst car QuadListItem Any) (quad-list c)) String))
10 years ago
(define-break-type page)
(define-break-type column)
(define-break-type block)
(define-break-type line)