;;AUTOLOAD: pp
;;AUTOLOAD: ppn
;;;AUTODOC: pp "klone pretty-printer"
;; (pp function)
;;
;; Customisable and smart pretty-printer
;; contributed by Anselm BairdSmith <A.BairdSmith@frcl.bull.fr>
;; Example: (pp pp)
;; pp adds a newline at the end, ppn does not.

;;HISTORY
;; Fri Jun  4 17:39:58 1993
;; Reset history (switch-to-english-mode)
;; 2 bugs corrected:
;; . standard-print used *output-stream* instead of *standard-output*
;; . pretty on QuotedExpr use to suppose that each QuotedExpr was '

;--------------------------------------------------------------------------
; Customization variables
; . *pretty-htable*: if TRUE, prettyhastable contents
; . *pretty-long-list*: if list length is greater than this mark, pretty
;     only *pretty-list-base* items of the list.
;--------------------------------------------------------------------------

(setq *pretty-htable* ())
(setq *pretty-nil* "()")

; If you want long lists to be printed as ellipses:

(setq *pretty-long-list* ())	;; (> (length long-list) *pretty-long-list*)
(setq *pretty-list-base* 3)     ;; pretty only *pretty-list-base* items before "..."

;--------------------------------------------------------------------------
; main dispatch functions:
; pretty and pretty:basic

;; hashtables where methods are stored indexed by types
(setq pretty-table:pretty (Hashtable ()))
(setq pretty-table:pretty:basic (Hashtable ()))

(defun pretty-table:add (table type method)
  (put (eval (intern (+ "pretty-table:" table))) type method)
)

(defun pretty (self context &aux
    (method (get pretty-table:pretty (type-of self)
	'(pretty-table:default self "pretty" context)
  )))
  (apply method (list self context))
)

(defun pretty:basic (self context &aux
    (method (get pretty-table:pretty:basic (type-of self)
	'(pretty-table:default self "pretty:basic" context)
  )))
  (apply method (list self context))
)

(defun pretty-table:default (self selector-name context &aux
    (self-type (type-of self))
    (table (eval (intern (+ "pretty-table:" selector-name))))
    (ptype Any)
  )
  (dolist (type (types-list))
    (if (and (getn table type) (subtypep self-type type) (subtypep type ptype))
      (setq ptype type)
  ))
  (if (= Any ptype)
    (with (fallback (intern (+ selector-name "-default")))
      (if (boundp fallback)
	(apply fallback (list self context))
	(error Errors:UndefinedMethod self selector-name)
    ))
    (progn (put table self-type (get table ptype))
      (get table ptype)
  ))
)

(defun pretty-table:expand (table self-type &aux
    (ptype Any)
  )
  (dolist (type (types-list))
    (if (and (getn table type) (subtypep self-type type) (subtypep type ptype))
      (setq ptype type)
  ))
  (if (= Any ptype)
    ()
    (progn (put table self-type (get table ptype))
      (get table ptype)
  ))
)

;--------------------------------------------------------------------------
; pretty:
; Fallback pretty print function. To be used when no specific method
; are found for the object.
;--------------------------------------------------------------------------

(defun standard-print (object)
  (with (buffer (copy "")
	 *standard-output* (open buffer :direction :output :type :string)
	 *print-readably* t)
	(? object)
	buffer) )

(defun pretty-default (object context)
  (pretty (standard-print object) context) )
	
; ----------------------------------------------------------------------------
; A few utilities
; ----------------------------------------------------------------------------

(defun stringp (s)
  (eq (type-of s) String) )

; I wuld like to replace this by a proper statement. It doesn't look nice !

