#lang racket

;; compiler

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