(module marks mzscheme

  (require (lib "list.ss")
	   (lib "contract.ss")
           "my-macros.ss"
           "shared.ss")

  (define-struct full-mark-struct (source label bindings values))

  ; CONTRACTS
  (define mark? (-> ; no args  
                 full-mark-struct?))
  (define mark-list? (listof procedure?))
  
  (provide/contract 
   ;[make-debug-info (-> any/c binding-set? varref-set? any/c boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
   [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
   [make-top-level-mark (syntax? . -> . syntax?)]
   [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
   [lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)]
   [lookup-binding (mark-list? identifier? . -> . any)])
  
  (provide
   make-debug-info
   wcm-wrap
   skipto-mark?
   skipto-mark
   strip-skiptos
   mark-list?
   mark-source
   mark-bindings
   mark-label
   mark-binding-value
   mark-binding-binding
   display-mark
   all-bindings
   #;lookup-binding-list
   debug-key
   extract-mark-list
   (struct normal-breakpoint-info (mark-list kind))
   (struct error-breakpoint-info (message))
   (struct breakpoint-halt ())
   (struct expression-finished (returned-value-list)))
  
  ; BREAKPOINT STRUCTURES
  
  (define-struct normal-breakpoint-info (mark-list kind))
  (define-struct error-breakpoint-info (message))
  (define-struct breakpoint-halt ())
  (define-struct expression-finished (returned-value-list))
  
  (define-struct skipto-mark-struct ())
  (define skipto-mark? skipto-mark-struct?)
  (define skipto-mark (make-skipto-mark-struct))
  (define (strip-skiptos mark-list)
    (filter (lx (not (skipto-mark? _))) mark-list))
  
    
  ; debug-key: this key will be used as a key for the continuation marks.
  (define-struct debug-key-struct ())
  (define debug-key (make-debug-key-struct))
  
  (define (extract-mark-list mark-set)
    (strip-skiptos (continuation-mark-set->list mark-set debug-key)))
   
  
  ; the 'varargs' creator is used to avoid an extra cons cell in every mark:
  (define (make-make-full-mark-varargs source label bindings)
    (lambda values 
      (make-full-mark-struct source label bindings values)))
  
  ; see module top for type
  (define (make-full-mark location label bindings)
    (datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings)
                                              ,@(map make-mark-binding-stx bindings)))))
  
  (define (mark-source mark)
    (full-mark-struct-source (mark)))
    
  ; : identifier -> identifier
  (define (make-mark-binding-stx id)
    #`(lambda () #,(syntax-property id 'stepper-dont-check-for-function #t)))
  
  (define (mark-bindings mark)
    (map list 
         (full-mark-struct-bindings (mark)) 
         (full-mark-struct-values (mark))))
  
  (define (mark-label mark)
    (full-mark-struct-label (mark)))
  
  (define (mark-binding-value mark-binding)
    ((cadr mark-binding)))
  
  (define (mark-binding-binding mark-binding)
    (car mark-binding))

  (define (expose-mark mark)
    (let ([source (mark-source mark)]
          [label (mark-label mark)]
          [bindings (mark-bindings mark)])
      (list source
            label
            (map (lambda (binding)
                   (list (mark-binding-binding binding)
                         (mark-binding-value binding)))
                 bindings))))
  
  (define (display-mark mark)
    (apply
     string-append
     (format "source: ~a~n" (syntax-object->datum (mark-source mark)))
     (format "label: ~a~n" (mark-label mark))
     (format "bindings:~n")
     (map (lambda (binding)
                 (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding))
                         (mark-binding-value binding)))
               (mark-bindings mark))))
  
  
  ; possible optimization: rig the mark-maker to guarantee statically that a
  ; variable can occur at most once in a mark.  
  
  (define (binding-matches matcher mark)
    (filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
  
  (define (lookup-all-bindings matcher mark-list)
    (apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
  
  (define (lookup-first-binding matcher mark-list fail-thunk)
    (let ([all-bindings (lookup-all-bindings matcher mark-list)])
      (if (null? all-bindings)
          (fail-thunk)
          (car all-bindings))))
  
  (define (lookup-binding mark-list id)
    (mark-binding-value
     (lookup-first-binding (lambda (id2) (module-identifier=? id id2)) 
                           mark-list 
                           (lambda ()
                             (error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) 
                                                                                                  (syntax-object->datum id)
                                                                                                  id))))))
  
  (define (all-bindings mark)
    (map mark-binding-binding (mark-bindings mark)))
  
  (define (wcm-wrap debug-info expr)
    #`(with-continuation-mark #,debug-key #,debug-info #,expr))

  
  ; DEBUG-INFO STRUCTURES
  
  ;;;;;;;;;;
  ;;
  ;; make-debug-info builds the thunk which will be the mark at runtime.  It contains 
  ;; a source expression and a set of binding/value pairs.
  ;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info)
  ;;
  ;;;;;;;;;;
     
  (define (make-debug-info source tail-bound free-vars label lifting?)
       (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
         (if lifting?
             (let*-2vals ([let-bindings (filter (lambda (var) 
                                                  (case (syntax-property var 'stepper-binding-type)
                                                    ((let-bound macro-bound) #t)
                                                    ((lambda-bound stepper-temp non-lexical) #f)
                                                    (else (error 'make-debug-info 
                                                                 "varref ~a's binding-type info was not recognized: ~a"
                                                                 (syntax-e var)
                                                                 (syntax-property var 'stepper-binding-type)))))
                                                kept-vars)]
                          [lifter-syms (map get-lifted-var let-bindings)])
               (make-full-mark source label (append kept-vars lifter-syms)))
             (make-full-mark source label kept-vars))))
  
  
  (define (make-top-level-mark source-expr)
    (make-full-mark source-expr 'top-level null)))