Commits

Anonymous committed 2292f44

Targets

  • Participants
  • Parent commits 5c67b65
  • Branches target-based

Comments (0)

Files changed (1)

File ate-impl.scm

 (import chicken scheme)
-(use files posix extras matchable sxml-transforms lowdown)
+(use files srfi-1 sxml-transforms lowdown clojurian-syntax matchable)
 
-
-(define pages
-  (make-parameter '()))
-
-(define page-part-readers
+(define page-readers
   (make-parameter
    `(("md" . ,markdown->sxml))))
 
-(define-record page
-  type ; a symbol denoting this file's type (static, dynamic or directory)
-  source-path        ; path to the source file
-  path               ; pretty path
-  attrs              ; attributes as passed to define-page
-  parts)             ; some representation of the different page parts
-
-(define-record-printer (page page out)
-  (display "#<page " out)
-  (write (page-type page) out)
-  (display " " out)
-  (write (page-path page) out)
-  (display ">" out))
-
-(define current-page-path
-  (make-parameter #f))
-
-(define (register-page! type path #!optional (attrs '()))
-  (let* ((source-path (make-pathname (current-directory) path))
-         (page (make-page type source-path path attrs '())))
-    (pages (cons page (pages)))))
-
-(define (define-page . attrs)
-  (register-page! 'dynamic (current-page-path) attrs))
-
-(define (dynamic-page-file? f)
-  (and (equal? (pathname-file f) "page")
-       (equal? (pathname-extension f) "scm")))
-
-(define (page-part-file? f)
-  (equal? (pathname-extension (pathname-file f)) "part"))
-
-(define (load-pages! root)
-  (pages '())
-  (parameterize ((current-directory root))
-    (find-files ""
-                action: (lambda (file _)
-                          (cond ((dynamic-page-file? file)
-                                 (parameterize ((current-page-path file))
-                                   (load file)))
-                                ((directory? file)
-                                 (register-page! 'directory file))
-                                ((not (page-part-file? file))
-                                 (register-page! 'static file)))
-                          (void)))))
-
-(define (page-attr page attr)
-  (let loop ((attrs (page-attrs page)))
-    (and (pair? attrs)
-         (if (eq? attr (car attrs))
-             (cadr attrs)
-             (loop (cddr attrs))))))
-
-;; Used to obtain a target path for a page part. By default it
-;; generates <page-path>/index.<ext>.
-(define make-page-path
-  (make-parameter
-   (lambda (page part)
-     (make-pathname (pathname-directory (page-path page))
-                    (if (eq? 'content part) "index" (symbol->string part))
-                    (page-attr page extension:)))))
-
-
-(define (part name)
-  (lambda (page)
-    (list
-     (cons ((make-page-path) page name)
-           (read-page-part page name)))))
-
-(define (read-page-part page #!optional (part 'content))
-  (let ((part (make-pathname "" (symbol->string part) "part"))
-        (dir  (pathname-directory (page-source-path page))))
-    (let loop ((readers (page-part-readers)))
-      (if (null? readers)
-          (error "Couldn't find page part" page part)
-          (let ((file (make-pathname dir part (caar readers))))
-            (if (file-exists? file)
-                (with-input-from-file file (cdar readers))
-                (loop (cdr readers))))))))
-
-;; The default page rendering function. A page rendering function must
-;; return a list of pairs with the car being the target path and the
-;; cdr being the SXML HTML representation of the page. By default it
-;; renders the page's `content` part and wraps it in the `default`
-;; template and uses the current `make-page-path` function to generate
-;; its name.
-(define default-content-renderer
-  ;;(with-template (part 'content 'index) 'default)
-  (part 'content))
-
-;; (with-template (part 'content) 'default) => 
-;; (lambda (page . attrs)
-;;   (apply read-template
-;;          'default
-;;          page: page
-;;          content: ((part 'content) page)
-;;          attrs))
-
-;; Executes all renderers of a page as given in the `render:`
-;; attribute.
-(define (render-page page)
-  (let ((renderers (page-attr page render:)))
-    (when renderers
-      (append-map
-       (lambda (render)
-         (render page))
-       renderers))))
-
-(define (serialize-sxml sxml)
-  (SRV:send-reply (pre-post-order* sxml universal-conversion-rules*)))
-
-(define (compile-page page dest)
-  (let ((page-dest-path (make-pathname dest (page-path page))))
-    (case (page-type page)
-      ((directory)
-       (print "creating directory " page-dest-path)
-       (create-directory page-dest-path))
-      ((static)
-       (print "copying " (page-path page) " to " page-dest-path)
-       (file-copy (page-source-path page) page-dest-path #t))
-      ((dynamic)
-       (print "compiling dynamic page " page)
-       (for-each (match-lambda
-                  ((dest-path . content)
-                   (let ((full-dest-path (make-pathname dest dest-path)))
-                     (create-directory (pathname-directory full-dest-path) #t)
-                     (with-output-to-file full-dest-path
-                       (lambda ()
-                         (serialize-sxml content))))))
-                 (render-page page)))
-      (else (fprintf (current-error-port)
-                     "skipping page of unknown type: ~S~%"
-                     page)))))
+(define (read-page file #!optional in)
+  (let ((read (alist-ref (pathname-extension file) (page-readers) equal?)))
+    (if read
+        (if in (read in) (call-with-input-file file read))
+        (error "Couldn't find page reader for file" file))))
+
+(define (serialize-sxml sxml #!optional (out (current-output-port)))
+  (parameterize ((current-output-port out))
+    (SRV:send-reply (pre-post-order* sxml universal-conversion-rules*))))
+
+(define targets
+  (make-parameter (list)))
+
+(define (register-target! name dependencies realization)
+  (targets (alist-update! name
+                          (cons dependencies realization)
+                          (targets)
+                          equal?)))
+
+(define-syntax define-target
+  (ir-macro-transformer
+   (lambda (x i r)
+     (let ((first (cadr x)))
+       (cond ((symbol? first)
+              `(define ,first (define-target . ,(cddr x))))
+             ((string? first)
+              `(define-target (list (list . ,(cdr x)))))
+             (else
+              `(let ((targets ,first))
+                 (for-each (lambda (t)
+                             (register-target! (car t) (cadr t) (caddr t)))
+                           targets)
+                 (map car targets))))))))
+
+(define source-directory
+  (make-parameter "src"))
+
+(define (strip-source-directory path)
+  (irregex-replace `(seq bos ,(source-directory) "/") path ""))
+
+(define (target-ref target)
+  (alist-ref target (targets) equal?))
+
+(define (result-ref results)
+  (lambda (target)
+    (alist-ref target results equal?)))
 
 (define (compile-site #!key (src "src") (dest "out"))
-  (let ((dest (normalize-pathname dest))
-        (src  (normalize-pathname src)))
-    (load-pages! src)
-    (create-directory dest #t)
-    (for-each (lambda (page)
-                (compile-page page dest))
-              (reverse (pages)))))
+  (let ((dest  (normalize-pathname dest))
+        (src   (normalize-pathname src)))
+    (->> (topological-sort
+          (map (lambda (target)
+                 (cons (car target) (cadr target)))
+               (targets))
+          equal?)
+         (reverse)
+         (fold (lambda (target results)
+                 (alist-cons
+                  target
+                  (match-let (((dependencies . realize) (target-ref target)))
+                    (let ((target (make-pathname dest target)))
+                      (create-directory (pathname-directory target) #t)
+                      (realize target (map (result-ref results) dependencies))))
+                  results))
+               '()))))