capybara/compiler.rkt

#lang racket/base

;; compiler:
;; infrastructure for incrementally compiling site contents from source to html/json/etc
;; lots of graphs (it's all graphs)

(require racket/bool racket/file racket/match racket/set
         syntax/parse/define (for-syntax racket/base racket/syntax))

(provide define-rule define-rule* rule-name rule-inputs rule-output
         generate-operations execute-rule execute-operations generate/execute)

;; A compiler rule
;; Input files, output file, compile function
(struct rule [name inputs output compiler] #:transparent)

;; cool and good macro for defining rules
;; binds a rule struct with a list of the given output and input files and a lambda that accepts
;; port arguments in the same order
(define-syntax-parse-rule (define-rule (id:id [outfile:id outpath:expr] [infile:id inpath:expr] ...)
                                       body:expr ...+)
  #:with name-sym #'(quote id)
  (define id (rule name-sym (list inpath ...) outpath
                   (lambda (outfile infile ...)
                     body ...))))

(define-syntax-parse-rule (define-rule* (id:id [outfile:id outpath:expr] [infiles:id inpaths:expr])
                                       body:expr ...+)
  #:with name-sym #'(quote id)
  (define id (rule name-sym inpaths outpath
                   (lambda (outfile . infiles)
                     body ...))))

;; Converts set of rules into ordered list of rules to execute based on current filesystem state
(define (generate-operations rules)
  (define nodes (mutable-set))
  (define edges (make-hash))
  (define edges-rev (make-hash))
  (define (edge-add! from to)
    (when (equal? from to)
      (error "loop edge" from to))
    (set-add! nodes from)
    (set-add! nodes to)
    (if (hash-has-key? edges from)
      (set-add! (hash-ref edges from) to)
      (hash-set! edges from (mutable-set to)))
    (if (hash-has-key? edges-rev to)
      (set-add! (hash-ref edges-rev to) from)
      (hash-set! edges-rev to (mutable-set from))))

  ;; construct graph
  (for ([rule (in-set rules)])
    (for ([input (in-list (rule-inputs rule))])
      (edge-add! input rule))
    (when (hash-has-key? edges-rev (rule-output rule))
      (error "duplicate output rule" (rule-output rule)))
    (edge-add! rule (rule-output rule)))

  ;; construct topological sort
  (define (topo-sort nodes edges)
    (define temp-mark (mutable-set))
    (define perm-mark (mutable-set))
    ;; visits recursively
    (define (visit node sorted)
      (cond
        [(set-member? perm-mark node) sorted]
        [(set-member? temp-mark node) (error "cycle detected")]
        [else
          (set-add! temp-mark node)

          (define new-sorted
            (for/fold ([s sorted]) ([neighbor (in-set (hash-ref edges node (set)))])
              (visit neighbor s)))

          (set-remove! temp-mark node)
          (set-add! perm-mark node)
          (cons node new-sorted)]))

    (for/fold ([s '()]) ([node (in-set nodes)] #:unless (set-member? perm-mark node))
      (visit node s)))

  (define topo-sorted (topo-sort nodes edges))

  ;; everything where either the output does not exist, or one of the inputs does not exist, or one
  ;; of the inputs is newer than the output
  (define (rule-dirty? rule)
    (define (modt f)
      (file-or-directory-modify-seconds f #f (λ () #f)))
    (define output-time (modt (rule-output rule)))
    (define input-times (map modt (rule-inputs rule)))
    (or (false? output-time)
        (for/or ([time (in-list input-times)])
          (or (false? time) (> time output-time)))))

  (define initial-dirty (for/set ([rule (in-set rules)] #:when (rule-dirty? rule)) rule))
  ;; propagate the dirty set recursively
  ;; for each missing input, add the rule that generates the input
  ;; if outputs have dependents, add the dependents
  (define (expand-dirty rule [dset (mutable-set)])
    (unless (set-member? dset rule)
      (set-add! dset rule)
      (for ([dep (in-set (hash-ref edges (rule-output rule) (set)))])
        (expand-dirty dep dset))
      (for ([input (in-list (rule-inputs rule))])
        (unless (or (file-exists? input) (link-exists? input) (directory-exists? input))
          (define dep-revs (hash-ref edges-rev input (set)))
          (when (zero? (set-count dep-revs))
            (error "no rule to generate" input))
          (for ([dep-rev (in-set dep-revs)])
            (expand-dirty dep-rev dset)))))
    dset)
  (define dirty
    (for/fold ([d (set)]) ([item (in-set initial-dirty)])
      (set-union d (expand-dirty item))))

  (define dirty-sorted
    (for/list ([item (in-list topo-sorted)] #:when (set-member? dirty item))
      item))
  (unless (= (set-count dirty) (length dirty-sorted))
    (error "self-check failed lmao"))
  dirty-sorted)

;; TODO : replace printf with logging

;; Executes one rule
(define (execute-rule r)
  (match-define (rule name ins out func) r)
  (printf "executing: ~a -> ~a\n" name out)
  (define cust (make-custodian))
  (parameterize ([current-custodian cust])
    (thread-wait
      (thread
        (λ ()
           (make-parent-directory* out)
           (call-with-atomic-output-file
             out
             (λ (out-port tmp-path)
                (apply func out-port (map open-input-file ins))))))))
  (custodian-shutdown-all cust))

;; Runs an ordered operations list
(define (execute-operations ops)
  (printf "~a task(s) to run\n" (length ops))
  (for ([op (in-list ops)])
    (execute-rule op)))

;; generates the list and then executes it
(define (generate/execute rules)
  (execute-operations (generate-operations rules)))