;(library 'pp)

; File: "pp.scm"   (c) 1991, Marc Feeley

; 'generic-write' is a procedure that transforms a Scheme data value (or
; Scheme program expression) into its textual representation.  The interface
; to the procedure is sufficiently general to easily implement other useful
; formatting procedures such as pretty printing, output to a string and
; truncated output.
;
; Parameters:
;
;   OBJ       Scheme data value to transform.
;   WIDTH     Extended boolean, selects format:
;               #f = single line format
;               integer > 0 = pretty-print (value = max nb of chars per line)
;   OUTPUT    Procedure of 1 argument of string type, called repeatedly
;               with successive substrings of the textual representation.
;               This procedure can return #f to stop the transformation.
;
; The value returned by 'generic-write' is undefined.
;
; Examples:
;
;   (write obj)   = (generic-write obj #f #f display-string)
;   (display obj) = (generic-write obj #t #f display-string)
;
; where display-string = (lambda (s) (for-each write-char (string->list s)) #t)
(begin-module 'pprint-simple)
(module-export '(generic-write
                 indent-general-ref max-call-head-width-ref max-expr-width-ref
                 indent-general! max-call-head-width! max-expr-width!))

;(module-export-r/w '(dbg-print-srcinfo))
;(define dbg-print-srcinfo #f)

(define indent-general 2)
(define max-call-head-width 5)
(define max-expr-width 70)

(define (indent-general-ref) indent-general)
(define (max-call-head-width-ref) max-call-head-width)
(define (max-expr-width-ref) max-expr-width)

(define (indent-general! value) (gset! indent-general value))
(define (max-call-head-width! value) (gset! max-call-head-width value))
(define (max-expr-width! value) (gset! max-expr-width value))


(define (generic-write obj width output)
  (define (vector->list vec)
    (define res (cons #nil #nil))
    (define tail res)
    (define pos 0)
    (define end (min (vector-length vec) 128))
    (while {pos <> end}
      (set! tail (cdr-set! tail (cons (vector-ref vec pos) #nil)))
      (inc! pos))
    (if {end <> (vector-length vec)}
        (set! tail (cdr-set! tail (cons '... #nil))))
    (cdr res))

  (define (reverse-string-append l)
    (define res "")
    ;(let loop ([lst l])
    ;  (if (pair? lst)
    ;      (then (loop (cdr lst))
    ;            (set! res (strcat res (car lst))))))
    (while (pair? l)
      (set! res (strcat (car l) res))
      (set! l (cdr l)))
    res)

  (define (read-macro? l)
    (define (length1? l) (and (pair? l) (null? (cdr l))))
    (let ([head (car l)] [tail (cdr l)])
      (case head
        ([quote quasiquote unquote unquote-splicing] (length1? tail))
        (else                                        #f))))

  (define (read-macro-body l)
    (cadr l))

  (define (read-macro-prefix l)
    (let ([head (car l)] [tail (cdr l)])
      (case head
        ([quote]            "'")
        ([quasiquote]       "`")
        ([unquote]          ",")
        ([unquote-splicing] ",@"))))

  (define (out str col)
    ;(and col (output str) (+ col (length str))))
    (if (any-true? col)
        (begin (output str) (+ col (length str)))))

  (define (out-quoted-str str col)
    (out (string-quote str) col))

  ;(define (out-srcinfo srcinfo col)
  ;  ;(printf "srcinfo=%o\n" srcinfo)
  ;  (out (string-append "<" car(srcinfo) ":" (number->string (cdr srcinfo)) ">") col))

  ;(define (wr-srcinfo expr col)
  ;  (if (true? dbg-print-srcinfo)
  ;      (let ([srcinfo (::SYSTEM:srcinfo-ref expr)])
  ;          (if (any-true? srcinfo)
  ;              (out-srcinfo srcinfo col)
  ;              col))
  ;      col))

  (define (wr obj col)
    (define (wr-expr expr col)
      (if (read-macro? expr)
          (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
          (wr-lst expr col)))

    (define (wr-lst l col)
      ;;(set! col (wr-srcinfo l col))
      (if (pair? l)
        (let loop ([l (cdr l)] [col (wr (car l) (out "\x28" col))])
          ;(and col
          ;     (cond ((pair? l) (loop (cdr l) (wr (car l) (out " " col))))
          ;           ((null? l) (out "\x29" col))
          ;           (else      (out "\x29" (wr l (out " . " col)))))))
          ;(set! col (wr-srcinfo l col))
          (cond
            ([any-true? col]
              (cond
                ([pair? l] (loop (cdr l) (wr (car l) (out " " col))))
                ([null? l] (out "\x29" col))
                (else      (out "\x29" (wr l (out " . " col))))))
            (else #f)))
        (out "#nil" col)))

    (cond ([pair? obj]          (wr-expr obj col))
          ([null? obj]          (wr-lst obj col))
          ([vector? obj]        (wr-lst (vector->list obj) (out "#" col)))
          ([boolean? obj]       (out (if obj "#t" "#f") col))
          ([number? obj]        (out (number->string obj) col))
          ([symbol? obj]        (out (symbol->string obj) col))
          ([primitive? obj]
            (if (symbol? (::SYSTEM:procedure-name obj))
                (out (string-append "<|" (symbol->string (::SYSTEM:procedure-name obj)) "|>") col)
                (out "#[primitive]" col)))
          ([closure? obj]
            (if (symbol? (::SYSTEM:procedure-name obj))
                (out (string-append "<|{" (symbol->string (::SYSTEM:procedure-name obj)) "}|>") col)
                (out "#[closure]" col)))
          ([procedure? obj]
            (if (symbol? (::SYSTEM:procedure-name obj))
                (out (symbol->string (::SYSTEM:procedure-name obj)) col)
                (out "#[procedure]" col)))
          ([string? obj]        (out-quoted-str obj col))
          ([eof-object? obj]    (out "#[eof-object]" col))
          ([error-object? obj]  (out "#[error]" col))
          ([void-object? obj]   (out "#[void]" col))
          ([coroutine? obj]     (out "#[coroutine]" col))
          (else                 (out "#[unknown]" col))))

  (define (pp obj col)
    (define (spaces n col)
      (if (> n 0)
        (if (> n 7)
          (spaces (- n 8) (out "        " col))
          (out (substring "        " 0 n) col))
        col))

    (define (indent to col)
      (lax-and col
        (if (< to col)
            (then (if (and (any-true? out)
                           ;(any-true? (char->string 10))
                           (any-true? col))
                       (then (out (char->string 10) col)
                             (spaces to 0))))
            (else (spaces (- to col) col)))))

    (define (pr obj col extra pp-pair)
      (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
        (let ([result '()]
              [left (min (+ (- (- width col) extra) 1) max-expr-width)])
          (generic-write obj #f
            (lambda (str)
              (set! result (cons str result))
              (set! left (- left (length str)))
              (> left 0)))
          (if (> left 0) ; all can be printed on one line
            (out (reverse-string-append result) col)
            (if (pair? obj)
              (pp-pair obj col extra)
              (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
        (wr obj col)))

    (define (pp-expr expr col extra)
      (if (read-macro? expr)
        (pr (read-macro-body expr)
            (out (read-macro-prefix expr) col)
            extra
            pp-expr)
        (let* ([head (car expr)] [proc (style head)])
          ;(printf "head=%o; style=%o\n" head proc)
          (cond
            [(any-true? proc)
             (proc expr col extra)]
            [(symbol? head)
             (if (> (length (symbol->string head))
                    max-call-head-width)
                 (pp-general expr col extra #f #f #f pp-expr)
                 (pp-call expr col extra pp-expr))]
            [else (pp-list expr col extra pp-expr)]))))

    ; (head item1
    ;       item2
    ;       item3)
    (define (pp-call expr col extra pp-item)
      (let ([col* (wr (car expr) (out "\x28" col))])
        (lax-and col
          (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))

    ; (item1
    ;  item2
    ;  item3)
    (define (pp-list l col extra pp-item)
      (let ([col (out "\x28" col)])
        (pp-down l col col extra pp-item)))

    (define (pp-down l col1 col2 extra pp-item)
      (let loop ([l l] [col col1])
        (lax-and col
          (cond
            ([pair? l]
              (let ([rest (cdr l)])
                (let ([extra (if (null? rest) (+ extra 1) 0)])
                  (loop rest
                        (pr (car l) (indent col2 col) extra pp-item)))))
            ([null? l]
              (out "\x29" col))
            (else
              (out "\x29"
                   (pr l
                       (indent col2 (out "." (indent col2 col)))
                       (+ extra 1)
                       pp-item)))))))

    (define (pp-general expr col extra named? pp-1 pp-2 pp-3)

      (define (tail1 rest col1 col2 col3)
        (if (lax-and pp-1 (pair? rest))
          (let* ([val1 (car rest)]
                 [rest (cdr rest)]
                 [extra (if (null? rest) (+ extra 1) 0)])
            (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
          (tail2 rest col1 col2 col3)))

      (define (tail2 rest col1 col2 col3)
        (if (lax-and pp-2 (pair? rest))
          (let* ([val1 (car rest)]
                 [rest (cdr rest)]
                 [extra (if (null? rest) (+ extra 1) 0)])
            (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
          (tail3 rest col1 col2)))

      (define (tail3 rest col1 col2)
        (pp-down rest col2 col1 extra pp-3))

      (let* ([head (car expr)]
             [rest (cdr expr)]
             [col* (wr head (out "\x28" col))])
        (if (lax-and named? (pair? rest))
          (let* ([name (car rest)]
                 [rest (cdr rest)]
                 [col** (wr name (out " " col*))])
            (tail1 rest (+ col indent-general) col** (+ col** 1)))
          (tail1 rest (+ col indent-general) col* (+ col* 1)))))

    (define (pp-expr-list l col extra)
      (pp-list l col extra pp-expr))

    (define (pp-LAMBDA expr col extra)
      (pp-general expr col extra #f pp-expr-list #f pp-expr))

    (define (pp-IF expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr))

    (define (pp-COND expr col extra)
      (pp-call expr col extra pp-expr-list))

    (define (pp-CASE expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr-list))

    (define (pp-AND expr col extra)
      (pp-call expr col extra pp-expr))

    (define (pp-LET expr col extra)
      (let* ([rest (cdr expr)]
             [named? (and (pair? rest) (symbol? (car rest)))])
        (pp-general expr col extra named? pp-expr-list #f pp-expr)))

    (define (pp-BEGIN expr col extra)
      (pp-general expr col extra #f #f #f pp-expr))

    (define (pp-DO expr col extra)
      (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))

    ; define formatting style (change these to suit your style)

    (define specials-list `(
      ([lambda let* letrec define define-macro] ,pp-LAMBDA)
      ([if set! gset!]             ,pp-IF)
      ([and or]                    ,pp-AND)
      ([let]                       ,pp-LET)
      ([begin iterate cond]        ,pp-BEGIN)
      ;([cond]                      ,pp-COND)
      ([case]                      ,pp-CASE)
      ([do]                        ,pp-DO)
      ;;
      ([,lambda ,let* ,letrec ,define ,define-macro] ,pp-LAMBDA)
      ([,if ,set! ,gset!]             ,pp-IF)
      ([,and ,or]                    ,pp-AND)
      ([,let]                       ,pp-LET)
      ([,begin ,iterate ,cond]        ,pp-BEGIN)
      ;([,cond]                      ,pp-COND)
      ([,case]                      ,pp-CASE)
    ))

    (define (style head)
      (let loop ([list specials-list])
        ;(printf "head=%o; xlist=%o; memq=%o\n" head (caar list) (memq head (caar list)))
        (if (any-true? (memq head (caar list)))
            (cadar list)
            (if (any-true? (cdr list))
                (loop (cdr list))
                #f))))

    ;(define (style head)
    ;  (case head
    ;    ([lambda let* letrec define define-macro] pp-LAMBDA)
    ;    ([if set!]                   pp-IF)
    ;    ([and or]                    pp-AND)
    ;    ([let]                       pp-LET)
    ;    ([begin iterate cond]        pp-BEGIN)
    ;    ;([cond]                      pp-COND)
    ;    ([case]                      pp-CASE)
    ;    ([do]                        pp-DO)
    ;    (else                        #f)))

    (pr obj col 0 pp-expr))

  (if (any-true? width)
    (out (char->string 10) (pp obj 0))
    (wr obj 0)))

(end-module 'pprint-simple)


(define (pprint list)
  (pprint-simple:generic-write list 69 (lambda (s) (write s))))
