From dbdde3440199da73418be1c0df2b5089f910ac3d Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Thu, 27 Mar 2014 12:00:57 -0700
Subject: [PATCH] add cloning function

---
 command.rkt | 35 +++++++++++++++++++++++++++++++++++
 file.rkt    |  7 +++++++
 raco.rkt    |  5 +++--
 3 files changed, 45 insertions(+), 2 deletions(-)

diff --git a/command.rkt b/command.rkt
index 0bc3851..71f29b5 100644
--- a/command.rkt
+++ b/command.rkt
@@ -34,6 +34,41 @@ clone                 copy project to desktop without source files" ,(world:curr
                         ,@(if port (list `(world:current-server-port ,port)) null))
            (start-server)))))
 
+
+(define (handle-clone directory target)
+  (define target-path (or (and target (path->complete-path (string->path target)))
+                          (build-path (find-system-path 'desk-dir) (string->path "clone"))))
+  
+  `(begin
+     (displayln "Clone & prune ...")
+     (require racket/file pollen/file)
+     
+     (define (pollen-related-file? file)
+       (ormap (λ(proc) (proc file)) (list
+                                     preproc-source? 
+                                     markup-source?
+                                     markdown-source?
+                                     template-source?
+                                     pagetree-source?
+                                     scribble-source?
+                                     null-source?
+                                     racket-source?
+                                     magic-directory?)))
+     (define (delete-it path)
+       (when (directory-exists? path)
+         (delete-directory/files path))
+       (when (file-exists? path)
+         (delete-file path)))
+     
+     (let ([source-dir ,directory]
+           [target-dir ,target-path])
+       (when (directory-exists? target-dir)
+         (delete-directory/files target-dir))
+       (copy-directory/files source-dir target-dir)
+       (map delete-it (find-files pollen-related-file? target-dir))
+       (displayln (format "Completed to ~a" ,target-path))
+       )))
+
 (define (handle-else command)
   `(if (regexp-match #rx"(shit|fuck)" ,command)
        (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")])
diff --git a/file.rkt b/file.rkt
index 02a22cf..cc67643 100644
--- a/file.rkt
+++ b/file.rkt
@@ -111,8 +111,15 @@
   (coerce/symbol? . -> . (listof complete-path?))
   (map ->complete-path (filter (λ(i) (has-ext? i ext)) (directory-list (world:current-project-root)))))
 
+(define+provide (racket-source? x)
+  (->boolean (and (pathish? x) (has-ext? (->path x) 'rkt))))
+
 
 ;; to identify unsaved sources in DrRacket
 (define (unsaved-source? path-string)
   ((substring (->string path-string) 0 7) . equal? . "unsaved"))
 
+(define+provide (magic-directory? path)
+  (and (directory-exists? path) 
+       (or (ends-with? (path->string path) "compiled")
+           )))
\ No newline at end of file
diff --git a/raco.rkt b/raco.rkt
index 53ac619..7d47b84 100644
--- a/raco.rkt
+++ b/raco.rkt
@@ -11,7 +11,7 @@
   (with-handlers ([exn:fail? (λ(exn) (current-directory))])
     (path->complete-path (simplify-path (string->path (vector-ref args 1))))))
 
-(define-for-syntax arg-server-port
+(define-for-syntax second-arg
   (with-handlers ([exn:fail? (λ(exn) #f)])
     (string->number (vector-ref args 2))))
 
@@ -24,8 +24,9 @@
   (datum->syntax stx 
                  (case arg-command-name
                    [(#f "help") (handle-help)]
-                   [("start") (handle-start first-arg-or-current-dir arg-server-port)]
+                   [("start") (handle-start first-arg-or-current-dir second-arg)]
                    [("render") (handle-render first-arg-or-current-dir)]
+                   [("clone") (handle-clone first-arg-or-current-dir second-arg)]
                    [else (handle-else arg-command-name)])))
 
 (select-syntax-for-command)