emo/thin-provisioning-tools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[functional tests] Split out an (xml) library from (thin-xml)

Browse Source 
Preparation for writing cache-xml and era-xml.
This commit is contained in:
Joe Thornber 2017-08-17 11:55:18 +01:00
parent 8fc8331404
commit 0730016cc2
2 changed files with 59 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
functional-tests/thin-xml.scm
View File

@ -1,8 +1,9 @@
(library
(thin-xml)
(export generate-xml to-attribute-name)
(export generate-xml)
(import (rnrs)
(list-utils)
(xml)
(fmt fmt)
(only (srfi s1 lists) iota)
(srfi s27 random-bits))
@ -19,58 +20,6 @@
(lambda ()
(+ low (random-integer range)))))
;;;----------------------------------------
(define (dquote doc)
(cat (dsp #\") doc (dsp #\")))
(define (to-attribute-name sym)
(define (to-underscore c)
(if (eq? #\- c) #\_ c))
(list->string (map to-underscore (string->list (symbol->string sym)))))
(define (attribute dotted-pair)
(let ((key (to-attribute-name (car dotted-pair)))
(val (cdr dotted-pair)))
(cat (dsp key)
(dsp "=")
(dquote ((if (string? val) dsp wrt) val)))))
(define (%open-tag sym attrs end)
(cat (dsp "<")
(dsp sym)
(dsp " ")
(apply cat (intersperse (dsp " ")
(map attribute attrs)))
(dsp end)))
(define (open-tag sym attrs)
(%open-tag sym attrs ">"))
(define (simple-tag sym attrs)
(%open-tag sym attrs "/>"))
(define (close-tag sym)
(cat (dsp "</")
(dsp sym)
(dsp ">")))
(define (tag sym attrs . body)
(if (null? body)
(simple-tag sym attrs)
(begin
(cat (open-tag sym attrs)
nl
(apply cat body)
nl
(close-tag sym)))))
(define (vcat docs)
(apply cat (intersperse nl docs)))
;;;----------------------------------------
(define (div-down n d)
(floor (/ n d)))

57
functional-tests/xml.scm Normal file
View File

@ -0,0 +1,57 @@
(library
(xml)
(export tag
vcat)
(import (rnrs)
(fmt fmt)
(list-utils))
(define (dquote doc)
(cat (dsp #\") doc (dsp #\")))
(define (to-attribute-name sym)
(define (to-underscore c)
(if (eq? #\- c) #\_ c))
(list->string (map to-underscore (string->list (symbol->string sym)))))
(define (attribute dotted-pair)
(let ((key (to-attribute-name (car dotted-pair)))
(val (cdr dotted-pair)))
(cat (dsp key)
(dsp "=")
(dquote ((if (string? val) dsp wrt) val)))))
(define (%open-tag sym attrs end)
(cat (dsp "<")
(dsp sym)
(dsp " ")
(apply cat (intersperse (dsp " ")
(map attribute attrs)))
(dsp end)))
(define (open-tag sym attrs)
(%open-tag sym attrs ">"))
(define (simple-tag sym attrs)
(%open-tag sym attrs "/>"))
(define (close-tag sym)
(cat (dsp "</")
(dsp sym)
(dsp ">")))
(define (tag sym attrs . body)
(if (null? body)
(simple-tag sym attrs)
(begin
(cat (open-tag sym attrs)
nl
(apply cat body)
nl
(close-tag sym)))))
(define (vcat docs)
(apply cat (intersperse nl docs))))