Commits

Anonymous committed df43d87

put some generic stuff in target-realization

  • Participants
  • Parent commits 2292f44
  • Branches target-based

Comments (0)

Files changed (2)

File ate-impl.scm

 (import chicken scheme)
-(use files srfi-1 sxml-transforms lowdown clojurian-syntax matchable)
+(use files srfi-1 sxml-transforms lowdown clojurian-syntax matchable plan plan-parallel)
 
 (define page-readers
   (make-parameter
   (parameterize ((current-output-port out))
     (SRV:send-reply (pre-post-order* sxml universal-conversion-rules*))))
 
+(define source-directory
+  (make-parameter "src"))
+
+(define target-directory
+  (make-parameter "out"))
+
 (define targets
   (make-parameter (list)))
 
-(define (register-target! name dependencies realization)
-  (targets (alist-update! name
-                          (cons dependencies realization)
-                          (targets)
-                          equal?)))
+(define (target-realization path realize)
+  (lambda (path deps)
+    (print path)
+    (let ((target (make-pathname (target-directory) path)))
+      (create-directory (pathname-directory target) #t)
+      (cons* path: path
+             target-path: target
+             (realize target deps)))))
+
+(define (register-target! path dependencies realize)
+  (let ((step (cons dependencies (target-realization path realize))))
+    (targets (alist-update! path step (targets) equal?))))
 
 (define-syntax define-target
   (ir-macro-transformer
                            targets)
                  (map car targets))))))))
 
-(define source-directory
-  (make-parameter "src"))
-
 (define (strip-source-directory path)
   (irregex-replace `(seq bos ,(source-directory) "/") path ""))
 
   (lambda (target)
     (alist-ref target results equal?)))
 
-(define (compile-site #!key (src "src") (dest "out"))
-  (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))
-               '()))))
+(define (compile-site #!optional (target "out"))
+  (parameterize ((target-directory target))
+    (realize-plan-parallel (make-plan (targets)))))

File ideas/outputs-first/site.scm

+;; old
+;; (define-site
+;;   ("*.png" copy-files)
+;;   ("images/*" copy-files)
+;;   ("posts/*.html" (compile-page "posts/*.md"))
+;;   ("feed.atom" (require "posts/*.html") compile-feed))
+
+
+;; (define-site
+;;   ("posts/*.md" (add-class 'post))
+;;   (post read-meta))
+
+(define-syntax key
+  (syntax-rules ()
+    ((_ name default)
+     (lambda (#!key (name default)) name))
+    ((_ name)
+     (key name #f))))
+
+(define (render-page vars content out)
+  (serialize-sxml content out))
+
+(define (alist->plist alist)
+  (append-map (lambda (x)
+                (list (string->keyword (symbol->string (car x)))
+                      (cdr x)))
+              alist))
+
+(define (read-page* file)
+  (call-with-input-file file
+    (lambda (in)
+      (let ((page-vars (read in)))
+        (values page-vars (read-page file in))))))
+
+(define (hyde-page source-path #!optional (extension "html"))
+  (list (pathname-replace-extension
+         (strip-source-directory source-path)
+         extension)
+        '()
+        (lambda (target-path _)
+          (receive (page-vars content) (read-page* source-path)
+            (call-with-output-file target-path
+              (lambda (out)
+                (render-page page-vars content out)))
+            (cons* content: content
+                   source-path: source-path
+                   target-path: target-path
+                   (alist->plist page-vars))))))
+
+(define (hyde-pages pattern)
+  (map hyde-page (glob (make-pathname (source-directory) pattern))))
+
+(define (as-index path)
+  (pathname-replace-file path (make-pathname (pathname-file path) "index")))
+
+;; (define-rules foo
+;;   `(("some.html" . ,(lambda (out)
+;;                       (with-output-to-file out (cut print "check"))))))
+;; ->
+;; (delay
+;;   ((lambda (out) (with-output-to-file out (cut print "check")))
+;;    "some.html"))
+
+;; If first argument is a symbol, establish a binding of that name to
+;; be used in dependencies
+(define-target posts
+  (map (lambda (page)
+         (let ((target (car page)))
+           (cons (as-index (car page)) (cdr page))))
+       (hyde-pages "posts/*.md")))
+
+(define-target (hyde-pages "*.md"))
+
+;; (define (post->atom-entry #!key content title authors date)
+;;   (list title:   (or title (first-heading content))
+;;         date:    (make-atom-date date)
+;;         entry:   (render (first-paragraph content))
+;;         authors: (map make-atom-author authors)))
+
+;; (define-target
+;;   (atom-feed "posts.atom"
+;;              posts
+;;              (lambda (posts)
+;;                (->> posts
+;;                     (sort-by (o local-time->seconds string->time (key date)))
+;;                     (take 10)
+;;                     (map (lambda (post)
+;;                            (apply post->atom-entry post)))))))
+
+(define (post->entry post)
+  (apply (lambda (#!key title content)
+           `(entry
+             (title ,title)
+             (content ,content)))
+         post))
+
+(define-target
+  "posts.atom"                          ; target name
+  posts                                 ; dependencies
+  (lambda (target-file dependencies) ; realization (dependencies is a list of realized dependencies)
+    (with-output-to-file target-file
+      (lambda ()
+        (serialize-sxml
+         (cons 'posts (map post->entry dependencies)))))
+    '(this: is the: target return: value)))
+
+;; ;; Alternatively, if only one argument is given
+;; (define-target
+;;   '(("some-target" (deps ...) realization) ...))
+
+
+;; A realization function is called with the target as first argument
+;; and the list of realized dependencies as second argument. Targets
+;; are only realized once and their return value is what is passed on
+;; to depending targets.
+
+
+;; Gallery example
+
+
+;; (define (thumbnail-path file)
+;;   (pathname-replace-extension file "thumb.jpg"))
+
+;; (define-target images
+;;   (copy-files "*.jpg"))
+
+;; (define-target
+;;   (process-files "*.jpg"
+;;                  (lambda (image-file)
+;;                    (make-thumbnail 16 16 image-file (thumbnail-path image-file)))))
+
+;; (define-target
+;;   "index.html"
+;;   images
+;;   (lambda (target images)
+;;     (write-sxml target
+;;                 (map (lambda (image)
+;;                        (let ((path (get-key path: image)))
+;;                          `(li (a (@ (href ,path))
+;;                                  (img (@ (src ,(thumbnail-path path))))))))
+;;                      images))))
+
+;; ;; Alternatively
+;; (define-targets
+;;   (images (copy-files "*.jpg"))
+;;   (thumbnails (process-files "*.jpg"
+;;                              (lambda (img)
+;;                                (make-thumbnail 16 16 img (thumbnail-path img)))))
+;;   ("index.html"
+;;    images
+;;    (lambda (target images)
+;;      (write-sxml target
+;;                  (map (lambda (image)
+;;                         (let ((path (get-key path: image)))
+;;                           `(li (a (@ (href ,path))
+;;                                   (img (@ (src ,(thumbnail-path path))))))))
+;;                       images)))))
+
+(compile-site)