82 lines
2.4 KiB
Scheme
82 lines
2.4 KiB
Scheme
#lang scheme
|
|
|
|
(require htdp/error
|
|
lang/prim)
|
|
|
|
(provide
|
|
create-dir ; path -> Directory
|
|
|
|
; structure
|
|
dir?
|
|
make-dir
|
|
dir-name
|
|
dir-dirs
|
|
dir-files
|
|
|
|
; structure
|
|
(rename-out (fil? file?)
|
|
(make-fil make-file)
|
|
(fil-name file-name)
|
|
(fil-content file-content)
|
|
(fil-size file-size))
|
|
)
|
|
|
|
;; Structures:
|
|
(define-struct dir (name dirs files) #:transparent)
|
|
(define-struct fil (name size content) #:transparent)
|
|
|
|
(define-primitive create-dir create-dir/proc)
|
|
|
|
;; Data:
|
|
;; Directory = (make-dir Symbol (listof Dir) (listof File))
|
|
;; File = (make-file Symbol Number (union '() X))
|
|
|
|
(define (create-dir/proc a-path)
|
|
(check-arg 'create-dir (string? a-path) "string" "first" a-path)
|
|
(let ([a-path! (string->path a-path)])
|
|
(if (directory-exists? a-path!)
|
|
(car (explore (list a-path!)))
|
|
(error 'create-dir "not a directory: ~e" a-path))))
|
|
|
|
;; explore : (listof String[directory-names]) -> (listof Directory)
|
|
(define (explore dirs)
|
|
(map (lambda (d)
|
|
(let-values ([(fs ds) (pushd d directory-files&directories)])
|
|
(make-dir
|
|
(string->symbol (path->string (my-split-path d)))
|
|
(explore (map (lambda (x) (build-path d x)) ds))
|
|
(map make-fil
|
|
(map (compose string->symbol path->string) fs)
|
|
(map (lambda (x) (if (file-exists? x) (file-size x) 0))
|
|
(map (lambda (x) (build-path d x)) fs))
|
|
(map (lambda (x) (if (link-exists? x) 'link null)) fs)))))
|
|
dirs))
|
|
|
|
;; String -> String
|
|
(define (my-split-path d)
|
|
(let-values ([(base name mbd?) (split-path d)])
|
|
(if (string? base) name d)))
|
|
|
|
;; pushd : String[directory-name] (-> X) -> X
|
|
(define (pushd d f)
|
|
(parameterize ([current-directory d])
|
|
(f)))
|
|
|
|
;; directory-files&directories :
|
|
;; (-> (values (listof String[file-names]) (listof String[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))))
|
|
|
|
;; 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 (fil-size f)
|
|
(open-input-file (symbol->string (fil-name f)))))
|
|
|