"
Assume and export:
(struct dir (name dirs files))
(struct file (name size content))
A directory is
(make-dir symbol (listof directory) (listof file))
A file is
(make-file symbol number symbol)
Export:
create-dir : string[path-name] -> directory."
(define-signature errorS (check-arg check-arity check-proc))
(define errorU
(unit/sig errorS
(import)
;; check-arg : sym bool str str TST -> void
(define (check-arg pname condition expected arg-posn given)
(unless condition
(error pname "expected <~a> as ~a argument, given: ~e" expected arg-posn given)))
;; check-arity : sym num (list-of TST) -> void
(define (check-arity name arg# args)
(if (>= (length args) arg#)
(void)
(error name "expects at least ~a arguments, given ~e" arg# (length args))))
;; check-proc : sym (... *->* ...) num (union sym str) (union sym str) -> void
(define (check-proc proc f exp-arity arg# arg-err)
(unless (procedure? f)
(error proc "procedure expected as ~s argument; given ~e" arg# f))
(unless (and (number? (arity f)) (= (arity f) exp-arity))
(error proc
"procedure of ~a expected as ~s argument; given procedure of ~s arguments"
arg-err arg# (arity f))))))
(define-signature dirS
((struct dir (name dirs files))
(struct file (name size content))
create-dir get-path-to-file))
(define dirU
(let ((f-s (lambda (x) (if (link-exists? x) 0 (file-size x)))))
(unit/sig dirS
(import errorS plt:userspace^)
(define-struct dir (name dirs files))
(define-struct file (name size content))
;; create-dir : path -> directory
(define (create-dir a-path)
(check-arg 'create-dir (string? a-path) "string" "first" a-path)
(if (directory-exists? a-path)
(car (explore (list a-path)))
(error 'create-dir "not a directory: ~e" a-path)))
;; explore : (listof directory-names) -> (listof directory)
(define (explore dirs)
(map (lambda (d)
(let-values ([(fs ds) (pushd d directory-files&directories)])
(make-dir
(string->symbol (my-split-path d))
(explore (map (lambda (x) (build-path d x)) ds))
(map make-file
(map string->symbol fs)
(map f-s (map (lambda (x) (build-path d x)) fs))
(map (lambda (x) (if (link-exists? x) 'link null)) fs)))))
dirs))
(define (my-split-path d)
(let-values ([(base name mbd?) (split-path d)])
(if (string? base) name d)))
;; pushd : directory-name ( () -> X ) -> X
(define (pushd d f)
(let ((current (current-directory)))
(dynamic-wind
(lambda () (current-directory d))
(lambda () (f))
(lambda () (current-directory current)))))
;; directory-files&directories :
;; () -> (values (listof file-names) (listof directory-names))
(define (directory-files&directories)
(let ((contents (directory-list)))
(values
(filter (lambda (x) (or (file-exists? x) (link-exists? x))) contents)
(filter (lambda (x)
(and (directory-exists? x) (not (link-exists? x))))
contents))))
;; filter: (X -> bool) (listof X) -> (listof X)
;; (define (filter p? l)
;; (foldr (lambda (fst rst) (if (p? fst) (cons fst rst) rst)) '() l))
;; get-file-content : file -> (int -> string)
;; to read a file on demand as a string
;; option to expand the library ...
;; cache it ...
(define (get-file-content f)
(read-string (file-size f)
(open-input-file (symbol->string (file-name f)))))
(define (get-path-to-file a-file in-dir)
(local ((define (add-dir to-path)
(string-append (symbol->string (dir-name in-dir))
"/" to-path)))
(cond [(ormap (lambda (f)
(symbol=? (file-name f) a-file))
(dir-files in-dir))
(add-dir (symbol->string a-file))]
[else (local ((define found-path
(ormap (lambda (a-dir)
(get-path-to-file a-file a-dir))
(dir-dirs in-dir))))
(cond [(string? found-path)
(add-dir found-path)]
[else false]))])))
; Test:
; (define G (create-dir "."))
; (define foo (assf (lambda (x) (eq? 'dir-test.ss (file-name x))) (dir-files G)))
; (get-file-content foo)
)))
(compound-unit/sig
(import (PLT : plt:userspace^))
(link
(XXX : dirS (dirU ERR PLT))
(ERR : errorS (errorU)))
(export (open XXX)))
(define functionU (require-library-unit/sig "functior.ss"))
(define prettyU (require-library-unit/sig "prettyr.ss"))
(define-signature htmlS
(make-html-hrule html-hrule?
make-html-list html-list-items html-list-numbered? html-list?
make-html-paragraph html-paragraph-contents html-paragraph?
make-html-section html-section-heading html-section-level
html-section-center-heading? html-section-contents html-section?
make-html-table html-table-header html-table-rows html-table-grid?
html-table?
make-html-link html-link-URL html-link-text html-link?
make-html-center html-center-contents html-center?
make-html-image html-image-file html-image-description html-image?
make-html-page html-page-title html-page-bgcolor html-page-contents
html-page?
html-to-file category-filename))
(define HtmlU
(unit/sig htmlS
(import mzlib:function^ mzlib:pretty-print^)
(define-struct html-hrule ())
(define-struct html-list (items numbered?))
(define-struct html-paragraph (contents))
(define-struct html-section (heading level center-heading? contents))
(define-struct html-table (header rows grid?))
(define-struct html-link (URL text))
(define-struct html-center (contents))
(define-struct html-image (file description))
(define-struct html-page (title bgcolor contents))
(define (category-filename sym)
(string-append (symbol->string sym) ".html"))
(define (enclose-in-tag tag str . attr)
(if (null? attr)
(format "<~a>~a
" tag str tag)
(format "<~a ~a>~a
" tag (car attr) str tag)))
(define (render-lohtml html-elts)
(apply string-append
(map (lambda (item) (format " ~a " (render-html item))) html-elts)))
;; html-elt or list of html-elt -> string
(define (render-contents contents . tag)
(let ([content-str
(if (list? contents)
(render-lohtml contents)
(render-html contents))])
(if (null? tag) content-str (enclose-in-tag (car tag) content-str))))
;; enclose-each-and-combine : string list-of html-elts -> string
(define (enclose-each-and-combine tag html-elts)
(apply string-append
(map (lambda (elt) (enclose-in-tag tag (render-html elt)))
html-elts)))
(define (render-atom html-elt)
(cond [(string? html-elt) html-elt]
[(number? html-elt) (number->string html-elt)]
[(symbol? html-elt) (symbol->string html-elt)]
[else (error "Given html-elt ~a is not an html-atom" html-elt)]))
;; render-html : html-elt -> string
(define (render-html html-elt)
(cond [(string? html-elt) html-elt]
[(number? html-elt) (number->string html-elt)]
[(symbol? html-elt) (symbol->string html-elt)]
[(html-hrule? html-elt) "
"]
[(html-list? html-elt)
(let ([items (apply string-append
(map (lambda (item)
(format " ~a" (render-html item)))
(html-list-items html-elt)))])
(if (html-list-numbered? html-elt)
(enclose-in-tag "ol" items)
(enclose-in-tag "ul" items)))]
[(html-paragraph? html-elt)
(render-contents (html-paragraph-contents html-elt) "p")]
[(html-section? html-elt)
(let ([header (enclose-in-tag (format "h~a" (html-section-level html-elt))
(render-atom (html-section-heading html-elt)))])
(if (html-section-center-heading? html-elt)
(string-append (enclose-in-tag "center" header)
(render-contents (html-section-contents html-elt)))
(string-append header
(render-contents (html-section-contents html-elt)))))]
[(html-table? html-elt)
(let ([table-contents
(apply string-append
(cons (enclose-in-tag
"tr" (enclose-each-and-combine
"th" (map render-atom (html-table-header html-elt))))
(map (lambda (row)
(enclose-in-tag
"tr" (enclose-each-and-combine "td" row)))
(html-table-rows html-elt))))])
(if (html-table-grid? html-elt)
(enclose-in-tag "table" table-contents "border=3")
(enclose-in-tag "table" table-contents)))]
[(html-link? html-elt)
(enclose-in-tag "a" (render-atom (html-link-text html-elt))
(format "href=~s" (html-link-URL html-elt)))]
[(html-center? html-elt)
(render-contents (html-center-contents html-elt) "center")]
[(html-image? html-elt)
(format "![\"~a\"](\"~a\")
"
(html-image-file html-elt)
(render-atom (html-image-description html-elt)))]
[(html-page? html-elt)
(enclose-in-tag "html"
(string-append
(enclose-in-tag "title" (html-page-title html-elt))
(enclose-in-tag
"body"
(render-contents (html-page-contents html-elt))
(format "bgcolor=~a" (html-page-bgcolor html-elt)))))]))
; (define (popup-html html-elt)
; (let* ([html-string (render-html html-elt)]
; [port (open-input-string html-string)])
; (open-url port)
; (close-input-port port)
; #t))
(define (html-to-file html-elt filename)
(let ([html-string (render-html html-elt)]
[port (open-output-file filename 'replace)])
(pretty-display html-string port)
(close-output-port port)
#t))
))
(define-signature hwk2S
(make-album album-artist album-title album-category album?
make-format format-type format-copies format-price format?
make-stock stock-album stock-cd stock-tape stock?
make-lst lst-first lst-rest lst?
gen-page/1 gen-page/2 gen-page/3 gen-page/4 gen-page/5
produce-test-page produce-test-page/list
filename-for-stock
update-db base-inventory
))
(define CoreHwk2U
(unit/sig hwk2S
(import htmlS plt:userspace^)
(define-struct album (artist title category))
(define-struct format (type copies price))
(define-struct stock (album cd tape))
;; inventory is a list of stock
(define-struct lst (first rest))
(define (make-list->list mlist)
(cond [(empty? mlist) null]
[else (cons (lst-first mlist) (make-list->list (lst-rest mlist)))]))
(define (^inca a-stock category)
(let ([c (lambda (e) (apply (apply compose
(list album-category stock-album))
(cons e '())))])
(symbol=? category (c a-stock))))
(define (!*appup?* an-update a-stock)
(printf "in *appup*~n")
(and (string=?
(album-artist (stock-album a-stock))
(with-handlers
([exn:else?
(lambda (exn) (cons exn empty))])
(update-artist an-update)))
(string=?
(update-title an-update)
(with-handlers
([exn:struct?
(lambda (exn) (cons exn empty))])
(album-title (stock-album a-stock))))))
(define (cohabitators name selector1 a-stock an-update selector2)
(let ((cohorts (lambda (format-what selector update-what)
(+ (format-what (selector a-stock))
(update-what an-update)))))
(make-format name
(cohorts format-copies selector1 update-change-in-copies)
(cohorts format-price selector2 update-change-in-price))))
(define (upst** an-update a-stock)
(cond [(symbol=? (update-type an-update) 'cd)
(make-stock (stock-album a-stock)
(cohabitators 'cd stock-cd a-stock an-update stock-cd)
(stock-tape a-stock))]
[(symbol=? (update-type an-update) 'tape)
(make-stock (stock-album a-stock)
(stock-cd a-stock)
(cohabitators 'tape stock-tape a-stock an-update stock-tape))]))
(define (gad++ a-stock)
(let ([gap (lambda (a-format)
(if a-format (format-price a-format) "N/A"))])
(let ((lst->list (lambda (l)
(let lp ((l l))
(if (null? l) l
(cons (lst-first l) (lp (lst-rest l)))))))
(list->lst (lambda (l)
(foldr make-lst empty l))))
(list->lst
(apply list (map (lambda (f)
(f a-stock))
(lst->list
(make-lst
(lambda (e) (album-artist (stock-album e)))
(make-lst
(lambda (e) (album-title (stock-album e)))
(make-lst
(lambda (e) (gap (stock-cd e)))
(make-lst
(lambda (e) (gap (stock-tape e)))
empty)))))))))))
(define (get-stock type inventory)
(filter (lambda (a-stock) (in-category? a-stock type))
inventory))
; filename-for-stock : stock -> string
(define (char-converter c)
(if (char=? c #\space) #\- c))
(define (spaces/dashes s)
(list->string (map char-converter (string->list s))))
(define (filename-for-stock stock)
(string-append (spaces/dashes (album-title (stock-album stock)))
".html"))
(define (update-db apply-update? update-stock an-update inventory)
(foldr (lambda (a-stock rst)
((lambda (tst tb fb)
(if tst (tb a-stock rst) (fb a-stock rst)))
(apply-update? an-update a-stock)
(lambda (f r) (cons (update-stock an-update f) r))
cons))
() inventory))
(define (get-table-rows inventory)
(map (lambda (stock-item)
((lambda (data)
(if (lst? data) (make-list->list data) data))
(get-album-data stock-item)))
inventory))
(define (make-section-table inventory get-table-rows)
(make-html-table
(let ([fst "Artist"] [snd "Album"])
(append (list fst snd) (list "CD Price") (list "Cassette Price")))
(get-table-rows inventory)
#t))
(define (produce-test-page html-item-or-list filename)
(html-to-file (make-html-page "210 Test Page" "WHITE" html-item-or-list)
filename))
(define produce-test-page/list produce-test-page)
;; gen-first-page : inventory -> boolean
;; generates web page for an inventory
(define (gen-first-page inventory get-stock get-table-rows)
(let ([classical (get-stock 'classical inventory)]
[rock (get-stock 'rock inventory)]
[blues (get-stock 'blues inventory)])
(html-to-file
(make-html-page
"Sammy's Music Prices" "WHITE"
(make-html-section
"Sammy's Music" 1 #t
(list
(make-html-paragraph
(make-html-center "Check out our Inventory!"))
(make-html-hrule)
(make-html-section "Classical" 2 #f (make-section-table classical get-table-rows))
(make-html-paragraph "")
(make-html-hrule)
(make-html-section "Rock" 2 #f (make-section-table rock get-table-rows))
(make-html-paragraph "")
(make-html-hrule)
(make-html-section "Blues" 2 #f (make-section-table blues get-table-rows))
(make-html-paragraph "")
(make-html-hrule)
)))
"210Music.html")
#t))
(define (make-gen-page sub-in-category? sub-apply-update?
sub-update-stock sub-get-album-data
get-stock get-table-rows)
(if sub-in-category?
(set! in-category? sub-in-category?)
(set! in-category? ^inca))
(if sub-apply-update?
(set! apply-update? sub-apply-update?)
(set! apply-update? !*appup?*))
(if sub-update-stock
(set! update-stock sub-update-stock)
(set! update-stock upst**))
(if sub-get-album-data
(set! get-album-data sub-get-album-data)
(set! get-album-data gad++))
(lambda (inventory)
(gen-first-page inventory get-stock get-table-rows)))
(define in-category? #f)
(define apply-update? #f)
(define update-stock #f)
(define get-album-data #f)
(define update-artist #f)
(define update-title #f)
(define update-type #f)
(define update-change-in-copies #f)
(define update-change-in-price #f)
(define (gen-page/1 in-category? inventory)
((make-gen-page in-category? #f #f #f get-stock get-table-rows) inventory))
(define (gen-page/2 inventory)
((make-gen-page #f #f #f #f get-stock get-table-rows) inventory))
(define (gen-page/3 get-album-data inventory)
((make-gen-page #f #f #f get-album-data get-stock get-table-rows) inventory))
(define (gen-page/4 in-category? get-album-data inventory)
((make-gen-page in-category? #f #f get-album-data get-stock get-table-rows)
inventory))
(define (gen-page/5 get-stock get-table-data inventory)
((make-gen-page #f #f #f #f get-stock get-table-rows) inventory))
;; inventory data
(define a1 (make-album "Bach" "Brandenburg Concertos" 'classical))
(define a2 (make-album "Pink Floyd" "The Wall" 'rock))
(define a3 (make-album "Vivaldi" "The Four Seasons" 'classical))
(define a4 (make-album "Beatles" "Abbey Road" 'rock))
(define a5 (make-album "BB King" "The Thrill is Gone" 'blues))
(define a6 (make-album "Beatles" "Yellow Submarine" 'rock))
(define base-inventory
(list (make-stock a1 (make-format 'cd 4 8.99)
(make-format 'cassette 3 5.99))
(make-stock a2 (make-format 'cd 8 12.99)
(make-format 'cassette 0 7.99))
(make-stock a3 (make-format 'cd 6 8.99) #f)
(make-stock a4 #f (make-format 'cassette 9 12.99))
(make-stock a5 (make-format 'cd 4 11.99) #f)
(make-stock a6 (make-format 'cd 5 11.99) (make-format 'tape 6 8.99))
))
))
(define hwk4U
(compound-unit/sig
(import (PLT : plt:userspace^))
(link
(FUNCTION : mzlib:function^ (functionU))
(PRETTY : mzlib:pretty-print^ (prettyU))
(XXX : dirS (dirU ERR PLT))
(ERR : errorS (errorU))
(HTML : htmlS (HtmlU FUNCTION PRETTY))
(HWK2 : hwk2S (CoreHwk2U HTML PLT)))
(export (open HTML) (open HWK2) (open XXX))))
hwk4U