add init command

fetch-util.rkt

@@ -36,9 +36,9 @@
     [(? string?) sxml]
     ['(& nbsp) "\u00a0"]
     [(list '& _) (error "unhandled &-code" sxml)]
-    [(list tag (cons '@ attrs) body ...)
+    [(list (? symbol? tag) (cons '@ attrs) body ...)
      (cons tag (cons (map sxml-attr->xexpr-attr attrs) (map sxml->xexpr body)))]
-    [(list tag body ...)
+    [(list (? symbol? tag) body ...)
      (cons tag (cons '() (map sxml->xexpr body)))]))
 
 (define (check-xexpr x)

fetch.rkt

@@ -94,7 +94,7 @@
         (define filtered (filter (λ (x) (not (eq? (first x) 'href))) attrs))
         (apply list 'a (cons (list 'href (url->string (combine-url/relative base href))) filtered)
                (map (curry transform-links base) body))])]
-    [(list tag attrs body ...)
+    [(list (? symbol? tag) attrs body ...)
      (apply list tag attrs (map (curry transform-links base) body))]
     [(? string?) xexpr]))
 

info.rkt

@@ -12,13 +12,17 @@
 ; (define compile-omit-paths '("something"))
 ; (define scribblings '(("scribblings/capybara.scrbl" ())))
 
-(define racket-launcher-names '("capybara-render"))
-(define racket-launcher-libraries '("render"))
+(define racket-launcher-names '("capybara-render" "capybara-init"))
+(define racket-launcher-libraries '("render" "init"))
 
 (define raco-commands
-  '(("capybara"
+  '(("capybara-render"
      (submod capybara/render main)
-     "run capybara"
+     "run capybara-render"
+     #f)
+    ("capybara-init"
+     (submod capybara/init main)
+     "run capybara-init"
      #f)
     ("capybara-fasl"
      (submod capybara/fasl-reader main)

init.rkt

@@ -0,0 +1,47 @@
+#lang racket/base
+
+(require racket/file racket/path racket/pretty
+         "compiler.rkt" "render.rkt" "util.rkt")
+
+(provide init-project)
+
+(define (init-project name [dir (build-path (current-directory) name)])
+  (when (directory-exists? dir)
+    (error "directory already exists!" (path->string dir)))
+  (define src (simple-form-path (build-path dir "src")))
+  (define target (simple-form-path (build-path dir "target")))
+  (make-directory* src)
+  (with-output-to-file
+    (build-path src "index.md")
+    (λ ()
+       (pretty-write
+         (list (list 'title name)
+               (list 'summary "a cool site")
+               (apply list 'date (get-date-ymd))
+               (list 'tags "tag1" "tag2")
+               (list 'lang "en")
+               (list 'authors "you")))
+       (write-string "\n# trans rights\n\nmeow")))
+  (with-output-to-file
+    (build-path src "index.scss")
+    (λ () (write-string "/* your cool SCSS goes here */")))
+  (with-output-to-file
+    (build-path src "favicon.png.rkt")
+    (λ () (write-string "#lang capybara/pict\n\n(standard-cat 128 128)")))
+  (with-output-to-file
+    (build-path src "config.rktd")
+    (λ () (pretty-write (list (list 'base (path->string target))))))
+
+  (parameterize ([current-directory dir])
+    (generate/execute (scan-for-rules)))
+
+  (void))
+
+(module+ main
+  (require racket/cmdline)
+  (command-line
+    #:program "capybara-init"
+    #:args (name)
+    (with-handlers ([exn? (λ (e) (printf "error: ~a\n" (exn-message e)))])
+      (init-project name)
+      (printf "created project ~a\n" name))))

pict.rkt

@@ -2,10 +2,11 @@
 
 (require racket/base racket/contract syntax/parse/define syntax/wrap-modbeg
          (for-syntax racket/base)
-         racket/draw pict ppict/2)
+         racket/draw pict ppict/pict ppict/tag ppict/align)
 
 (provide (rename-out [x:#%module-begin #%module-begin])
-         (except-out (all-from-out racket/base racket/contract racket/draw pict ppict/2)
+         (except-out (all-from-out racket/base racket/contract racket/draw pict
+                                   ppict/pict ppict/tag ppict/align)
                      #%module-begin))
 
 (define-syntax x:#%module-begin

render.rkt

@@ -10,6 +10,8 @@
          (prefix-in syntax: "ext-syntax/main.rkt")
          (prefix-in page: "templates/page.html.rkt"))
 
+(provide scan-for-rules)
+
 (struct input-doc [metadata xref-name text] #:transparent)
 (struct ir-doc [metadata xref-name html] #:prefab)
 
@@ -39,7 +41,7 @@
       ;; do not descend into other special tags
       [(list (or 'code 'math 'tech 'deftech 'masto 'user 'xref) attrs children ...) (list xexpr)]
       ;; recursive
-      [(list tag attrs children ...)
+      [(list (? symbol? tag) attrs children ...)
        (list (cons tag (cons attrs
                        (apply append
                               (map (lambda (child) (process+ child)) children)))))]
@@ -69,7 +71,7 @@
           (define target (substring value 1))
           `(,tag-name ([target ,target]) ,@(map extract-prefixed-links+ body))]
          [_ (apply list 'a attrs (map extract-prefixed-links+ body))])]
-      [(list tag attrs children ...)
+      [(list (? symbol? tag) attrs children ...)
        (apply list tag attrs (map extract-prefixed-links+ children))]
       [(? string? str) str]))
   (extract-prefixed-links+ xexpr))
@@ -92,7 +94,7 @@
          (error "invalid xref!" target))
        (apply list 'xref (list (list 'target (path->string abs-target)))
               (map check-xrefs-help body))]
-      [(list tag attrs body ...)
+      [(list (? symbol? tag) attrs body ...)
        (cons tag (cons attrs (map check-xrefs-help body)))]
       [(? string?) xexpr]))
   (map check-xrefs-help xexprs))
@@ -135,10 +137,10 @@
       [(list 'p _ (list 'masto _ (? string? url)))
        (masto-fetch-embed url)]
       ;; everything else
-      [(list tag attrs children ...)
+      [(list (? symbol? tag) attrs children ...)
        (apply list tag attrs (map lower-specials* children))]
       [(? string? str) str]))
-  (lower-specials* xexpr))
+  (map lower-specials* xexpr))
 
 (define (ir-doc->page doc site-config)
   (match-define (ir-doc md xref-name content) doc)
@@ -172,7 +174,7 @@
                      [in (build-path src-dir "index.scss")])
     (~> (compile-index-scss (port->string in)) (write-string out)))
 
-  (define favicon.rkt (build-path src-dir "favicon.rkt"))
+  (define favicon.rkt (build-path src-dir "favicon.png.rkt"))
   (define-rule (favicon [out (build-path output-dir "favicon.png")]
                         [in favicon.rkt])
     (define icon-pict (dynamic-require favicon.rkt 'icon-pict))

util.rkt

@@ -1,8 +1,12 @@
 #lang racket/base
 
-(require racket/format racket/string racket/port)
+(require racket/date racket/format racket/string racket/port)
 
-(provide ~r/pad run-external)
+(provide ~r/pad run-external get-date-ymd)
+
+(define (get-date-ymd)
+  (define date (current-date))
+  (list (date-year date) (date-month date) (date-day date)))
 
 (define (~r/pad num pad-to)
   (~r num #:min-width pad-to #:pad-string "0"))