remember.rkt

#lang racket

(provide
 (contract-out
  [remember/c (-> (-> any/c any/c) chaperone-contract?)]))

(require meta)
(module+ test (require rackunit))

(define (remember/c convert)
  (define convert-name (object-name convert))
  (define (first-order x)
    (if (meta-has-key? x ctc)
        (meta-ref x ctc)
        (convert x)))
  (define ctc
    (make-chaperone-contract
     #:name `(remember/c ,convert-name)
     #:first-order first-order
     #:late-neg-projection
     (λ (blm)
       (λ (val neg)
         (define result (first-order val))
         (unless result
           (raise-blame-error
            #:missing-party neg
            blm val
            '(expected: "~a" given: "~e")
            convert-name val))
         (if (meta? val)
             (meta-set val ctc result)
             val)))))
  ctc)

(module+ test
  ;; crank N up to 10000000 and `remember/c` starts to make a difference
  (define N 10)
  (define data (append (range N) '(0)))

  (define last-zero/c
    (and list? (remember/c (λ (x) (zero? (last x))))))

  (define/contract (f x)
    (-> last-zero/c any)
    (g x))

  (define/contract (g x)
    (-> last-zero/c any)
    42)

  (check-eq? (f data) 42)

  (define (last-fast x)
    (if (meta-ref x last-zero/c #f) 0 (last x)))

  (define/contract (h x)
    (-> last-zero/c any)
    (last-fast x))

  (check-eq? (h data) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide
 (contract-out
  [remember-canonicalize/c
   (-> (-> any/c any/c) (values chaperone-contract? (-> any/c any/c)))]))

(define (remember-canonicalize/c convert)
  (define ctc (remember/c convert))
  (define (convert* x)
    (if (meta-has-key? x ctc)
        (meta-ref x ctc)
        (convert x)))
  (values ctc convert*))

(module+ test
  (define (tree->num-list x)
    (let/ec return
      (let go ([x x])
        (cond
          [(number? x) (list x)]
          [(list? x) (append-map go x)]
          [else (return #f)]))))

  (define-values (tree->num-list/c fast-tree->num-list)
    (remember-canonicalize/c tree->num-list))

  (define/contract (a x)
    (-> tree->num-list/c any)
    (apply + (fast-tree->num-list x)))

  (check-eq? (a '(1 2 3)) 6))