capybara/compiler.rkt

150 lines
5.5 KiB
Racket

#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)))