#lang scheme/unit

(require (planet untyped/unlib:3/list)
         (planet untyped/unlib:3/parameter)
         "../base.ss"
         "era-sig.ss"
         "transaction-sig.ss")

(import era^)

(export transaction^)

; Here's the idea:
;
; - Every time you start a transaction, you create a frame in which you record
;   deltas to persistent-structs.
;
; - There is a parameter called current-frame that points to the frame you are
;   currently using to store roll-back information.
;
; - When you start a sub-transaction, you create a "child" frame of the current
;   frame, and set that to be the current-frame.
;
; - Rolling back a given transaction involves rolling back its frame and any
;   child frames that haven't already been rolled back.
;
; - Even if a sub-transaction completes successfully, its parent still keeps a
;   link to its frame. If the parent is rolled back, it can roll back the child.
;
; That's about it.

; Structure types ------------------------------

; (struct frame (hashof symbol persistent-struct) boolean)
;
; The "deltas" field maps persistent structs to the old values
; of their fields.
(define-struct frame (parent [copies #:mutable] [rolled-back? #:mutable]) #:transparent)

; (parameter (U frame #f))
(define current-frame (make-parameter #f (make-guard frame? "frame")))

; (parameter boolean)
(define enable-transaction-backups?
  (make-parameter #t (make-guard boolean? "boolean")))

; Public interface -----------------------------

; -> boolean
;
; This has been replaced by the in-transaction field in the connection structure.
;(define (in-transaction?)
;  (if (current-frame)
;      #t
;      #f))

; (-> any) -> any
(define (call-with-transaction-frame thunk)
  (define frame (create-frame))
  (define complete? #f)
  (call-with-continuation-barrier
   (lambda ()
     (dynamic-wind 
      ; Entry
      void
      ; Body
      (lambda ()
        (parameterize ([current-frame frame])
          (begin0 (thunk)
                  (set! complete? #t))))
      ; Exit
      (lambda ()
        (unless complete?
          (roll-back-transaction-frame! frame)))))))

; persistent-struct -> void
(define (store-transaction-backup! struct)
  (when (enable-transaction-backups?)
    (let ([frame (current-frame)])
      (when (and frame (not (copy-stored? frame struct)))
        (hash-set! (frame-copies frame) struct (copy-persistent-struct struct))))))

; Helpers --------------------------------------

; frame -> integer
(define (frame-depth frame)
  (if (frame-parent frame)
      (add1 (frame-depth (frame-parent frame)))
      0))

; -> frame
(define (create-frame)
  (make-frame (current-frame) (make-hasheq) #f))

; frame persistent-struct -> boolean
(define (copy-stored? frame struct)
  (and (hash-ref (frame-copies frame) struct (lambda () #f)) #t))

; frame -> void
(define (roll-back-transaction-frame! frame)
  (if (frame-rolled-back? frame)
      (raise-exn exn:fail:snooze
        (format "Transaction frame already rolled back: ~s" frame))
      (let ([copies (frame-copies frame)]) ; (hashof persistent-struct persistent-struct)
        ; Mark the frame as rolled back so we don't try it again:
        (set-frame-rolled-back?! frame #t)
        ; Roll back the frame:
        (hash-for-each (frame-copies frame) update-persistent-struct-from-copy!))))