" 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\"" (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