(defun pretty:method (item selector)
  (if (= 'pretty selector)
    (get pretty-table:pretty (type-of item)
      '(pretty-table:expand pretty-table:pretty (type-of item))
    )
    (= 'pretty:basic selector)
    (get pretty-table:pretty:basic (type-of item)
      '(pretty-table:expand pretty-table:pretty:basic (type-of item))
    )
    (eval selector)
))

(setq pretty:debug ())

(defun pretty:trace (&rest l)
  (if pretty:debug 
      (apply ? l) ) )

; ----------------------------------------------------------------------------
; Stream handlers.
;
; Streams handle output, eventually to the screen. As the pretty text can
; not be displayed before we are sure the text to be displayed holds
; in line, we must save it in these objects. If pretty succesfully ends,
; we "flush" the stream to the screen, else, we prune the work (!).
; ----------------------------------------------------------------------------

(defstruct PrettyStream 
  (length 0)
  (buffer (copy ""))
)

(setq PrettyStream:length PrettyStream-length)
(setq PrettyStream:buffer PrettyStream-buffer)

(defun PrettyStream:write (self string)
  (PrettyStream:buffer self (+ (PrettyStream:buffer self) string))
  (PrettyStream:length self (+ (PrettyStream:length self) (length string))) )

(defun PrettyStream:flush (self)
  (? (PrettyStream:buffer self))
  (PrettyStream:buffer self "")
  (PrettyStream:length self 0) )

; ----------------------------------------------------------------------------
; Contexts handlers.
;
; Context are used to memorize the whole state of the pretty printer when
; it recursivly prints object. We must be able to restart a computation
; in the same pretty context in case of failure with a given method.
; ----------------------------------------------------------------------------

(defstruct Context 
  (point 0)
  (lmargin 0)
  (rmargin 80)
  (output (make-PrettyStream))
  (delim 0) 
  (newline 0)
)

(setq context:point    Context-point)
(setq context:lmargin  Context-lmargin)
(setq context:rmargin  Context-rmargin)
(setq Context:output   Context-output)
(setq context:delim    Context-delim)
(setq context:newline  Context-newline)

; A short hand for writing in the output of Context :

(defun Context:put (self string)
  (incf (Context:output self) string) )

; --------------------------------------------------------------------------
; Pretty print hashtables
; If *pretty-htable* is true, print all the associations, else print
; the default.
; --------------------------------------------------------------------------

(pretty-table:add 'pretty:basic  Hashtable
  (lambda (h ctxt)
    (if *pretty-htable*
      (progn (pretty:print "{" ctxt)
	(with (tab (context:lmargin ctxt)
	    l   (- (length h) 1)
	    i   0 )
	  (context:lmargin ctxt (context:point ctxt))
	  (dohash (key val h)
	    (pretty key ctxt)
	    (pretty:delim ctxt)
	    (pretty val ctxt)
	    (if (< i l)
	      (pretty:newline ctxt) )
	    (incf i 1) )
	  
	  (pretty:print "}" ctxt)
	  (context:lmargin ctxt tab)
	  ctxt  ))
      (pretty:print (string h) ctxt) ) )
)

(pretty-table:add 'pretty  Hashtable
  (lambda (self context)
    (pretty:pp self context 'pretty:basic) )
)

; ----------------------------------------------------------------------------
; Pretty printing lists:
;
; We had defined three strategies for pretty printing lists. The first one
; tries to display it on current line, the second one is "customizable"
; for each "function" (car) of the list (see examples below).
; The third method is rarely used, and try to display the list in the smallest
; way.
; ----------------------------------------------------------------------------

(pretty-table:add 'pretty:basic  List
  (lambda (self ctxt)
    (if (= 0 (length self))
      (pretty:print *pretty-nil* ctxt)
      (progn (pretty:openPar ctxt)
	(dolist (i (subseq self 0 (- (length self) 1)))
	  (pretty i ctxt)
	  (pretty:delim ctxt))
	(pretty (get self (- (length self) 1)) ctxt)
	(pretty:closePar ctxt)
	ctxt
))))

; In strategy one, you can add entry to this table if you need particular 
; indentations for sonme lists. See below the pretty1 function wich eventually
; dispatch the list to pretty to one of these functions.

(setq pretty:table-list (coerce (list) Hashtable))

(put pretty:table-list 'with 'pretty:with-env)
(put pretty:table-list 'let  'pretty:let-env)
(put pretty:table-list 'let* 'pretty:let-env)

(defun pretty:with-env (self ctxt)
  (pretty:openPar ctxt)
  (pretty:print "with" ctxt)
  (pretty:delim ctxt)
; Parse the new environment :
; (with (this kind
;        of   indentation)
;       and continue here)
  (pretty:openPar ctxt)
  (context:lmargin ctxt (context:point ctxt))
  (with (env  (get self 1)
      nenv 0 
      tab  (context:lmargin ctxt))
    (while (< nenv (- (length env) 2))
      (pretty (get env nenv) ctxt)
      (incf nenv 1)
      (pretty:delim ctxt)
      (pretty (get env nenv) ctxt)
      (incf nenv 1)
      (pretty:newline ctxt) )
    (pretty (get env nenv) ctxt)
    (pretty:delim ctxt)
    (incf nenv 1)
    (pretty (get env nenv) ctxt)
    (pretty:closePar ctxt)
    (context:lmargin ctxt (- tab 1))
    (pretty:newline ctxt)  )
; statements with newlines except the last one.
  (dolist (i (subseq self 2 (- (length self) 1)))
    (pretty i ctxt)
    (pretty:newline ctxt) )
  (pretty (get self (- (length self) 1)) ctxt)
  (pretty:closePar ctxt)
  ctxt   )

(defun pretty:let-env (self ctxt)
  (pretty:openPar ctxt)
  (pretty:print (coerce (get self 0) String) ctxt)
  (pretty:delim ctxt)
; Parse the new environment :
; (let ((this kind)
;       (of   indentation))
;       and continue here)
  (pretty:openPar ctxt)
  (context:lmargin ctxt (context:point ctxt))
  (with (env  (get self 1)
      nenv 0 
      tab  (context:lmargin ctxt))
    (while (< nenv (- (length env) 1))
      (pretty (get env nenv) ctxt)
      (incf nenv 1)
      (pretty:newline ctxt) )
    (pretty (get env nenv) ctxt)
    (pretty:closePar ctxt)
    (context:lmargin ctxt (- tab 1))
    (pretty:newline ctxt)  )
; statements with newlines except the last one.
  (dolist (i (subseq self 2 (- (length self) 1)))
    (pretty i ctxt)
    (pretty:newline ctxt) )
  (pretty (get self (- (length self) 1)) ctxt)
  (pretty:closePar ctxt)
  ctxt   )

; The pretty1 entry point:

(defun pretty:pretty1 (self ctxt)	;self is a List
  (if (= 0 (length self))
      (pretty:print *pretty-nil* ctxt)
      (with (tab    (context:lmargin ctxt)
	     fun    (get self 0)
	     method (get pretty:table-list fun ()))
	    (pretty:trace "pretty1 for (" (get self 0) "...\n")
	    (if method
		(method self ctxt)
; (Default strategy 
;          (at this level)
;          (is like that))
; This strategy works in fact for most construct (see exceptions below)
	        (progn (pretty:trace "default 1 strategy\n") 
		       (pretty:openPar ctxt)
		       (pretty fun ctxt)
		       (pretty:delim ctxt)
		       (context:lmargin ctxt (context:point ctxt))
		       (with (l    (- (length self) 1)
			      args (subseq self 1 l))
			     (dolist (i args)
				  (pretty:trace "pretty:pretty1:List (item)\n")
				  (pretty i ctxt)
				  (pretty:newline ctxt))
			     (and (get self l ())
				  (pretty (get self l ()) ctxt))
			     (pretty:closePar ctxt)) )  )
	    (context:lmargin ctxt tab)
	    ctxt   )) )

	  
; (This 
;  (method is a last resort)
;  (it should compact list inthe best way))

(defun pretty:pretty2 (self ctxt)	;self is a List
  (if (= 0 (length self))
      (pretty:print *pretty-nil*)
      (with (tab (context:lmargin ctxt))
	    (pretty:trace "pretty2 for (" (get self 0) "...\n")
	    (pretty:openPar ctxt)
	    (context:lmargin ctxt (context:point ctxt))
	    (dolist (i (subseq self 0 (- (length self) 1)))
		 (pretty i ctxt)
		 (pretty:newline ctxt))
	    (pretty (get self (- (length self) 1)) ctxt)
	    (pretty:closePar ctxt)
	    (context:lmargin ctxt tab)
	    ctxt    )))

;; The main entry point for pretty printing lists :
;; We deal with the *pretty-long-list* flag here by converting the list 
;; according to its length. This is not very nice, but the cost is small
;; in the overall cost of the algo used (!)

(pretty-table:add 'pretty  List
  (lambda (self context)
    (if (and *pretty-long-list* (> (length self) *pretty-long-list*))
      (with (self-list (+ (subseq self 0 *pretty-list-base*) (list "...")))
	(pretty:pp self-list context 'pretty:basic 'pretty:pretty1 'pretty:pretty2))
      (pretty:pp self context 'pretty:basic 'pretty:pretty1 'pretty:pretty2))
    context  )
)

; ----------------------------------------------------------------------------
; Functions pretty printing.
;
; Coerce them to list !
; ----------------------------------------------------------------------------

(pretty-table:add 'pretty  Expr
  (lambda (self context)
    (pretty (coerce self List) context) )
)

(pretty-table:add 'pretty  FExpr
  (lambda (self context)
  (pretty (coerce self List) context) )
)

(pretty-table:add 'pretty  Macro
  (lambda (self context)
  (pretty (coerce self List) context) )
)

(pretty-table:add 'pretty  Subr
  (lambda (self context)
  (pretty (string self) context) )
)

; ----------------------------------------------------------------------------
; Number pretty printing.
; 
; Coerce them to string.
; ----------------------------------------------------------------------------

(pretty-table:add 'pretty  Number
  (lambda (self context)
  (pretty:print (coerce self String) context) )
)

; ----------------------------------------------------------------------------
; Strings pretty printing.
;
; As we want string to be printed in a readable form, we use the klone
; variable *print-readably* to pretty them.
; Two methods can be used, one for strings that fit in the current line,
; and the other one wich split them with a "\".
; ----------------------------------------------------------------------------

(defun string (s)
  (with (buffer            (copy "")
	 *standard-output* (open buffer :direction :output :type :string)
	 *print-readably*  t)
	(? s)
	; When s contains a "\n", ? produces a "\\n\\\n": get rid of last !
	(with (p (seek buffer "\n"))
 	      (while p
 		(delete buffer p)
 		(delete buffer (- p 1))
 		(setq p (seek buffer "\n"))) )
 	buffer   ) )

(defun pretty:pretty (self ctxt)	; self is a String
  (with (tab  (context:lmargin ctxt)
	 size (- (context:rmargin ctxt) (context:point ctxt) 3)
         str  (string self)
	 idx  0 )
	(context:lmargin ctxt (context:point ctxt))
	(while (< idx (- (length self) size))
	  (pretty:print (+ (subseq str idx (+ idx size)) "\\") ctxt)
	  (pretty:newline ctxt)
	  (incf idx size) )
	(pretty:print (subseq str idx (+ idx size)) ctxt)
	(context:lmargin ctxt tab)
	ctxt  ))

(pretty-table:add 'pretty:basic  String
  (lambda (self ctxt)
  (pretty:print (string self) ctxt) )
)

(pretty-table:add 'pretty  String
  (lambda (self context)
  (pretty:pp self context 'pretty:basic 'pretty:pretty) )
)

; ----------------------------------------------------------------------------
; Atoms pretty printing.
;
; As string.
; ----------------------------------------------------------------------------

(pretty-table:add 'pretty:basic  Atom
  (lambda (self context)
  (pretty:print (coerce self String) context) )
)

(pretty-table:add 'pretty  Atom
  (lambda (self context)
  (pretty:pp self context 'pretty:basic) )
)

; ----------------------------------------------------------------------------
; QuotedExpr pretty printing.
;
; Just print the "'" before printing the expression.
; ----------------------------------------------------------------------------

(pretty-table:add 'pretty:basic  QuotedExpr
  (lambda (self context)
    (pretty:print (get self 0) context)
    (pretty:pp (get self 1) context 'pretty:basic) )
)

(pretty-table:add 'pretty  QuotedExpr
  (lambda (self context)
    (pretty:pp self context 'pretty:basic)
))

; ----------------------------------------------------------------------------
; Entry point :
;
; The main entry point: 
;   . create a default context ,
;   . reset the protections list (see below, usage of this variable)
;   . and apply "pretty" method to the object, and flush resulting context.
; ----------------------------------------------------------------------------

(defun ppn (expr &optional (context (make-Context)))
  (catch 'pretty
    (setq pretty:protect (list (list -1 -1)))
    (pretty expr context)
    (PrettyStream:flush (Context:output context)))
  ()
)

(defun pp (&rest args)
  (if (and (boundp 'Structure) (typep Structure Type) (typep (0 args) Structure))
    (struct-pp (0 args))
    (apply ppn args)
  )
  (write-char #\newline)
  ()
)


; ----------------------------------------------------------------------------
; Displaying functions.
;
; These function are the UI for the one who wants to define new method. 
; Available functions are:
;      . pretty:print   : add a string to the current PrettyStream
;      . pretty:delim   : add a delimiter right now in PrettyStream
;      . pretty:newline : user line break (/= pretty line breaks)
;      . pretty:openPar : open a parenthisis
;      . pretty:closePar: close it.
; The last two functions are just here in case you want a special handling
; on displaying them. If this is the case, redefine them. 
; ----------------------------------------------------------------------------

(defun pretty:print (s context)
  (context:point context (+ (context:point context)
			    (length s) ))
  (if (< (context:point context) (context:rmargin context))
      (with (output (Context:output context))
	    (while (> (context:delim context) 0)
	      (PrettyStream:write output " ") 
	      (context:delim context (- (context:delim context) 1)) )
	    (PrettyStream:write output s)
	    context  )
      (progn (context:delim context 0)
	     (pretty:next-strategy)) ) )

(defun pretty:delim (ctxt)
  (context:delim ctxt (+ 1 (context:delim ctxt)))
  (context:point ctxt (+ 1 (context:point ctxt))) )
	     
(defun pretty:newline (context)
  (with (output (Context:output context)
	 spaces (context:lmargin context))
	(PrettyStream:write output "\n")
	(while (> spaces 0) (PrettyStream:write output " ") (incf spaces -1))
	(context:delim context 0)
	(context:point context (context:lmargin context))
	(context:newline context (+ (context:newline context) 1))
	context  ))
	
(defun pretty:openPar (ctxt)
  (pretty:print "(" ctxt) )

(defun pretty:closePar (ctxt)
  (context:delim ctxt 0)
  (pretty:print ")" ctxt) )

; ----------------------------------------------------------------------------
; Main engine.
;
; The main engine is divided in three parts:
;
;    . The first part is concerned with trying each method for each object
;    to pretty print. 
;    . The second part handles the restartation of the pretty printer: 
;    on wich object should you restart the pretty printing to obtain the
;    best result ?
;    . The last 


; This is the entry point in the main engine: feed it with the object
; to bee pretty printed, the current context and a number of methods to
; do the work. 
; It will try - in the given order - each possible strategies on this object.

(defun pretty:pp (item context &rest strategies)
  (with (sucess ()
	 n      0 )
; The first (- n 1) strategies are tried using a "catch" in case of newline:
; we know for them a better strategie, namemly the (+ i 1) one.
	(while (and (not sucess) (< n (- (length strategies) 1)))
	  (setq sucess (pretty:try item 
				   context 
				   (pretty:method item (get strategies n))
				   (pretty:push-tag n)  ))
	  (incf n 1) )
	(if (not sucess)
; For the last one do not protect: if you cannot pretty print using this
; strategy, you should abort the pretty printing process
	    (setq sucess 
		  (with (ctxt (copy context))
			(Context:output ctxt (make-PrettyStream))
			((pretty:method item (get strategies n))
			 item
			 ctxt)  )) )
	(if (not sucess)
	    (throw 'pretty "Not good enough strategies for this.\n")
; Ok: one of the strategies has ended succesfully, set the enclosing context
; to the returned context, and return it :
	    (progn (PrettyStream:write (Context:output context) 
			  (PrettyStream:buffer (Context:output sucess)))
	           (context:point   context (context:point   sucess))
		   (context:lmargin context (context:lmargin sucess))
		   (context:rmargin context (context:rmargin sucess))
		   (context:delim   context (context:delim sucess))
		   (context:newline context (context:newline sucess))
		   context  ))  ))

; Try one strategy, eventually protecting against 'newline throw:

(defun pretty:try (item context strat tag)
  (with (ctxt      (copy context)
	 caught   (progn (Context:output ctxt (make-PrettyStream))
			  (if tag
			      (catch tag (strat item ctxt))
			      (pretty:basic item ctxt) )) )
	(if (= caught 'newline)
	    ()
	    (progn (if tag (pretty:forget-tag)) ctxt)  ) ) )

; ----------------------------------------------------------------------------
; The catch and throw maintenance.
;
; For each object beeing pretty printed with more than one method, we catch
; the work with a unique tag, so we can decide wich pretty we should 
; restart in the list of enclosed objects.
; ----------------------------------------------------------------------------

; Obtain a stamp for a new tag :

(setq pretty:tag-stamp 0)
(defun pretty:new-stamp () (incf pretty:tag-stamp 1))

; Given a stamp and a method number (position of the method in the method list)
; make a tag :

(defun pretty:make-tag (stamp n)
  (intern (+ "tag-" (coerce stamp String) "-" (coerce n String))) )

; Forget tag is used to throw a tag, wich hasn't been effectiveley throwed

(defun pretty:forget-tag ()
  (delete pretty:protect 0) )

; This function push a tag with level given on the stak, and memorize it
; on the pretty:protect lists of all the tags actually in the stack.
  
(defun pretty:push-tag (level)
  (with (stamp (pretty:new-stamp)
	 tag   (pretty:make-tag stamp level))
	(setq pretty:protect (+ (list (list stamp level)) pretty:protect))
	tag  )  )



; This function is called when you want to change the current strategy. It has
; to decide for wich enclosed object yuou should restart the pretty print
; process. This choice is quiet difficult !
; Mainly, the strategy here consists of beeing sure that no objects are still
; using the 0 strategy if an enclosed one is using a higher one (this is
; done through "pretty:protect-null". Next using only the last level, try
; to see wich computation to restart.
; Gien the strategies I have defined, this function give me the best result.
; If ever you changed the strategies, you will perhaps like to change this
; function also.

(defun pretty:pop-tag ()
  (with (easy (pretty:protect-null))
    (or easy
      (with (current  (get pretty:protect 0)
	  enclosed (get pretty:protect 1)
	  el       (get enclosed 1)
	  cl       (get current 1))
	(if (or (and (>= cl 2) (<= el 1))
	    (and (= cl 0) (=  el 0))
	    (and (= cl 1) (= el 1)) ) (progn
; Restart enclosing :
	    (delete pretty:protect 0)
	    (delete pretty:protect 0)
	    (pretty:make-tag (get enclosed 0) el) )
; Restart current:
	  (or (and (= cl 0) (>= el 1))
	    (and (<= cl 1) (>= el 1))) (progn
	    (delete pretty:protect 0)
	    (pretty:make-tag (get current 0) cl))
	  (progn
; I cannot see what to choose ! restart current:
	    (delete pretty:protect 0)
	    (pretty:make-tag (get current 0) cl))
)))))


; Try to find (in reverse order) a tag defined with the 0 level :

(defun pretty:protect-null ()
  (with (l (length pretty:protect))
	(if (> l 3)
	    (with (n (- l 2)
		   b () )
		  (while (and (not b) (>= n 0))
		    (with (level (get (get pretty:protect n) 1)
			   stamp (get (get pretty:protect n) 0))
			  (if (= level 0)
			      (setq b (pretty:make-tag stamp level))
			      (incf n -1))) )
		  (if b
		      (progn (incf n 1)
			     (setq pretty:protect (subseq pretty:protect n l))
			     b ))  )  ) ))

; User Interface for asking a change of methodfor the current object :

(defun pretty:next-strategy ()
  (with (tag (pretty:pop-tag))
	(if tag
	    (throw tag 'newline)
	    (throw 'pretty "pretty: internal error ?\n"))) )




;; end of file
