#lang scheme/base

(require (for-syntax scheme/base
                     scheme/require-transform
                     scheme/provide-transform
                     (only-in srfi/13 string-index-right)
                     "base.ss"
                     "syntax.ss")
         scheme/require-syntax
         scheme/path
         scheme/provide-syntax
         (only-in srfi/1 take-right)
         srfi/13
         "base.ss"
         "contract.ss")

; (parameter boolean)
(define debug-enabled?
  (make-parameter #t))

; string any -> void
(define (default-debug-printer message value)
  ; string
  (define value-string
    (with-pretty-indent "  "
      (pretty-format value)))
  (printf "~a:~n~a~n" message value-string))

; (parameter (string any -> void))
(define current-debug-printer
  (make-parameter default-debug-printer))

; string any -> any
;
; Prints the value of the specified expression and returns it transparently.
(define (debug message value)
  (when (debug-enabled?)
    ((current-debug-printer) message value))
  value)

; string syntax -> any
(define (debug-syntax message value)
  (debug message (syntax->datum value))
  value)

; (_ string any ...) -> any
;
; Prints the value of the specified expression and returns it transparently.
(define-syntax debug*
  (syntax-rules ()
    [(_ message proc arg ...)
     (let ([value (proc arg ...)])
       (when (debug-enabled?)
         ((current-debug-printer) message value))
       value)]))

; (_) -> void
; (_ any) -> any
(define-syntax (debug-location stx)
  (syntax-case stx ()
    [(_)
     #`(when (debug-enabled?)
         (display "Reached ")
         (display #,(syntax-location-string stx))
         (newline))]
    [(_ expr)
     #`(debug (format "Reached ~a" #,(syntax-location-string stx)) expr)]))

; (_ id value)
(define-syntax (define-debug stx)
  (syntax-case stx ()
    [(_ id val)
     #`(define id (debug (symbol->string 'id) val))]))

; (_ (id ...) value)
(define-syntax (define-values-debug stx)
  (syntax-case stx ()
    [(_ (id ...) val)
     #`(define-values (id ...) 
         (apply values (debug (format "~a" '(id ...))
                              (call-with-values (lambda () val) list))))]))

; (_ ([id value] ...) expr ...)
(define-syntax (let-debug stx)
  (syntax-case stx ()
    [(_ ([var val] ...) exp ...)
     #'(let ([var (debug (symbol->string 'var) val)] ...)
         exp ...)]))

; (_ ([id value] ...) expr ...)
(define-syntax (let*-debug stx)
  (syntax-case stx ()
    [(_ ([var val] ...) exp ...)
     #'(let* ([var (debug (symbol->string 'var) val)] ...)
         exp ...)]))

; (_ ([id value] ...) expr ...)
(define-syntax (letrec-debug stx)
  (syntax-case stx ()
    [(_ ([var val] ...) exp ...)
     #'(letrec ([var (debug (symbol->string 'var) val)] ...)
         exp ...)]))

; (_ ([(id ...) value] ...) expr ...)
(define-syntax (let-values-debug stx)
  (syntax-case stx ()
    [(_ ([(var ...) val] ...) exp ...)
     #`(let-values ([(var ...)
                     (apply values (debug (format "~a" '(var ...))
                                          (call-with-values (lambda () val) list)))]
                    ...)
         exp ...)]))

; (_ ([(id ...) value] ...) expr ...)
(define-syntax (let*-values-debug stx)
  (syntax-case stx ()
    [(_ ([(var ...) val] ...) exp ...)
     #`(let*-values ([(var ...)
                      (apply values (debug (format "~a" '(var ...))
                                           (call-with-values (lambda () val) list)))]
                     ...)
         exp ...)]))

; (_ ([(id ...) value] ...) expr ...)
(define-syntax (letrec-values-debug stx)
  (syntax-case stx ()
    [(_ ([(var ...) val] ...) exp ...)
     #`(letrec-values ([(var ...)
                      (apply values (debug (format "~a" '(var ...))
                                           (call-with-values (lambda () val) list)))]
                     ...)
         exp ...)]))

; string (-> any) -> any
(define-syntax with-pretty-indent
  (syntax-rules ()
    [(_ indent expr ...)
     (let* ([indent-string indent]
            [indent-amount (string-length indent-string)])
       (parameterize ([pretty-print-print-line 
                       (lambda (line out offset width)
                         (cond [(eq? line 0)   (display indent-string out)
                                               indent-amount]
                               [(number? line) (if (number? width)
                                                   (begin
                                                     (newline out)
                                                     (display indent-string out)
                                                     indent-amount)
                                                   (begin 
                                                     0))]
                               [else             (when (number? width)
                                                   (newline out))
                                                 0]))])
         expr ...))]))

; exn -> (listof symbol)
(define (exn-context exn)
  (map (match-lambda
         [(list-rest name srcloc)
          (string->symbol
           (if srcloc
               (format "~a:~a:~a:~a"
                       (path->short-string (srcloc-source srcloc))
                       (srcloc-line srcloc)
                       (srcloc-column srcloc)
                       (or name '??))
               (format "??:??:??:~a"
                       (or name '??))))])
       (continuation-mark-set->context (exn-continuation-marks exn))))

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

; path -> string
(define (path->short-string path)
  ; (listof (U string 'up 'same))
  (define path-elements
    (foldr (lambda (element accum)
             (cond [(path? element)     (cons (path->string element) accum)]
                   [(eq? element 'same) accum]
                   [(eq? element 'up)   (cons ".." accum)]))
           null
           (explode-path (simplify-path path))))
  ; natural
  (define num-elements
    (length path-elements))
  (string-join (take-right path-elements (min 3 num-elements)) "/"))

; Provide statements -----------------------------

(provide debug*
         debug-location
         define-debug
         define-values-debug
         let-debug
         let*-debug
         letrec-debug
         let-values-debug
         let*-values-debug
         letrec-values-debug
         with-pretty-indent)

(provide/contract
 [debug-enabled?        (parameter/c boolean?)]
 [current-debug-printer (parameter/c (-> string? any/c void?))]
 [debug                 (-> string? any/c any)]
 [debug-syntax          (-> string? syntax? any)]
 [exn-context           (-> exn? (listof symbol?))])