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.
67 lines
2.9 KiB
Racket
67 lines
2.9 KiB
Racket
#lang racket/base
|
|
(require racket/contract)
|
|
(require (only-in xml xexpr/c))
|
|
(require "tools.rkt" "predicates.rkt")
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
(provide (contract-out
|
|
[decode ((xexpr/c) ;; use xexpr/c for contract on nx because it gives better error messages
|
|
|
|
;; todo: how to write more specific contracts for these procedures?
|
|
;; e.g., string-proc should be restricted to procs that accept a string as input
|
|
;; and return a string as output
|
|
(#:exclude-xexpr-tags list?
|
|
#:xexpr-tag-proc procedure?
|
|
#:xexpr-attr-proc procedure?
|
|
#:xexpr-elements-proc procedure?
|
|
#:block-xexpr-proc procedure?
|
|
#:inline-xexpr-proc procedure?
|
|
#:string-proc procedure?)
|
|
. ->* . tagged-xexpr?)]
|
|
[register-block-tag (symbol? . -> . void?)]))
|
|
|
|
;; add a block tag to the list
|
|
;; this function is among the predicates because it alters a predicate globally.
|
|
(define (register-block-tag tag)
|
|
(append-block-tag tag))
|
|
|
|
(module+ test
|
|
(check-true (begin (register-block-tag 'barfoo) (block-xexpr? '(barfoo "foo")))))
|
|
|
|
|
|
;; decoder wireframe
|
|
(define (decode nx
|
|
#:exclude-xexpr-tags [excluded-xexpr-tags '()]
|
|
#:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)]
|
|
#:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
|
|
#:xexpr-elements-proc [xexpr-elements-proc (λ(x)x)]
|
|
#:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
|
|
#:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
|
|
#:string-proc [string-proc (λ(x)x)])
|
|
|
|
(when (not (tagged-xexpr? nx))
|
|
(error (format "decode: ~v not a full tagged-xexpr" nx)))
|
|
|
|
|
|
(define (&decode x)
|
|
(cond
|
|
[(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)])
|
|
(if (tag . in? . excluded-xexpr-tags)
|
|
x ; let x pass through untouched
|
|
(let ([decoded-xexpr (apply make-tagged-xexpr
|
|
(map &decode (list tag attr elements)))])
|
|
((if (block-xexpr? decoded-xexpr)
|
|
block-xexpr-proc
|
|
inline-xexpr-proc) decoded-xexpr))))]
|
|
[(xexpr-tag? x) (xexpr-tag-proc x)]
|
|
[(xexpr-attr? x) (xexpr-attr-proc x)]
|
|
;; need this for operations that may depend on context in list
|
|
[(xexpr-elements? x) (map &decode (xexpr-elements-proc x))]
|
|
[(string? x) (string-proc x)]
|
|
;; if something has made it through undecoded, that's a problem
|
|
[else (error "Can't decode" x)]))
|
|
|
|
|
|
(&decode nx))
|