reset
parent
c6b4a62ef1
commit
0a0ad2354a
@ -0,0 +1,12 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
(rename-out [~module-begin #%module-begin])
|
||||
(for-syntax (all-from-out racket/base)))
|
||||
|
||||
(define-syntax-rule (~module-begin . args)
|
||||
(#%module-begin
|
||||
. args))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
#:language 'quad/dev)
|
||||
@ -1,52 +1,8 @@
|
||||
#lang racket/base
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
(rename-out [quad-module-begin #%module-begin]))
|
||||
(require (for-syntax racket/base syntax/strip-context))
|
||||
(require quad/quads quad/typeset quad/world quad/render racket/class)
|
||||
(require "top.rkt")
|
||||
(provide (except-out (all-from-out racket/base) #%top)
|
||||
(rename-out [~top #%top]))
|
||||
|
||||
(define-syntax (quad-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(replace-context #'(expr ...)
|
||||
#'(#%module-begin
|
||||
(module outy racket/base
|
||||
(require quad/quads)
|
||||
(define out (block '(font "Times New Roman" measure 360.0 leading 14.0 column-count 1 column-gutter 10.0 size 11.5 x-align justify x-align-last-line left) expr ...))
|
||||
(provide out))
|
||||
(require 'outy)
|
||||
(provide (all-from-out 'outy))
|
||||
(displayln out)))]))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/main
|
||||
#:read quad-read
|
||||
#:read-syntax quad-read-syntax
|
||||
#:whole-body-readers? #t ;; need this to make at-reader work
|
||||
#:info custom-get-info
|
||||
(require scribble/reader)
|
||||
|
||||
(define (quad-read p)
|
||||
(syntax->datum (quad-read-syntax (object-name p) p)))
|
||||
|
||||
(define quad-command-char #\@)
|
||||
|
||||
(define (quad-read-syntax path-string p)
|
||||
(define quad-at-reader (make-at-reader
|
||||
#:command-char quad-command-char
|
||||
#:syntax? #t
|
||||
#:inside? #t))
|
||||
(define source-stx (quad-at-reader path-string p))
|
||||
source-stx)
|
||||
|
||||
(define (custom-get-info key default [proc (λ _ #f)])
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(define my-make-scribble-inside-lexer
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
|
||||
(cond [my-make-scribble-inside-lexer
|
||||
(my-make-scribble-inside-lexer #:command-char quad-command-char)]
|
||||
[else default])]
|
||||
[(drracket:toolbar-buttons)
|
||||
(define my-make-drracket-buttons (dynamic-require 'quad/buttons 'make-drracket-buttons))
|
||||
(my-make-drracket-buttons)]
|
||||
[else default])))
|
||||
#:language 'quad)
|
||||
|
Before Width: | Height: | Size: 163 B After Width: | Height: | Size: 163 B |
@ -0,0 +1,52 @@
|
||||
#lang racket/base
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
(rename-out [quad-module-begin #%module-begin]))
|
||||
(require (for-syntax racket/base syntax/strip-context))
|
||||
(require quad/quads quad/typeset quad/world quad/render racket/class)
|
||||
|
||||
(define-syntax (quad-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(replace-context #'(expr ...)
|
||||
#'(#%module-begin
|
||||
(module outy racket/base
|
||||
(require quad/quads)
|
||||
(define out (block '(font "Times New Roman" measure 360.0 leading 14.0 column-count 1 column-gutter 10.0 size 11.5 x-align justify x-align-last-line left) expr ...))
|
||||
(provide out))
|
||||
(require 'outy)
|
||||
(provide (all-from-out 'outy))
|
||||
(displayln out)))]))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/main
|
||||
#:read quad-read
|
||||
#:read-syntax quad-read-syntax
|
||||
#:whole-body-readers? #t ;; need this to make at-reader work
|
||||
#:info custom-get-info
|
||||
(require scribble/reader)
|
||||
|
||||
(define (quad-read p)
|
||||
(syntax->datum (quad-read-syntax (object-name p) p)))
|
||||
|
||||
(define quad-command-char #\@)
|
||||
|
||||
(define (quad-read-syntax path-string p)
|
||||
(define quad-at-reader (make-at-reader
|
||||
#:command-char quad-command-char
|
||||
#:syntax? #t
|
||||
#:inside? #t))
|
||||
(define source-stx (quad-at-reader path-string p))
|
||||
source-stx)
|
||||
|
||||
(define (custom-get-info key default [proc (λ _ #f)])
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(define my-make-scribble-inside-lexer
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
|
||||
(cond [my-make-scribble-inside-lexer
|
||||
(my-make-scribble-inside-lexer #:command-char quad-command-char)]
|
||||
[else default])]
|
||||
[(drracket:toolbar-buttons)
|
||||
(define my-make-drracket-buttons (dynamic-require 'quad/buttons 'make-drracket-buttons))
|
||||
(my-make-drracket-buttons)]
|
||||
[else default])))
|
||||
@ -0,0 +1,239 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax racket/string) racket/string racket/contract racket/serialize sugar/list racket/format racket/list sugar/debug sugar/coerce racket/bool racket/function sugar/unstable/string)
|
||||
(require "world.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; struct implementation
|
||||
|
||||
(serializable-struct quad (name attrs list) #:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc (λ(b port mode)
|
||||
(display (format "(~a)" (string-join (filter-not void? (list
|
||||
(~a (quad-name b))
|
||||
(if (and (hash? (quad-attrs b)) (> (length (hash-keys (quad-attrs b))) 0)) (~v (flatten (hash->list (quad-attrs b)))) "#f")
|
||||
(if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) " ")) (void)))) " ")) port)))]
|
||||
#:property prop:sequence (λ(q) (quad-list q)))
|
||||
|
||||
|
||||
|
||||
;; vector implementation
|
||||
#|
|
||||
(define (quad-name q) (vector-ref q 0))
|
||||
(define (quad-attrs q) (vector-ref q 1))
|
||||
(define (quad-list q) (vector-ref q 2))
|
||||
|
||||
(define (quad? x)
|
||||
(and (vector? x)
|
||||
(symbol? (quad-name x))
|
||||
(or (false? (quad-attrs x)) (hash? (quad-attrs x)))
|
||||
(list? (quad-list x))))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(vector name attrs xs))
|
||||
|#
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; hash implementation
|
||||
#|
|
||||
(define (quad-name q) (hash-ref q 'name))
|
||||
(define (quad-attrs q) (hash-ref q 'attrs))
|
||||
(define (quad-list q) (hash-ref q 'list))
|
||||
|
||||
(define (quad? x)
|
||||
(and (hash? x)
|
||||
(andmap (λ(k) (hash-has-key? x k)) (list 'name 'attrs 'list))
|
||||
(symbol? (quad-name x))
|
||||
(ormap (λ(pred) (pred (quad-attrs x))) (list false? hash?))
|
||||
(list? (quad-list x))))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(hash 'name name 'attrs attrs 'list xs))
|
||||
|#
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (quad-name? x) (symbol? x))
|
||||
(define (hashable-list? x) (and (list? x) (even? (length x))))
|
||||
(define (quad-attrs? x) (or (false? x) (hash? x)))
|
||||
(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (and (string? xi) (< 0 (string-length xi))))) x)))
|
||||
(define (quads? x) (and (list? x) (andmap quad? x)))
|
||||
(define (lists-of-quads? x) (and (list? x) (andmap quads? x)))
|
||||
|
||||
(define quad= equal?)
|
||||
|
||||
(define token? quad?)
|
||||
|
||||
(define (quad/c x) (λ(x) (and (quad? x) (symbol? (quad-name x)) (hash? (quad-attrs x))
|
||||
(andmap (λ(xi) (or (quad/c xi) (string? xi))) (quad-list x)))))
|
||||
|
||||
(define quad-attr-ref
|
||||
(case-lambda
|
||||
[(q key)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key)
|
||||
(error 'quad-attr-ref (format "no attrs in quad ~a" q)))]
|
||||
[(q key default)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key default)
|
||||
default)]))
|
||||
|
||||
(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)))]))
|
||||
|
||||
|
||||
(define (quad-has-attr? q key)
|
||||
(define qa (quad-attrs q))
|
||||
(and qa (hash-has-key? qa key)))
|
||||
|
||||
(define-syntax (define-quad-list-function stx)
|
||||
(syntax-case stx ()
|
||||
[(_ proc)
|
||||
(with-syntax ([quad-proc (format-id stx "quad-~a" #'proc)])
|
||||
#'(define (quad-proc q) (proc (quad-list q))))]))
|
||||
|
||||
(define-quad-list-function first)
|
||||
(define-quad-list-function car)
|
||||
(define-quad-list-function cdr)
|
||||
(define-quad-list-function last)
|
||||
(define (quad-cons item q)
|
||||
(quad (quad-name q) (quad-attrs q) (cons item (quad-list q))))
|
||||
|
||||
(define-syntax-rule (quad-ref q r)
|
||||
(list-ref (quad-list q) r))
|
||||
|
||||
(define (quad-ends-with? q str)
|
||||
(quad? string? . -> . boolean?)
|
||||
(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]))
|
||||
|
||||
|
||||
(define (quad-append q new-item)
|
||||
(quad? (or/c quad? string?) . -> . quad?)
|
||||
(quad (quad-name q) (quad-attrs q) (append (quad-list q) (list new-item))))
|
||||
|
||||
(define (quad->string x)
|
||||
(quad? . -> . string?)
|
||||
(cond
|
||||
[(quad? x) (string-append* (map quad->string (quad-list x)))]
|
||||
[(string? x) x]
|
||||
[else ""]))
|
||||
|
||||
(define-syntax-rule (report-quadstring q)
|
||||
(begin
|
||||
(report (quad->string q) 'q)
|
||||
q))
|
||||
|
||||
(define cannot-be-common-attrs '(width x y page)) ;; todo: how to specify these better? this-* prefix?
|
||||
|
||||
;; make this a macro because qs-in is often huge
|
||||
;; and the macro avoids allocation + garbage collection
|
||||
(define attr-missing (gensym))
|
||||
(define (gather-common-attrs qs)
|
||||
(let loop ([qs qs]
|
||||
[common-attrs (if (quad-attrs (car qs))
|
||||
(for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))]
|
||||
#:unless (member (car kv-pair) cannot-be-common-attrs))
|
||||
kv-pair)
|
||||
empty)])
|
||||
(cond
|
||||
[(empty? common-attrs) empty]
|
||||
[(empty? qs) (flatten common-attrs)]
|
||||
[else (loop (cdr qs)
|
||||
(filter (λ(ca) (equal? (quad-attr-ref (car qs) (car ca) attr-missing) (cdr ca)))
|
||||
common-attrs))])))
|
||||
|
||||
|
||||
(define-syntax (define-box-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(with-syntax ([id? (format-id #'id "~a?" #'id)]
|
||||
[ids? (format-id #'id "~as?" #'id)]
|
||||
[lists-of-ids? (format-id #'id "list-of-~as?" #'id)]
|
||||
[quads->id (format-id #'id "quads->~a" #'id)]
|
||||
[inline/quads->id (format-id #'id "inline/quads->~a" #'id)])
|
||||
#'(begin
|
||||
;; quad predicate - ok to be relaxed here if we're strict when making the struct
|
||||
(define (id? x)
|
||||
(and (quad? x) (equal? (quad-name x) 'id)))
|
||||
;; quad constructor
|
||||
;; put contract here rather than on struct, because this is the main interface
|
||||
;; and this contract is more liberal.
|
||||
;; but don't put a separate contract on struct, because it's superfluous.
|
||||
(define (id [attrs empty] . xs)
|
||||
(() ((or/c quad-attrs? hashable-list?)) #:rest quad-list? . ->* . id?)
|
||||
(quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs))
|
||||
;; quad list predicate and list-of-list predicate.
|
||||
;; These are faster than the listof contract combinator.
|
||||
(define (ids? x)
|
||||
(and (list? x) (andmap id? x)))
|
||||
(define (lists-of-ids? x)
|
||||
(and (list? x) (andmap ids? x)))
|
||||
;; quad converter macro
|
||||
(define (quads->id qs)
|
||||
(apply id (gather-common-attrs qs) qs))))]))
|
||||
|
||||
|
||||
;; do not treat empty string as whitespace.
|
||||
;; throws off tests that rely on adjacency to positive whitespace.
|
||||
(define (whitespace? x [nbsp? #f])
|
||||
((any/c)(boolean?) . ->* . coerce/boolean?)
|
||||
(cond
|
||||
[(quad? x) (whitespace? (quad-list x) nbsp?)]
|
||||
[(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 (curryr whitespace? 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 ()
|
||||
[(_ 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)])
|
||||
#'(begin
|
||||
(define-box-type id)
|
||||
(define-box-type id-break)
|
||||
(define-box-type multi-id)
|
||||
;; breaker
|
||||
(define (split-on-id-breaks x)
|
||||
(quads? . -> . lists-of-quads?)
|
||||
;; omit leading & trailing whitespace, because they're superfluous next to a break
|
||||
(map (curryr trimf whitespace?) (filter-split x id-break?)))))]))
|
||||
|
||||
(define-box-type box)
|
||||
|
||||
(define-break-type word)
|
||||
(define (word-string c) (car (quad-list c)))
|
||||
|
||||
(define-box-type spacer)
|
||||
(define-box-type kern)
|
||||
(define-box-type optical-kern)
|
||||
(define-box-type flag)
|
||||
(define-box-type doc)
|
||||
(define-box-type input)
|
||||
(define-box-type piece)
|
||||
(define-box-type run)
|
||||
|
||||
(define-break-type page)
|
||||
(define-break-type column)
|
||||
(define-break-type block)
|
||||
(define-break-type line)
|
||||
|
||||
(define (->input q) (input empty q))
|
||||
(define coerce/input? (make-coercion-contract input))
|
||||
|
||||
@ -1,239 +1,29 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax racket/string) racket/string racket/contract racket/serialize sugar/list racket/format racket/list sugar/debug sugar/coerce racket/bool racket/function sugar/unstable/string)
|
||||
(require "world.rkt")
|
||||
#lang quad/dev
|
||||
(provide (all-defined-out))
|
||||
(require (for-syntax racket/string))
|
||||
|
||||
;; struct implementation
|
||||
|
||||
(serializable-struct quad (name attrs list) #:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc (λ(b port mode)
|
||||
(display (format "(~a)" (string-join (filter-not void? (list
|
||||
(~a (quad-name b))
|
||||
(if (and (hash? (quad-attrs b)) (> (length (hash-keys (quad-attrs b))) 0)) (~v (flatten (hash->list (quad-attrs b)))) "#f")
|
||||
(if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) " ")) (void)))) " ")) port)))]
|
||||
#:property prop:sequence (λ(q) (quad-list q)))
|
||||
|
||||
|
||||
|
||||
;; vector implementation
|
||||
#|
|
||||
(define (quad-name q) (vector-ref q 0))
|
||||
(define (quad-attrs q) (vector-ref q 1))
|
||||
(define (quad-list q) (vector-ref q 2))
|
||||
|
||||
|
||||
(define (quad? x)
|
||||
(and (vector? x)
|
||||
(symbol? (quad-name x))
|
||||
(or (false? (quad-attrs x)) (hash? (quad-attrs x)))
|
||||
(or (not (quad-attrs x)) (hash? (quad-attrs x)))
|
||||
(list? (quad-list x))))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(vector name attrs xs))
|
||||
|#
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; hash implementation
|
||||
#|
|
||||
(define (quad-name q) (hash-ref q 'name))
|
||||
(define (quad-attrs q) (hash-ref q 'attrs))
|
||||
(define (quad-list q) (hash-ref q 'list))
|
||||
|
||||
(define (quad? x)
|
||||
(and (hash? x)
|
||||
(andmap (λ(k) (hash-has-key? x k)) (list 'name 'attrs 'list))
|
||||
(symbol? (quad-name x))
|
||||
(ormap (λ(pred) (pred (quad-attrs x))) (list false? hash?))
|
||||
(list? (quad-list x))))
|
||||
(define (quad-attrs? x) (list? x))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(hash 'name name 'attrs attrs 'list xs))
|
||||
|#
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (quad-name? x) (symbol? x))
|
||||
(define (hashable-list? x) (and (list? x) (even? (length x))))
|
||||
(define (quad-attrs? x) (or (false? x) (hash? x)))
|
||||
(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (and (string? xi) (< 0 (string-length xi))))) x)))
|
||||
(define (quads? x) (and (list? x) (andmap quad? x)))
|
||||
(define (lists-of-quads? x) (and (list? x) (andmap quads? x)))
|
||||
|
||||
(define quad= equal?)
|
||||
|
||||
(define token? quad?)
|
||||
|
||||
(define (quad/c x) (λ(x) (and (quad? x) (symbol? (quad-name x)) (hash? (quad-attrs x))
|
||||
(andmap (λ(xi) (or (quad/c xi) (string? xi))) (quad-list x)))))
|
||||
|
||||
(define quad-attr-ref
|
||||
(case-lambda
|
||||
[(q key)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key)
|
||||
(error 'quad-attr-ref (format "no attrs in quad ~a" q)))]
|
||||
[(q key default)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key default)
|
||||
default)]))
|
||||
|
||||
(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)))]))
|
||||
|
||||
|
||||
(define (quad-has-attr? q key)
|
||||
(define qa (quad-attrs q))
|
||||
(and qa (hash-has-key? qa key)))
|
||||
|
||||
(define-syntax (define-quad-list-function stx)
|
||||
(syntax-case stx ()
|
||||
[(_ proc)
|
||||
(with-syntax ([quad-proc (format-id stx "quad-~a" #'proc)])
|
||||
#'(define (quad-proc q) (proc (quad-list q))))]))
|
||||
|
||||
(define-quad-list-function first)
|
||||
(define-quad-list-function car)
|
||||
(define-quad-list-function cdr)
|
||||
(define-quad-list-function last)
|
||||
(define (quad-cons item q)
|
||||
(quad (quad-name q) (quad-attrs q) (cons item (quad-list q))))
|
||||
|
||||
(define-syntax-rule (quad-ref q r)
|
||||
(list-ref (quad-list q) r))
|
||||
|
||||
(define (quad-ends-with? q str)
|
||||
(quad? string? . -> . boolean?)
|
||||
(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]))
|
||||
|
||||
|
||||
(define (quad-append q new-item)
|
||||
(quad? (or/c quad? string?) . -> . quad?)
|
||||
(quad (quad-name q) (quad-attrs q) (append (quad-list q) (list new-item))))
|
||||
|
||||
(define (quad->string x)
|
||||
(quad? . -> . string?)
|
||||
(cond
|
||||
[(quad? x) (string-append* (map quad->string (quad-list x)))]
|
||||
[(string? x) x]
|
||||
[else ""]))
|
||||
|
||||
(define-syntax-rule (report-quadstring q)
|
||||
(begin
|
||||
(report (quad->string q) 'q)
|
||||
q))
|
||||
|
||||
(define cannot-be-common-attrs '(width x y page)) ;; todo: how to specify these better? this-* prefix?
|
||||
|
||||
;; make this a macro because qs-in is often huge
|
||||
;; and the macro avoids allocation + garbage collection
|
||||
(define attr-missing (gensym))
|
||||
(define (gather-common-attrs qs)
|
||||
(let loop ([qs qs]
|
||||
[common-attrs (if (quad-attrs (car qs))
|
||||
(for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))]
|
||||
#:unless (member (car kv-pair) cannot-be-common-attrs))
|
||||
kv-pair)
|
||||
empty)])
|
||||
(cond
|
||||
[(empty? common-attrs) empty]
|
||||
[(empty? qs) (flatten common-attrs)]
|
||||
[else (loop (cdr qs)
|
||||
(filter (λ(ca) (equal? (quad-attr-ref (car qs) (car ca) attr-missing) (cdr ca)))
|
||||
common-attrs))])))
|
||||
|
||||
|
||||
(define-syntax (define-box-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(with-syntax ([id? (format-id #'id "~a?" #'id)]
|
||||
[ids? (format-id #'id "~as?" #'id)]
|
||||
[lists-of-ids? (format-id #'id "list-of-~as?" #'id)]
|
||||
[quads->id (format-id #'id "quads->~a" #'id)]
|
||||
[inline/quads->id (format-id #'id "inline/quads->~a" #'id)])
|
||||
#'(begin
|
||||
;; quad predicate - ok to be relaxed here if we're strict when making the struct
|
||||
(define (id? x)
|
||||
(and (quad? x) (equal? (quad-name x) 'id)))
|
||||
;; quad constructor
|
||||
;; put contract here rather than on struct, because this is the main interface
|
||||
;; and this contract is more liberal.
|
||||
;; but don't put a separate contract on struct, because it's superfluous.
|
||||
(define (id [attrs empty] . xs)
|
||||
(() ((or/c quad-attrs? hashable-list?)) #:rest quad-list? . ->* . id?)
|
||||
(quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs))
|
||||
;; quad list predicate and list-of-list predicate.
|
||||
;; These are faster than the listof contract combinator.
|
||||
(define (ids? x)
|
||||
(and (list? x) (andmap id? x)))
|
||||
(define (lists-of-ids? x)
|
||||
(and (list? x) (andmap ids? x)))
|
||||
;; quad converter macro
|
||||
(define (quads->id qs)
|
||||
(apply id (gather-common-attrs qs) qs))))]))
|
||||
|
||||
|
||||
;; do not treat empty string as whitespace.
|
||||
;; throws off tests that rely on adjacency to positive whitespace.
|
||||
(define (whitespace? x [nbsp? #f])
|
||||
((any/c)(boolean?) . ->* . coerce/boolean?)
|
||||
(cond
|
||||
[(quad? x) (whitespace? (quad-list x) nbsp?)]
|
||||
[(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 (curryr whitespace? 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 ()
|
||||
[(_ 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)])
|
||||
#'(begin
|
||||
(define-box-type id)
|
||||
(define-box-type id-break)
|
||||
(define-box-type multi-id)
|
||||
;; breaker
|
||||
(define (split-on-id-breaks x)
|
||||
(quads? . -> . lists-of-quads?)
|
||||
;; omit leading & trailing whitespace, because they're superfluous next to a break
|
||||
(map (curryr trimf whitespace?) (filter-split x id-break?)))))]))
|
||||
|
||||
(define-box-type box)
|
||||
|
||||
(define-break-type word)
|
||||
(define (word-string c) (car (quad-list c)))
|
||||
|
||||
(define-box-type spacer)
|
||||
(define-box-type kern)
|
||||
(define-box-type optical-kern)
|
||||
(define-box-type flag)
|
||||
(define-box-type doc)
|
||||
(define-box-type input)
|
||||
(define-box-type piece)
|
||||
(define-box-type run)
|
||||
|
||||
(define-break-type page)
|
||||
(define-break-type column)
|
||||
(define-break-type block)
|
||||
(define-break-type line)
|
||||
(vector name attrs xs))
|
||||
|
||||
(define (->input q) (input empty q))
|
||||
(define coerce/input? (make-coercion-contract input))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define q (quad 'foo #f '("bar")))
|
||||
(check-true (quad? q))
|
||||
(check-false (quad? 42))
|
||||
(check-equal? (quad-name q) 'foo)
|
||||
(check-equal? (quad-attrs q) #f)
|
||||
(check-equal? (quad-list q) '("bar")))
|
||||
@ -0,0 +1,79 @@
|
||||
#lang racket
|
||||
(require "quads.rkt")
|
||||
|
||||
;; push together multiple attr sources into one list of pairs.
|
||||
;; mostly a helper function for the two attr functions below.
|
||||
(define (join-attrs quads-or-attrs-or-lists)
|
||||
(append-map hash->list (filter-not false? (map (λ(x)
|
||||
(cond
|
||||
[(quad? x) (quad-attrs x)]
|
||||
[(quad-attrs? x) x]
|
||||
#;[(hashable-list? x) (apply hash x)]
|
||||
[else #f])) quads-or-attrs-or-lists))))
|
||||
|
||||
|
||||
;; flatten merges attributes, but applies special logic suitable to flattening
|
||||
;; for instance, resolving x and y coordinates.
|
||||
(define (flatten-attrs . quads-or-attrs-or-falses)
|
||||
(define all-attrs (join-attrs quads-or-attrs-or-falses))
|
||||
(define-values (x-attrs y-attrs other-attrs-reversed)
|
||||
(for/fold ([xas null][yas null][oas null])([attr (in-list all-attrs)])
|
||||
(cond
|
||||
[(equal? (car attr) 'x) (values (cons attr xas) yas oas)]
|
||||
[(equal? (car attr) 'y) (values xas (cons attr yas) oas)]
|
||||
[else (values xas yas (cons attr oas))])))
|
||||
(define (make-cartesian-attr key attrs) (if (empty? attrs) empty (cons key (apply + (map cdr attrs)))))
|
||||
(define-values (x-attr y-attr) (apply values (map make-cartesian-attr (list 'x 'y) (list x-attrs y-attrs))))
|
||||
(apply hash (flatten (list* x-attr y-attr (reverse other-attrs-reversed)))))
|
||||
|
||||
;; pushes attributes down from parent quads to children,
|
||||
;; resulting in a flat list of quads.
|
||||
(define (flatten-quad q)
|
||||
(flatten
|
||||
(let loop ([x q][parent #f])
|
||||
(cond
|
||||
[(quad? x)
|
||||
(let ([x-with-parent-attrs (quad (quad-name x)
|
||||
(flatten-attrs parent x) ; child positioned last so it overrides parent attributes
|
||||
(quad-list x))])
|
||||
(if (empty? (quad-list x))
|
||||
x-with-parent-attrs ; no subelements, so stop here
|
||||
(map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements
|
||||
[(string? x) (quad (quad-name parent) (quad-attrs parent) (list x))]))))
|
||||
|
||||
|
||||
|
||||
(require sugar/debug)
|
||||
;; flatten quad as above,
|
||||
;; then dissolve it into individual character quads while copying attributes
|
||||
|
||||
(define (split-quad q)
|
||||
(letrec ([do-explode (λ(x [parent #f])
|
||||
(cond
|
||||
[(quad? x)
|
||||
(if (empty? (quad-list x))
|
||||
x ; no subelements, so stop here
|
||||
(map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
|
||||
;; todo: figure out why newlines foul up the input stream. Does it suffice to ignore them?
|
||||
[else (map (λ(xc) (quad 'atom (quad-attrs parent) (list xc))) (regexp-match* #px"[^\r\n]" x))]))])
|
||||
(flatten (map do-explode (flatten-quad q)))))
|
||||
|
||||
(require (for-syntax syntax/strip-context sugar/debug))
|
||||
(define-syntax (stx-quad stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ((ATTR-NAME ATTR-VAL) ...) XS)
|
||||
(with-syntax ([(NEW-ATTR-NAME ...) (map (λ(an) (replace-context #'here an)) (syntax->list #'(ATTR-NAME ...)))])
|
||||
#'(let ([NEW-ATTR-NAME ATTR-VAL] ...)
|
||||
(for-each (λ(x) (println (list size x))) XS)))]))
|
||||
|
||||
|
||||
(require racket/generator)
|
||||
#;(define y (generator () (stx-quad ((size 10)) (list "bar" (stx-quad () '("zam"))))))
|
||||
|
||||
#|
|
||||
(define x (quad 'foo (hash 'size 10) (list "bar" (quad 'foo (hash 'size 8) '("zam")) "qux")))
|
||||
(split-quad x)
|
||||
|#
|
||||
|
||||
(define x2 (stx-quad ((size 10)) (list "bar" (stx-quad ((size 8)) '("zam")) "qux")))
|
||||
x2
|
||||
@ -0,0 +1,12 @@
|
||||
#lang quad/dev
|
||||
(provide (all-defined-out))
|
||||
(require "quads.rkt" (for-syntax racket/string racket/syntax))
|
||||
|
||||
(define-syntax (~top stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . id)
|
||||
(let ([id-str (format "~a" (syntax->datum #'id))])
|
||||
(if (id-str . string-prefix? . "q:")
|
||||
(with-syntax ([new-id (format-id #'id "~a" (string-trim id-str "q:" #:right? #f))])
|
||||
#'(λ args (apply quad 'new-id args)))
|
||||
#'(#%top . id)))]))
|
||||
Loading…
Reference in New Issue