;; TODO
;; should hexdump respect # lines in describe-limit if len unset?  currently prints whole object
;; recursive describe??

;; CHANGES
;; - replaced (##core#inline "C_lambdainfop" x) with ##sys#lambda-info?
;; - final fixnum? newline writes to given output port, not stdout
;; - more compact fixnum, make char similar
;; - add dump offset, hex addresses

;; PROBLEMS
;; - describing arbitrary object may require object to understand sequence limit
;;   and possibly indent; original code ignores issue

;; EASTER EGG
;; - ,d can also be read "comedy"

(import (only csi toplevel-command))
(use extras data-structures)

(define bytevector-data
  '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)
    (s8vector "vector of signed bytes" s8vector-length s8vector-ref)
    (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)
    (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)
    (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)
    (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)
    (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)
    (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )

(define (circular-list? x)
  (let lp ((x x) (lag x))
    (and (pair? x)
	 (let ((x (cdr x)))
	   (and (pair? x)
		(let ((x   (cdr x))
		      (lag (cdr lag)))
		  (or (eq? x lag) (lp x lag))))))))

(define (improper-pairs? x)
  (let lp ((x x))
    (if (not (pair? x)) #f
       (or (eq? x (car x))
           (lp (cdr x))))))

(define describe-sequence-limit (make-parameter 40))

(define describer-table (make-vector 37 '()))

(define describe
  (let ([sprintf sprintf]
	[printf printf] 
	[fprintf fprintf]
	[length length]
	[list-ref list-ref]
	[string-ref string-ref])
    (lambda (x #!optional (out ##sys#standard-output))
      (define (descseq name plen pref start)
	(let ((len (fx- (plen x) start))
              (lim (describe-sequence-limit)))
	  (when name (fprintf out "~A of length ~S~%" name len))
	  (let loop1 ((i 0))
	    (cond ((fx>= i len))
		  ((fx>= i lim)
		   (fprintf out " (~A elements not displayed)~%" (fx- len i)) )
		  (else
		   (let ((v (pref x (fx+ start i))))
		     (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))
		       (cond ((fx>= j len)
			      (fprintf out " ~S: ~S" i v)
			      (if (fx> n 1)
				  (fprintf out "\t(followed by ~A identical instance~a)~% ...~%" 
					   (fx- n 1)
					   (if (eq? n 2) "" "s"))
				  (newline out) )
			      (loop1 (fx+ i n)) )
			     ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))
			     (else (loop2 n len)) ) ) ) ) ) ) ) )
      (when (##sys#permanent? x)
	(fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )
      (cond [(char? x)
	     (let ([code (char->integer x)])
	       (fprintf out "character ~S ~S (integer ~S #x~X #o~O)~%"
                        x (##sys#char->utf8-string x)
                        code code code) ) ]
	    [(eq? x #t) (fprintf out "boolean true~%")]
	    [(eq? x #f) (fprintf out "boolean false~%")]
	    [(null? x) (fprintf out "empty list~%")]
	    [(eof-object? x) (fprintf out "end-of-file object~%")]
	    [(eq? (##sys#void) x) (fprintf out "unspecified object~%")]
	    [(fixnum? x)
	     (fprintf out "exact integer ~S (#x~X #o~O #b~B" x x x x)
	     (let ([code (integer->char x)])
	       (when (fx< x #x10000) (fprintf out " ~S" code)) )
             (display ")")
	     (newline out) ]
	    [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
	     (fprintf out "unbound value~%") ]
	    [(flonum? x) (fprintf out "inexact number ~S~%" x)]
	    [(number? x) (fprintf out "number ~S~%" x)]
	    [(string? x) (descseq "string" ##sys#size string-ref 0)]
	    [(vector? x) (descseq "vector" ##sys#size ##sys#slot 0)]
	    ((keyword? x)
	     (fprintf out "keyword symbol with name ~s~%" 
	       (##sys#symbol->string x)))
	    [(symbol? x)
	     (unless (##sys#symbol-has-toplevel-binding? x)
	       (display "unbound " out))
	     (let ((q (##sys#qualified-symbol? x)))
	       (fprintf out "~a~asymbol with name ~S~%"
		 (if (##sys#interned-symbol? x) "" "uninterned ")
		 (if q "qualified " "")
		 (if q 
		     (##sys#symbol->qualified-string x)
		     (##sys#symbol->string x))))
	     (let ((plist (##sys#slot x 2)))
	       (unless (null? plist)
		 (display "  \nproperties:\n\n" out)
		 (do ((plist plist (cddr plist)))
		     ((null? plist))
		   (fprintf out "  ~s\t" (car plist))
		   (##sys#with-print-length-limit
		    1000
		    (lambda ()
		      (write (cadr plist) out) ) )
		   (newline out) ) ) ) ]
	    [(or (circular-list? x) (improper-pairs? x))
	     (fprintf out "circular structure: ")
	     (let loop-print ((x x)
                              (cdr-refs (list x)))
               (cond ((or (atom? x)
                          (null? x)) (printf "eol~%"))
                     ((memq (car x) cdr-refs)
                      (fprintf out "(circle)~%" ))
		     ((not (memq (car x) cdr-refs))
		      (fprintf out "~S -> " (car x))
		      (loop-print (cdr x) (cons (car x)  cdr-refs) ))))]
	    [(list? x) (descseq "list" length list-ref 0)]
	    [(pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x))]
	    [(procedure? x)
	     (let ([len (##sys#size x)])
	       (descseq 
		(sprintf "procedure with code pointer ~X" (##sys#peek-unsigned-integer x 0))
		##sys#size ##sys#slot 1) ) ]
	    [(port? x)
	     (fprintf out
		      "~A port of type ~A with name ~S and file pointer ~X~%"
		      (if (##sys#slot x 1) "input" "output")
		      (##sys#slot x 7)
		      (##sys#slot x 3)
		      (##sys#peek-unsigned-integer x 0) ) ]
	    [(##sys#locative? x)
	     (fprintf out "locative~%  pointer ~X~%  index ~A~%  type ~A~%"
		      (##sys#peek-unsigned-integer x 0)
		      (##sys#slot x 1)
		      (case (##sys#slot x 2) 
			[(0) "slot"]
			[(1) "char"]
			[(2) "u8vector"]
			[(3) "s8vector"]
			[(4) "u16vector"]
			[(5) "s16vector"]
			[(6) "u32vector"]
			[(7) "s32vector"]
			[(8) "f32vector"]
			[(9) "f64vector"] ) ) ]
	    [(##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0))]
	    [(##sys#bytevector? x)
	     (let ([len (##sys#size x)])
	       (fprintf out "blob of size ~S:~%" len)
	       (hexdump x 0 len ##sys#byte out) ) ]
	    [(##sys#lambda-info? x)
	     (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) ]
	    [(##sys#structure? x 'hash-table)
	     (let ((n (##sys#slot x 2)))
	       (fprintf out "hash-table with ~S element~a~%  comparison procedure: ~A~%"
			n (if (fx= n 1) "" "s")  (##sys#slot x 3)) 
               (fprintf out "  hash function: ~a~%" (##sys#slot x 4))
               ;; this copies code out of srfi-69.scm, but we don't want to depend on it
               (let* ((vec (##sys#slot x 1))
                      (len (##sys#size vec))
                      (lim (describe-sequence-limit))
                      (idx 0))
                 (call/cc
                  (lambda (break)
                    (do ((i 0 (fx+ i 1)))
                        ((fx>= i len))
                      (for-each (lambda (bucket)
                                  (cond ((< idx lim)
                                         (set! idx (add1 idx))
                                         (fprintf out " ~S\t-> ~S~%"
                                                  (##sys#slot bucket 0) (##sys#slot bucket 1)))
                                        (else
                                         (fprintf out "  (~S elements omitted)~%" (- n idx))
                                         (break #f))))
                                (##sys#slot vec i)))))))]
	    [(##sys#structure? x 'condition)
	     (fprintf out "condition: ~s~%" (##sys#slot x 1))
	     (for-each
	      (lambda (k)
		(fprintf out " ~s~%" k)
		(let loop ((props (##sys#slot x 2)))
		  (unless (null? props)
		    (when (eq? k (caar props))
		      (##sys#with-print-length-limit
		       100
		       (lambda ()
			 (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))
		      (newline out))
		    (loop (cddr props)) ) ) )
	      (##sys#slot x 1) ) ]
	    [(##sys#generic-structure? x)
	     (let ([st (##sys#slot x 0)])
	       (cond ((##sys#hash-table-ref describer-table st) => (cut <> x out))
		     ((assq st bytevector-data) =>
		      (lambda (data)
			(apply descseq (append (map eval (cdr data)) (list 0)))) )
		     (else
		      (fprintf out "structure of type `~S':~%" (##sys#slot x 0))
		      (descseq #f ##sys#size ##sys#slot 1) ) ) ) ]
	    [else (fprintf out "unknown object~%")] )
      (##sys#void) ) ) )

(define (set-describer! tag proc)
  (##sys#check-symbol tag 'symbol 'set-describer!)
  (##sys#hash-table-set! describer-table tag proc) )
;; todo: define-record-describer

;;; Display hexdump:

(define dump
  (lambda (x #!optional (off 0) len (out ##sys#standard-output))
      (define (bestend n) (if len (min n (+ off len)) n))
      (cond [(##sys#immediate? x) (##sys#error 'dump "cannot dump immediate object" x)]
	    [(##sys#bytevector? x) (hexdump x off (bestend (##sys#size x)) ##sys#byte out)]
	    [(string? x) (hexdump x off (bestend (##sys#size x)) ##sys#byte out)]
	    [(and (not (##sys#immediate? x)) (##sys#pointer? x))
	     (hexdump x off (+ off (or len 32)) ##sys#peek-byte out) ]
	    [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
	     (let ([bv (##sys#slot x 1)])
	       (hexdump bv off (bestend (##sys#size bv)) ##sys#byte out) ) ]
	    [else (##sys#error 'dump "cannot dump object" x)] ) ) )

(define hexdump
  (let ([display display]
        [string-append string-append]
        [make-string make-string]
        [write-char write-char] )
    (lambda (bv start end ref out)

      (define (justify n m base lead)
        (let* ([s (number->string n base)]
               [len (##sys#size s)] )
          (if (fx< len m)
              (string-append (make-string (fx- m len) lead) s)
              s) ) )
      (define (max-addr-width end base)
        (string-length (number->string (- end (fxmod end 16)) base)))

      (let ((M (max 4 (max-addr-width end 16))))
        (do ([a (- start (fxmod start 16))
                (fx+ a 16)])
            ((fx>= a end))
          (display (justify a M 16 #\0) out)
          (write-char #\: out)
          (do ([j 0 (fx+ j 1)]
               [a a (fx+ a 1)] )
              ((or (fx>= j 16) (fx>= a end))
               (when (fx>= a end)
                 (let ((o (fxmod end 16)))
                   (unless (fx= o 0)
                     (do ((k (fx- 16 o) (fx- k 1)))
                         ((fx= k 0))
                       (display "   " out) ) ) ) ) )
            (cond ((< a start)
                   (display "   " out))
                  (else
                   (write-char #\space out)
                   (display (justify (ref bv a) 2 16 #\0) out))) )
          (write-char #\space out)
          (write-char #\space out)
          (do ([j 0 (fx+ j 1)]
               [a a (fx+ a 1)] )
              ((or (fx>= j 16) (fx>= a end)))
            (if (< a start)
                (write-char #\space out)
                (let ([c (ref bv a)])
                  (if (and (fx>= c 32) (fx< c 128))
                      (write-char (integer->char c) out)
                      (write-char #\. out) ) )) ) 
          (write-char #\newline out) ))) ) )


;; tests
;; (let ((s (open-output-string))) (describe (##sys#make-lambda-info "(1 2 3)") s) (get-output-string s))
;; ;=> "lambda information: \"(1 2 3)\"\n"
;; (let ((s (open-output-string))) (describe 3 s) (get-output-string s))        ;; out of date
;; ;=> "exact integer 3\n  #x3\n  #o3\n  #b11, character #\\x3\n"
;; ,du (memory-mapped-file-pointer (map-file-to-memory #f 1000 prot/read map/shared (port->fileno (open-input-file "~/.emacs"))))
;; ,d (alist->hash-table (map (lambda (x) (cons x (+ x 1))) (iota 100)))


;;; REPL

(when (feature? 'csi)
  ;; Note -- these occur in opposite order of help text
  ;; Note -- this will erroneously execute when evaluating a script, not just in the REPL
  ;; Note -- we cannot override the built-in help text, even though we can override the commands
  (toplevel-command 'dus
                    (lambda ()
                      (let* ([e (read)]
                             [o (read)]
                             [n (read)])
                        (dump (eval e) (eval o) (eval n))))
                    ",dus EXP OFF LEN  (describe) Hexdump LEN bytes of bytevector EXP at offset OFF")
  (toplevel-command 'dur
                    (lambda ()
                      (let* ([e (read)]
                             [n (read)])
                        (dump (eval e) 0 (eval n))))
                    ",dur EXP LEN      (describe) Hexdump first LEN bytes of bytevector EXP")
  (toplevel-command 'du
                    (lambda ()
                      (let* ([e (read)])
                        (dump (eval e))))
                    ",du EXP           (describe) Hexdump contents of bytevector EXP")
  (toplevel-command 'd
                    (lambda ()
                      (let* ([e (read)])
                        (describe (eval e))))
                    ",d EXP            (describe) Describe result of evaluated EXP")

  )