dig.rkt

#lang racket/base

(require racket/contract)

(define shovel/c
  (-> any/c (subprogram/c artifact?)))

(provide
 (contract-out
  [install-found-artifact
   (->* (any/c
         path-string?)
        (shovel/c)
        (subprogram/c (cons/c path-record? path-record?)))]
  [find-artifact
   (->* (any/c)
        (shovel/c)
        (subprogram/c artifact?))]
  [shovel/c
   chaperone-contract?]
  [broken-shovel
   shovel/c]
  [dig-failure
   (-> (or/c symbol? string?)
       any/c
       subprogram?)]
  [current-shovel
   (parameter/c shovel/c)]
  [shovel-cons
   (-> shovel/c shovel/c shovel/c)]
  [shovel-list
   (->* () #:rest (listof shovel/c) shovel/c)]))


(require "artifact.rkt"
         "monad.rkt"
         "setting.rkt"
         "state.rkt"
         "subprogram.rkt"
         "message.rkt"
         "query.rkt")


(define+provide-message $dig ())
(define+provide-message $dig:no-artifact $dig (shovel-name hint))

(define+provide-setting DENXI_INSTALL_ARTIFACTS
  (listof (list/c string? string?)) null)


(define (dig-failure name hint)
  (subprogram-failure ($dig:no-artifact name hint)))

(define (broken-shovel v)
  (dig-failure (object-name broken-shovel) v))


(define ((shovel-cons a b) k)
  (subprogram (λ (m)
                (define-values (r m*) (run-subprogram (a k) m))
                (if (artifact? r)
                    (values r m*)
                    (run-subprogram (b k) m*)))))


(define (shovel-list . xs)
  (if (null? xs)
      broken-shovel
      (shovel-cons
       (car xs)
       (apply shovel-list
              (cdr xs)))))


(define current-shovel
  (make-parameter broken-shovel))


(define (install-found-artifact plinth link-path [dig (current-shovel)])
  (mdo arti := (find-artifact plinth dig)
       records := (install-artifact arti link-path)
       (subprogram-unit records)))


(define-subprogram (find-artifact plinth [dig (current-shovel)])
  (if (artifact? plinth)
      ($use plinth)
      ($run! (dig plinth))))


(module+ test
  (require rackunit
           (submod "subprogram.rkt" test))

  (test-case "Combine shovels"
    (define ((bind-shovel v) k)
      (if (eq? k v)
          (subprogram-unit (make-artifact v))
          (dig-failure v k)))

    (define shovel
      (shovel-list
       (bind-shovel #"a")
       (bind-shovel #"b")
       (bind-shovel #"c")))

    (define (check expected)
      (check-equal? (artifact-source (get-subprogram-value (shovel expected)))
                    expected))

    (check #"a")
    (check #"b")
    (check #"c")

    (define-values (should-be-failure messages)
      (run-subprogram (shovel #"d")))

    (check-eq? should-be-failure FAILURE)
    (check-equal? messages
                  (list ($dig:no-artifact 'broken-shovel #"d")
                        ($dig:no-artifact #"c" #"d")
                        ($dig:no-artifact #"b" #"d")
                        ($dig:no-artifact #"a" #"d"))))

  (test-subprogram-value
   "Trivially find provided artifact"
   (find-artifact (make-artifact #"") broken-shovel)
   (λ (result)
     (check-equal? (artifact-source result) #"")))

  (test-subprogram
   "Do not find an artifact by default when none is available"
   (find-artifact #f)
   (λ (result messages)
     (check-equal? result FAILURE)
     (check-equal? messages
                   (list ($dig:no-artifact 'broken-shovel #f)))))

  (test-case "Find an artifact using the right shovel"
    (define (indy req)
      (subprogram-unit
       (make-artifact
        (if req #"t" #"f"))))

    (define (check v expected)
      (check-subprogram-value
       (find-artifact v indy)
       (λ (result)
         (check-equal? (artifact-source result) expected))))

    (check #t #"t")
    (check #f #"f")))