replace polcom with raco

command.rkt

@@ -1,6 +1,51 @@
 #lang racket/base
 (require (for-syntax racket/base))
 
+;; Handle commands from raco
+
+;; arg 0 will be the command name
+(define-for-syntax args (current-command-line-arguments))
+(define-for-syntax arg-command-name (with-handlers ([exn:fail? (λ(exn) #f)]) 
+                                      (vector-ref args 0)))
+
+(define-for-syntax arg-project-directory
+  (if (> (vector-length args) 1)
+      (with-handlers ([exn:fail? (λ(exn) #f)])
+        (let ([possible-path (path->complete-path (simplify-path (string->path (vector-ref args 1))))])
+          possible-path))
+      (current-directory)))
+
+(define-for-syntax (command-error error-string)
+  `(displayln (string-append "Error: ", error-string)))
+
+(define-syntax (just-a-hook-for-the-macro stx)
+  (if arg-command-name
+      (datum->syntax stx 
+                     (case arg-command-name
+                       [("nothing") '(begin)]
+                       [("test") `(displayln "All systems go")]
+                       [("start")
+                        (if (not (directory-exists? arg-project-directory))
+                            (command-error (format "~a is not a directory" arg-project-directory))
+                            `(begin 
+                               (require pollen/server pollen/world)
+                               (parameterize ([world:current-project-root ,arg-project-directory])
+                                 (start-server))))]
+                       [else (if (regexp-match #rx"(shit|fuck)" arg-command-name)
+                                 (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")])
+                                              (list-ref responses (random (length responses)))))
+                                 (command-error (format "unknown command ~a" arg-command-name)))]))
+      #'(begin)))
+
+(just-a-hook-for-the-macro)
+
+
+
+#|
+
+#lang racket/base
+(require (for-syntax racket/base))
+
 ;; todo: add command to check validity of installation
 
 (require (for-syntax sugar "world.rkt"))
@@ -66,3 +111,4 @@ polcom [filename] (renders individual file)")]
 
 (handle-pollen-command)
 
+|#

info.rkt

@@ -1,4 +1,5 @@
 #lang info
 (define collection "pollen")
 (define scribblings '(("scribblings/pollen.scrbl" ())))
-(define deps '("txexpr" "sugar"))
+(define deps '("txexpr" "sugar"))
+(define raco-commands '(("pollen" pollen/command "issue Pollen command" #f)))

server.rkt

@@ -7,33 +7,37 @@
          "file-tools.rkt"
          "cache.rkt")
 
-(define-values (pollen-servlet _)
-  (dispatch-rules
-   [((string-arg) ... (? ptree-source?)) route-dashboard]
-   [((string-arg) ... "in" (string-arg)) route-in]
-   [((string-arg) ... "out" (string-arg)) route-out]
-   [((string-arg) ... "xexpr" (string-arg)) route-xexpr]
-   [else route-default]))
+(provide start-server)
 
-(message (format "Welcome to Pollen ~a" world:pollen-version) (format "(Racket ~a)" (version)))
-(message (format "Project root is ~a" (world:current-project-root)))
-
-(define server-name (format "http://localhost:~a" world:server-port))
-(message (format "Project server is ~a" server-name) "(Ctrl-C to exit)")
-(message (format "Project dashboard is ~a/~a" server-name world:dashboard-name))
-
-(message "Ready to rock")
-
-(world:current-module-root (apply build-path (drop-right (explode-path (current-contract-region)) 1)))
-(world:current-server-extras-path (build-path (world:current-module-root) "server-extras"))
-
-(parameterize ([world:current-module-root (world:current-module-root)]
-               [world:current-server-extras-path (world:current-server-extras-path)]
-               [current-cache (make-cache)])
-  (serve/servlet pollen-servlet
-                 #:port world:server-port
-                 #:listen-ip #f
-                 #:servlet-regexp #rx"" ; respond to top level
-                 #:command-line? #t
-                 #:file-not-found-responder route-404
-                 #:extra-files-paths (list (world:current-server-extras-path) (world:current-project-root))))
+(define (start-server)
+  
+  (define-values (pollen-servlet _)
+    (dispatch-rules
+     [((string-arg) ... (? ptree-source?)) route-dashboard]
+     [((string-arg) ... "in" (string-arg)) route-in]
+     [((string-arg) ... "out" (string-arg)) route-out]
+     [((string-arg) ... "xexpr" (string-arg)) route-xexpr]
+     [else route-default]))
+  
+  (message (format "Welcome to Pollen ~a" world:pollen-version) (format "(Racket ~a)" (version)))
+  (message (format "Project root is ~a" (world:current-project-root)))
+  
+  (define server-name (format "http://localhost:~a" world:server-port))
+  (message (format "Project server is ~a" server-name) "(Ctrl-C to exit)")
+  (message (format "Project dashboard is ~a/~a" server-name world:dashboard-name))
+  
+  (message "Ready to rock")
+  
+  (world:current-module-root (apply build-path (drop-right (explode-path (current-contract-region)) 1)))
+  (world:current-server-extras-path (build-path (world:current-module-root) "server-extras"))
+  
+  (parameterize ([world:current-module-root (world:current-module-root)]
+                 [world:current-server-extras-path (world:current-server-extras-path)]
+                 [current-cache (make-cache)])
+    (serve/servlet pollen-servlet
+                   #:port world:server-port
+                   #:listen-ip #f
+                   #:servlet-regexp #rx"" ; respond to top level
+                   #:command-line? #t
+                   #:file-not-found-responder route-404
+                   #:extra-files-paths (list (world:current-server-extras-path) (world:current-project-root)))))