46 lines
1.9 KiB
Scheme
46 lines
1.9 KiB
Scheme
; Author: Paul Graunke
|
|
#cs(module servlet mzscheme
|
|
(require (lib "servlet-env.ss" "web-server")
|
|
(lib "error.ss" "htdp")
|
|
(lib "xml.ss" "xml")
|
|
(lib "list.ss")
|
|
(lib "prim.ss" "lang")
|
|
(lib "unitsig.ss"))
|
|
(provide (all-from-except (lib "servlet-env.ss" "web-server") build-suspender)
|
|
(rename wrapped-build-suspender build-suspender))
|
|
|
|
(define wrapped-build-suspender
|
|
(case-lambda
|
|
[(title content)
|
|
(check-suspender2 title content)
|
|
(build-suspender title content)]
|
|
[(title content body-attributes)
|
|
(check-suspender3 title content body-attributes)
|
|
(build-suspender title content body-attributes)]
|
|
[(title content body-attributes head-attributes)
|
|
(check-suspender4 title content body-attributes head-attributes)
|
|
(build-suspender title content body-attributes head-attributes)]))
|
|
|
|
; : tst tst -> void
|
|
(define (check-suspender2 title content)
|
|
(check-arg 'build-suspender (listof? xexpr? title) "(listof xexpr[HTML])" "1st" title)
|
|
(check-arg 'build-suspender (listof? xexpr? content) "(listof xexpr[HTML])" "2nd" content))
|
|
|
|
; : tst tst tst -> void
|
|
(define (check-suspender3 title content body-attributes)
|
|
(check-suspender2 title content)
|
|
(check-arg 'build-suspender (listof? attribute-pair? body-attributes)
|
|
"(listof (cons sym str))" "3rd" body-attributes))
|
|
|
|
; : tst tst tst tst -> void
|
|
(define (check-suspender4 title content body-attributes head-attributes)
|
|
(check-suspender3 title content body-attributes)
|
|
(check-arg 'build-suspender (listof? attribute-pair? head-attributes)
|
|
"(listof (cons sym str))" "4th" head-attributes))
|
|
|
|
; : tst -> bool
|
|
(define (attribute-pair? b)
|
|
(and (pair? b)
|
|
(symbol? (car b))
|
|
(string? (cdr b)))))
|