120 lines
4.1 KiB
Racket
120 lines
4.1 KiB
Racket
#lang racket
|
|
|
|
;; compiler:
|
|
;; infrastructure for incrementally compiling blog contents from source to html/json/etc
|
|
;; lots of graphs (it's all graphs)
|
|
|
|
(provide (struct-out rule)
|
|
generate-operations
|
|
execute-rule)
|
|
|
|
;; A compiler rule
|
|
;; Input files, output file, compile function
|
|
(struct rule [inputs output compiler] #:transparent)
|
|
|
|
;; 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 (lambda () #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)
|
|
|
|
;; Executes one rule
|
|
(define (execute-rule r)
|
|
(match-define (rule in out func) r)
|
|
(define cust (make-custodian))
|
|
(parameterize ([current-custodian cust])
|
|
(thread-wait
|
|
(thread
|
|
(lambda ()
|
|
(call-with-atomic-output-file
|
|
out
|
|
(lambda (out-port tmp-path)
|
|
(func
|
|
(for/hash ([fn (in-list in)])
|
|
(values fn (open-input-file fn)))
|
|
out-port)))))))
|
|
(custodian-shutdown-all cust))
|