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.
113 lines
3.7 KiB
Racket
113 lines
3.7 KiB
Racket
#lang racket/base
|
|
(require "tools.rkt" "world.rkt" "decode.rkt" sugar txexpr "cache.rkt")
|
|
|
|
|
|
(define+provide current-pagemap (make-parameter #f))
|
|
|
|
|
|
(define+provide (node? x)
|
|
(->boolean (and (symbol? x) (try (not (whitespace/nbsp? (->string x)))
|
|
(except [exn:fail? (λ(e) #f)])))))
|
|
|
|
|
|
(define+provide (nodeish? x)
|
|
(try (node? (->symbol x))
|
|
(except [exn:fail? (λ(e) #f)])))
|
|
|
|
|
|
(define/contract+provide (->node x)
|
|
(nodeish? . -> . node?)
|
|
(->symbol x))
|
|
|
|
|
|
(define+provide/contract (decode-pagemap xs)
|
|
(txexpr-elements? . -> . any/c) ; because pagemap is being explicitly validated
|
|
(validate-pagemap
|
|
(decode (cons world:pagemap-root-node xs)
|
|
#:txexpr-elements-proc (λ(xs) (filter (compose1 not whitespace?) xs))
|
|
#:string-proc string->symbol))) ; because faster than ->node
|
|
|
|
|
|
(define+provide (validate-pagemap x)
|
|
(let ([nodes (pagemap->list x)])
|
|
(and
|
|
(andmap (λ(p) (or (node? p) (error (format "validate-pagemap: \"~a\" is not a valid node" p)))) nodes)
|
|
(try (members-unique?/error nodes)
|
|
(except [exn:fail? (λ(e) (error (format "validate-pagemap: ~a" (exn-message e))))]))
|
|
x)))
|
|
|
|
|
|
(define+provide (pagemap? x)
|
|
(try (->boolean (validate-pagemap x))
|
|
(except [exn:fail? (λ(e) #f)])))
|
|
|
|
|
|
;; Try loading from pagemap file, or failing that, synthesize pagemap.
|
|
(define+provide/contract (make-project-pagemap project-dir)
|
|
(pathish? . -> . pagemap?)
|
|
(define pagemap-source (build-path project-dir world:default-pagemap))
|
|
(cached-require pagemap-source world:main-pollen-export))
|
|
|
|
|
|
(define+provide/contract (parent p [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
|
(and pagemap p
|
|
(let ([node (->node p)])
|
|
(if (member node (map (λ(x) (if (list? x) (car x) x)) (cdr pagemap)))
|
|
(car pagemap)
|
|
(ormap (λ(x) (parent node x)) (filter list? pagemap))))))
|
|
|
|
|
|
(define+provide/contract (children p [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
|
(and pagemap p
|
|
(let ([node (->node p)])
|
|
(if (equal? node (car pagemap))
|
|
(map (λ(x) (if (list? x) (car x) x)) (cdr pagemap))
|
|
(ormap (λ(x) (children node x)) (filter list? pagemap))))))
|
|
|
|
|
|
(define+provide/contract (siblings p [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
|
(children (parent p pagemap) pagemap))
|
|
|
|
|
|
;; flatten tree to sequence
|
|
(define+provide/contract (pagemap->list pagemap)
|
|
(pagemap? . -> . (listof node?))
|
|
; use cdr to get rid of root tag at front
|
|
(cdr (flatten pagemap)))
|
|
|
|
|
|
(define (adjacents side p [pagemap (current-pagemap)])
|
|
; ((symbol? (or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
|
(and pagemap p
|
|
(let* ([node (->node p)]
|
|
[proc (if (equal? side 'left) takef takef-right)]
|
|
[result (proc (pagemap->list pagemap) (λ(x) (not (equal? node x))))])
|
|
(and (not (empty? result)) result))))
|
|
|
|
|
|
(define+provide/contract (previous* node [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
|
(adjacents 'left node pagemap))
|
|
|
|
|
|
(define+provide/contract (next* node [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f (listof node?)))
|
|
(adjacents 'right node pagemap))
|
|
|
|
|
|
(define+provide/contract (previous node [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
|
(let ([result (previous* node pagemap)])
|
|
(and result (last result))))
|
|
|
|
|
|
(define+provide/contract (next node [pagemap (current-pagemap)])
|
|
(((or/c #f nodeish?)) (pagemap?) . ->* . (or/c #f node?))
|
|
(let ([result (next* node pagemap)])
|
|
(and result (first result))))
|
|
|
|
|