(module engine mzscheme
  (require "base-gm.ss")

  (define (make-location file fn-name offset) (vector file fn-name offset))
  (define (location-file loc) (vector-ref loc 0))
  (define (location-fn-name loc) (vector-ref loc 1))
  (define (location-offset loc) (vector-ref loc 2))

  (define (make-var stack-framepops static-name offset)
    (vector stack-framepops static-name offset))

  (define (var-stack-framepops var) (vector-ref var 0))
  (define (var-static-name var) (vector-ref var 1))
  (define (var-offset var) (vector-ref var 2))

  (define-struct step-request (step-size proc))
  ;; make-step-request : (int (stack -> (may step-request)) -> step-request)

  (define loc 
    (case-lambda
      ;; TODO resolve the defaults
      [(line) (make-location (false false line))]
      [(fn line) (make-location (false fn line))]
      [(file fn line) (make-location (file fn line))]))

  (define-syntax (todo stx) #'(assert false))

  (define (behavior? v) todo)
  (define (send-event r v) todo)



  ;; Breakpoints can be:
  ;;
  ;; implemented or not : Implemented breakpoints were poked into the binary.
  ;;
  ;; enable or disabled : Disabled breakpoint are skipped silently.
  ;;
  ;; garbage or not : Garbage breakpoints need to be removed from the binary.
  ;;
  ;; new watch break : This is a watch breakpoint that has never ran before.
  ;;                      Its event-body is a proc which will instanciate the behaviors 
  ;;                      when called. The behaviors field is false.
  ;;
  ;; old watch break : This watch breakpoint has run once, its event-body is now 'false',
  ;;                      and its behaviors field contains the behaviors.

  ;; ===============================================================================
  ;; ===============================================================================
  ;; =============== THE INTERFACES THE SATELLITE MODULES ==========================

  ;; ---- Process control satellite :

  ;; The process control should modify the intruction at addr so the the next run
  ;; to reach this addr will stop with a break event (see pc:run).  Calls to
  ;; pc:implement are stackable, namely, after x calls to pc:implement at the same
  ;; address, it will take x calls to pc:unimplement to remove the implementation.
  (define (pc:implement addr) todo) ;; (int -> void)

  ;; Undoes one application of pc:implement at addr.
  (define (pc:unimplement addr) todo) ;; (int -> void)

  ;; Return true if addr has been modified by pc:implement.
  (define (pc:implemented? addr) todo) ;; (int -> bool)

  ;; A stack is (list addr:int)

  ;; Returns the current stack of a paused program.
  (define (pc:current-stack) todo) ;; (void -> stack)
  
  ;; Start the target program, or restarts it if it was paused. Calls to pc:run
  ;; block while the execution continues, until one of the six possible events
  ;; occur. At that point, pc:run returns the event. pc:run never return the
  ;; 'stepdone event.
  (define (pc:run) todo) ;; (void -> (values stack 
                         ;;                  (either (tuple 'break) (tuple 'exit) 
                         ;;                          (tuple 'stepdone) (tuple 'interupted)
                         ;;                          (tuple 'signal int)
                         ;;                          (tuple 'preload string)
                         ;;                          (tuple 'postload string))))

  ;; Tries to step the program by one instruction. If the step is successful,
  ;; pc:step returns the 'stepdone event. However, any other event might happend
  ;; before the step is completed, in which case pc:step returns that event and
  ;; leaves the steping incomplete.
  (define (pc:step) todo) ;; type is the same as pc:run

  ;; pc:interrupt can only be call while a thread is blocked on either pc:run or
  ;; pc:step. pc:interrupt will aborded the pc:run or pc:step operation and for
  ;; that call the return with the 'interrupted event.
  ;;
  ;; It is possible that process control receives an interrupt even while the
  ;; program is paused. There is a synchronization issue, whereby the two messages
  ;; (said 'interupt and 'break) might cross each other on the wire, and the
  ;; 'interupt arrives after process control has sent his event. For that reason,
  ;; process control should silently ignore interupts on paused processes.
  (define (pc:interrupt) todo) ;; (void -> void)

  ;; ---- Symbol table :

  ;; Add a binary file to the content of the symbol table.
  (define (st:load-binary filename) todo) ;; (string -> void)

  ;; Returns true is filename was loaded with st:load-binary earlier.
  (define (st:loaded? filename) todo) ;; (string -> bool)

  ;; Given a name and a code address, returns the address bound to 'name' at
  ;; when the program counter is at that code address.
  (define (st:lookup-symbol scope-addr varname) todo) ;; (string -> (either false offset:int))

  ;; Given the description of a type, return its internal numbering.
  (define (st:lookup-type type-str) todo) ;; (typeid:string -> (tuple typename:string size:int))

  ;; Returns a list of all variables accessible from the given code address.
  (define (st:variables-in-scope addr) todo) ;; (int -> (list (tuple name:string offset:int)))

  ;; Given a file line, returns the code address.
  (define (st:lookup-addr loc) todo) ;; (loc -> int)

  ;; Given a code address, returns the file line.
  (define (st:lookup-source addr) todo) ;; (int -> loc)

  ;; ---- Runtime values :

  ;; Returns the current value of the variable at the given address or offset, 
  ;; with the frame point poped up 'framepops' times.
  (define (rv:eval-var framepops offset) todo) ;; (int int -> value)

  ;; ===============================================================================
  ;; ===============================================================================

  ;; =============== Wrappers around the low-level accessors :
  
  (define (stack-to-locations stack)
    (map st:lookup-source stack))

  (define (variables-in-scope-at-stack stack)
    (let ([result empty])
      (let loop ([cur stack] [framepops 0])
        (unless (empty? cur)
          (set! result
                (append result 
                        (map 
                         (lambda (name-offset) (make-var framepops
                                                    (first name-offset)
                                                    (second name-offset)))
                         (st:variables-in-scope (first cur)))))
          (loop (rest stack) (+ framepops 1))))
      result))
  
  (define (eval-var stack var)
    (assert (< (var-stack-framepops var) (length stack)))

    (let ([offset 
           (st:lookup-symbol
            (list-ref stack (var-stack-framepops var))
            (var-static-name var))])
      (assert offset)
      (rv:eval-var (var-stack-framepops var) offset)))

  (define (get-current-stack) 
    (stack-to-locations (pc:current-stack)))

  (define (implement brk loc)
    (assert (not (breakpoint-impl? brk loc)))
    (hash-put! (breakpoint-implemented-locs brk) loc true)
    (pc:implement (st:lookup-addr loc)))
  
  (define (unimplement brk loc) 
    (assert (breakpoint-impl? brk loc))
    (hash-remove! (breakpoint-implemented-locs brk) loc)
    (pc:unimplement (st:lookup-addr loc)))
  
  ;; =============== The Engine : 

  (define loc2breakpoints (make-hash 'equal 'weak)) ;; (hash-equal location -> (list breakpoint))
  (define var2receivers (make-hash 'equal 'weak)) ;; (hash-set symbol -> receiver) ;; TODO
  (define all-break-onloads (make-hash 'weak)) ;; (hash-set (stack filename -> (may step-request)))
  (define all-break-onsignals (make-hash 'weak)) ;; (hash-set (stack signal:int -> (may step-request)))

  (define-struct breakpoint (locs implemented-locs enabled? is-watch? behaviors event-body))
  ;; breakpoint is (struct locs:(list loc) (hash-set loc) bool (stack -> (may step-request)) (list receiver))

  (define (breakpoint-impl? brk loc) 
    (hash-mem? (breakpoint-implemented-locs brk) loc))

  (define breakpoint-will-executor (make-will-executor))
  
  (define (create-breakpoint locs is-watch? event-body)
    (let* ([result (make-breakpoint locs (make-hash 'equal) true is-watch? false event-body)])
      
      (will-register breakpoint-will-executor result breakpoint-delete)
      (for-each
       (lambda (loc)
         (when (st:loaded? (location-file loc))
           (implement result loc))
         (hash-put! loc2breakpoints loc
                    (cons result (hash-get loc2breakpoints loc (lambda () empty)))))
       locs)
      result))

  (define (breakpoint-delete brk)
    (let ([locs (breakpoint-locs brk)])
      (for-each
       (lambda (loc)
         (when (breakpoint-impl? brk loc)
           (unimplement brk loc))
         (hash-put! 
          loc2breakpoints loc
          (filter (lambda (b) (not (eq? brk b)))
                  (hash-get loc2breakpoints loc)))
         (when (empty? (hash-get loc2breakpoints loc))
           (hash-remove! loc2breakpoints loc)))
       locs)	
      ;; Will-try-execute will return false when there is no will to run.
      ;; Let just make 100% sure we never return false ourself:
      true))
  
  (define (breakpoint-disable brk)
    (for-each
     (lambda (loc)
       (when (breakpoint-impl? brk loc)
         (unimplement brk loc)))
     (breakpoint-locs brk))
    (set-breakpoint-enabled?! brk false))

  (define (breakpoint-enable brk)
    (for-each
     (lambda (loc)
       (unless (or (breakpoint-impl? brk loc)
                   (not (st:loaded? (location-file loc))))
         (implement brk loc)))
     (breakpoint-locs brk))
    (set-breakpoint-enabled?! brk true))

  (define (all-breakpoints)
    (apply append (hash-values loc2breakpoints)))

  ;; TODO: who's responsible for cannonizing the filenames?
  (define (implement-breakpoints-of-file filename)
    (assert (st:loaded? filename))
    (for-each
     (lambda (brk)
       (when (breakpoint-enabled? brk)
         (for-each
          (lambda (loc) 
            (when (and (equal? (location-file loc) filename) ;; TODO: is this check useful?
                       (not (breakpoint-impl? brk loc)))
              (implement brk loc)))
          (breakpoint-locs brk))))
     (all-breakpoints)))


  (define var-ref
    (case-lambda 
      [(abs-stack name) (var-ref abs-stack 0 name)]
      [(abs-stack framepops name)
       (let ([stack (abstract-stack-data abs-stack)])
         (rv:eval-var framepops 
                      (st:lookup-symbol 
                       (list-ref stack framepops)
                       name)))]))
  
  
  (define-syntax break-event
    (syntax-rules ()
      [(_ (loc ...) (arg ...) body ...)
       (create-breakpoint 
        (list loc ...) false 
        (lambda (arg ...) (list body ...)))])) ;; TODO

  (define-syntax break-watch
    (syntax-rules ()
      [(_ (loc ...) (arg ...) body ...)
       (create-breakpoint
        (list loc ...) true
        (lambda (arg ...) (list body ...)))])) ;; TODO

  (define-syntax break-onload
    (syntax-rules ()
      [(_ (stack filename) body ...)
       (let ([result
              (create-breakpoint
               false false
               (lambda (stack filename) (list body) ...))])
         (hash-put! all-break-onloads result true)
         result)]))

  (define-syntax break-onsignal
    (syntax-rules ()
      [(_ (signal) body ...)
       (let ([result
              (create-breakpoint 
               false false
               (lambda (signal) (list body) ...))])
         (hash-put! all-break-onsignals result true)
         result)]))


  (define (collect-step-requests lst-of-lst)
    (filter step-request? (apply append lst-of-lst)))

  (define-struct abstract-stack (data))

  (define (run-breakpoints stack) 
    (let ([breakpoints (hash-get loc2breakpoints (first stack) (lambda () empty))])
      (collect-step-requests
       (map
        (lambda (brk)
          (cond [(not (breakpoint-enabled? brk)) false]
                     
                [(not (breakpoint-is-watch? brk))
                 ((breakpoint-event-body brk) (make-abstract-stack stack))]

                [(breakpoint-event-body brk)
                 (set-breakpoint-behaviors!
                  brk
                  (filter 
                   behavior?
                   ((breakpoint-event-body brk) 
                    (make-abstract-stack stack))))
                 false]))
        breakpoints))))
  
  (define (run-break-onloads stack filename) 
    (collect-step-requests
     (map
      (lambda (onload) (onload (make-abstract-stack stack) filename))
      (hash-keys all-break-onloads))))
  
  (define (run-break-onsignals stack signal)
    (collect-step-requests
     (map 
      (lambda (onsignal) (onsignal (make-abstract-stack stack) signal))
      (hash-keys all-break-onsignals))))

  (define (run-onsteps stack step-requests) 
    (collect-step-requests
     (map
      (lambda (request) ((step-request-proc request) (make-abstract-stack stack)))
      step-requests)))

  (define (run)
    (let loop ()
      (run-until-event empty)
      (loop)))

  ;; If one or many breakpoint bodies wants to step the program, finish running
  ;; all the other breakpoints, then order the step requests and execute them.
  ;;
  ;; This function returns the first event encountered, and its stack. If there 
  ;; stepping requested, the program counter was moved along since the event happend, and
  ;; and returned stack is no longer representative of the current state of the program. 
  ;; Rather, it record the stack as it was when the event happened. If you need the current 
  ;; stack, call 'get-current-stack' directly.
  ;; 
  (define (run-until-event step-requests)

    (let ([do-these-steps-then-exit
           (lambda (new-step-requests result-stack result-event)
             (unless (empty? new-step-requests)
               (run-until-event new-step-requests)
               (values result-stack result-event)))])
      
      (let ([stepping (not (empty? step-requests))])
        
        ;; Collect dead breakpoints before we have the chance to run into any of them:
        (collect-garbage)
        
        (let loop ()
          (when (will-try-execute breakpoint-will-executor)
            (loop)))
        
        ;; TODO : implement stepping with various step sizes
        
        ;; This a tad hairy. It makes sure that we can be Ctrl-C-ed without losing socket 
        ;; synchronization protocol with the process controler.
        (let-values ([(stack event) 
                      (let ([chn (make-channel)])
                        (thread 
                         (lambda ()
                           (let-values ([(stack event) (if stepping (pc:step) (pc:run))])
                             (channel-put chn (list stack event)))))
                        
                        (let ([v (with-handlers
                                     ([exn:break?
                                       (lambda (exn) (pc:interrupt) (channel-get chn))])
                                   (channel-get chn)
                                   ;; TODO : there is a small race condition right here.
                                   ;;        A exn:break could jump right after we read from the channel.
                                   ;;        I need to use semaphore-wait/enable-break
                                   )])
                          (values (first v) (second v))))])
          
          ;; Update all the watchess:
          (let* ([variables (variables-in-scope-at-stack stack)]
                 [watched-variables (filter (lambda (var) (hash-mem? var2receivers var)) variables)]
                 [receivers (map (lambda (var) (hash-get var2receivers var)) watched-variables)])
            
            (for-each
             (lambda (var receiver) (send-event receiver (eval-var stack var)))
             watched-variables receivers))
          
          ;; Then run all the events:
          (let ([event-tag (first event)])
            (cond [(eq? event-tag 'preload)
                   
                   (let ([new-step-requests (run-break-onloads stack (second event))])
                     
                     (do-these-steps-then-exit
                      (append step-requests (list new-step-requests))
                      stack event))]
                  
                  
                  [(eq? event-tag 'postload)
                   (st:load-binary (second event))
                   (implement-breakpoints-of-file (second event))
                   (do-these-steps-then-exit step-requests stack (second event))]
                  
                  
                  [(eq? event-tag 'exit) (values stack event)]
                  
                  
                  [(eq? event-tag 'signal) 
                   (run-break-onsignals stack (second event))
                   (do-these-steps-then-exit step-requests stack event)]
                  
                  
                  [(eq? event-tag 'stepdone)
                   (assert stepping)
                   (let ([new-step-requests (run-onsteps stack (first step-requests))])
                     
                     (do-these-steps-then-exit (append (rest step-requests)
                                                       (list new-step-requests))
                                               stack event))]
                  
                  [(eq? event-tag 'interupted)
                   (prompt) (values stack event)] ;; TODO : what is the Right Thing here?
                  
                  [(eq? event-tag 'break)
                   
                   (let ([new-step-requests (run-breakpoints stack)])
                     (if (not stepping)
                         ;; Everything calm and normal:
                         (do-these-steps-then-exit (append step-requests (list new-step-requests))
                                                   stack event)
                         
                         ;; Shit, we tried to single-step, but we ran into a bunch of breakpoints:
                         (begin
                           (assert (pc:implemented? (first stack)))
                           (let* ([program-counter (first stack)]
                                  [new-stack
                                   (let loop ()
                                     (if (pc:implemented? program-counter)
                                         ;; Temporarily unroll all the breakpoints here:
                                         (begin (unimplement program-counter)
                                                (begin0
                                                    (loop)
                                                  (implement program-counter)))
                                         ;; Then step over them:
                                         (let-values ([(stack event) (pc:step)])
                                           (assert (eq? (first event) 'stepdone))
                                           stack)))])
                             ;; Now run the hooks:
                             (let ([more-new-step-requests (run-onsteps new-stack (first step-requests))])
                               ;; And continue like nothing ever happened:
                               (do-these-steps-then-exit (append (rest step-requests)
                                                                 (list new-step-requests)
                                                                 (list more-new-step-requests))
                                                         stack event))))))]

                  [else (assert false)]))))))

    (define (prompt) todo)
    (define (kill) todo)
    (define (set-target) todo)

    )