make setup object based

setup.rkt

@@ -1,10 +1,49 @@
 #lang racket/base
-(require racket/system racket/port racket/file racket/string racket/date)
+(require racket/system racket/port racket/file 
+         racket/string racket/date racket/class racket/list)
 (require "debug.rkt" "readability.rkt")
 
 (provide setup)
 
 (define cd (current-directory))
+(define test-mode (make-parameter #f))
+
+;; simple class for setup tasks
+(define task% 
+  (class object%
+    (init do-proc [undo-proc #f])
+    (define this-do do-proc)
+    (define this-undo undo-proc)
+    (super-new)
+    (define/public (do-task) (this-do))
+    (define/public (undo-task) (if this-undo (this-undo) (void)))))
+
+;; function for invoking method of multiple objects
+(define-syntax send-each
+  (syntax-rules ()
+    ;; invoke a method of every object in list
+    [(send-each objects do-method)
+     (for-each (λ(obj) (send obj do-method)) objects)]
+    ;; invoke a method of every object in list, but
+    ;; if error, invoke the undo method all the way backwards
+    ;; allows structured cleanup
+    [(send-each objects do-method undo-method)
+     (begin
+       (define (send-stack-inner objects-inner)
+         (if (empty? objects-inner)
+             (void)
+             (with-handlers ([exn:fail? (λ(err) 
+                                          (begin 
+                                            (send (car objects-inner) undo-method) 
+                                            (raise err)))])
+               (send (car objects-inner) do-method)
+               (send-stack-inner (cdr objects-inner)))))
+       ;; error has been handled all the way back up the stack
+       ;; so kill it here 
+       (with-handlers ([exn:fail? (λ(err) (void))])
+         (send-stack-inner objects)))]))
+
+
 
 (define (make-polcom-data racket-path)
   (format "#! ~a
@@ -15,42 +54,86 @@
           cd
           (format "~a at ~a" (make-datestamp) (make-timestamp))))
 
-(define (setup)
-  ; this function is just for export.
-  ; it hides the test-only parameter
-  (setup-testable #f))
 
-(define (setup-testable test-only)    
+;; task: get confirmation
+(define (get-confirmation)
   (message (format "Set up ~a as a pollen directory? ['y' or 'yes']" cd))
-  (define setup-confirm (if test-only "y" (->string (read))))
+  (define setup-confirm (->string (read)))
-  (when (not (or (equal? setup-confirm "y") (equal? setup-confirm "yes")))
+  (when (not (ormap (λ(input)(equal? setup-confirm input)) (list "y" "yes")))
+    (error))
+  (message (format "Setting up ~a as a pollen directory" cd)))
+
+(define (abort-confirmation)
+  (message "Aborting setup"))
+
+(define confirm-setup
+  (new task% 
+       [do-proc get-confirmation]
+       [undo-proc abort-confirmation]))
+
+
+;; task: make polcom file
+(define polcom-filename "polcom")
+
+(define (delete-polcom-file-if-existing)
+  (when (file-exists? polcom-filename)
     (begin
-      (message "Aborting setup")
+      (message (format "Deleting existing polcom file in ~a" cd))
-      (exit)))
+      (delete-file polcom-filename))))
-  (message (format "Setting up ~a as a pollen directory" cd))
+
-  
+(define (save-polcom-file)
   (define racket-path (string-trim (with-output-to-string (λ() (system "which racket")))))
   (define path-to-racket-exists? (> (len racket-path) 0)) 
   
   (if path-to-racket-exists?
-      (let ([polcom-data (make-polcom-data racket-path)]
+      (let ([polcom-data (make-polcom-data racket-path)])
-            [polcom-filename "polcom"])
         (message (format "Using ~a as racket path" racket-path))
-        (when (file-exists? polcom-filename)
+        (delete-polcom-file-if-existing)
-          (begin
+        (message (format "Creating new polcom file in ~a" cd))
-            (message (format "Deleting existing polcom file in ~a" cd))
+        (if (not (test-mode))
-            (delete-file polcom-filename)))
+            (begin
-        (with-handlers ([exn:fail? (λ(e) (message "Couldn't write polcom file. Aborting setup"))])
+              (display-to-file polcom-data polcom-filename)
-          (when (not test-only)
+              (with-output-to-string (λ() (system (format "chmod 755 ~a" polcom-filename)))))
-              (begin
+            (message "[test mode: file would be saved now]")))
-                (message (format "Creating new polcom file in ~a" cd))
+      (begin 
-                (display-to-file polcom-data polcom-filename)
+        (message "No path to Racket binary")
-                (with-output-to-string (λ() (system (format "chmod 755 ~a" polcom-filename))))))
+        (error))))
-          (message "Setup complete")
+
-          (message (format "Run '~a~a start' to start project server" cd polcom-filename))
+(define (abort-polcom-file)
-          (message (format "Or run '~a~a help' for a list of commands" cd polcom-filename))
+  (message "Couldn't create polcom file")
-          (when (not test-only) (exit))))
+  (delete-polcom-file-if-existing))
-      (message "No path to racket binary. Aborting setup")))
+
+(define make-polcom
+  (new task%
+       [do-proc save-polcom-file]
+       [undo-proc abort-polcom-file]))
+
+
+;; task: report success
+
+(define (success-messages)
+  (message "Setup complete")
+  (message (format "Run '~a~a start' to start project server" cd polcom-filename))
+  (message (format "Or run '~a~a help' for a list of commands" cd polcom-filename))
+  (when (not (test-mode)) (exit)))
+
+(define report-success
+  (new task% 
+       [do-proc success-messages]))
+
+
+(define tasks (list confirm-setup make-polcom report-success))
+(define (setup)
+  (send-each tasks do-task undo-task))
+
+
+;; better way to do this is to create separate removal tasks
+;; (that may rely on some of the same intermediate functions)
+;; so that errors can be caught on the way out too.
+;; also, remove conflicts with existing racket name
+;;(define (remove)
+;;  (send-each (reverse tasks) remove-task))
 
 (module+ main
-  (setup-testable #t))
+  (parameterize ([test-mode #t])
+    (setup)))