
;; Copyright (C) 2018 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(import (theme-d runtime runtime0))


(define obj->string-to-display-fwd '())


(define (list-contents-to-string lst visited)
  (let ((result
	 (if (null? lst)
	     ""
	     (string-append
	      (obj->string-to-display-fwd (car lst) visited)
	      (if (not-null? (cdr lst)) " " "")
	      (list-contents-to-string (cdr lst) visited)))))
    result))


(define (tvar->string-to-display tvar)
  (string-append
   "%"
   (number->string (vector-ref tvar i-tvar-object-number))))


(define (aplti->string-to-display aplti visited)
  (string-append
   "(*"
   (vector-ref (vector-ref aplti i-aplti-param-ltype) i-class-name)
   " "
   (list-contents-to-string (vector-ref aplti i-aplti-tvar-values)
			    visited)
   "*)"))


(define (apci->string-to-display apci visited)
  (string-append
   "(*"
   (vector-ref (vector-ref apci i-apci-param-class) i-class-name)
   " "
   (list-contents-to-string (vector-ref apci i-apci-tvar-values)
			    visited)
   "*)"))


(define (obj->string-to-display obj visited)
  (let ((new-visited (cons obj visited)))
    (cond
     ((null? obj) "[]")
     ((eqv? obj _b_<null>) "{}")
     ((memv obj visited) "/cycle/")
     ((is-tvar-object? obj)
      (tvar->string-to-display obj))
     ((list? obj)
      (string-append
       "["
       (list-contents-to-string obj new-visited)
       "]"))
     ((pair? obj)
      (string-append "["
		     (obj->string-to-display (car obj) new-visited)
		     " . "
		     (obj->string-to-display (cdr obj) new-visited)
		     "]"))
     ((is-tuple-type? obj)
      (string-append
       "{"
       (list-contents-to-string (tuple-type->list-reject-cycles obj)
				new-visited)
       "}"))
     ((is-pair-class? obj)
      (string-append
       "{"
       (obj->string-to-display (gen-car obj) new-visited)
       " . "
       (obj->string-to-display (gen-cdr obj) new-visited)
       "}"))
     ((is-simple-proc-class? obj)
      (string-append
       "(:simple-proc "
       (obj->string-to-display (vector-ref obj i-procedure-class-arg-list-type)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-procedure-class-result-type)
			       new-visited)
       " "
       (if (vector-ref obj i-procedure-class-pure-proc) "pure" "nonpure")
       ")"))
     ((is-param-proc-class? obj)
      (let ((tvars (vector-ref obj i-ppc-tvars))
	    (inst-type (vector-ref obj i-ppc-inst-type)))
	(string-append
	 "(:param-proc ["
	 (list-contents-to-string tvars new-visited)
	 "] "
	 (obj->string-to-display
	  (vector-ref inst-type i-procedure-class-arg-list-type)
	  new-visited)
	 " "
	 (obj->string-to-display
	  (vector-ref inst-type i-procedure-class-result-type)
	  new-visited)
	 " "
	 (if (vector-ref inst-type i-procedure-class-pure-proc)
	     "pure" "nonpure")
	 ")")))
     ((is-abstract-proc-type? obj)
      (string-append
       "(:procedure "
       (obj->string-to-display (vector-ref obj i-procedure-class-arg-list-type)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-procedure-class-result-type)
			       new-visited)
       " "
       (if (vector-ref obj i-procedure-class-pure-proc) "pure" "nonpure")
       ")"))
     ((is-type-list? obj)
      (string-append
       "(type-list "
       (list-contents-to-string (vector-ref obj i-type-list-subexprs)
				new-visited)
       ")"))
     ((is-splice-expression? obj)
      (string-append
       "(splice "
       (obj->string-to-display (vector-ref obj i-splice-component)
			       new-visited)
       ")"))
     ;; ((is-concrete-uniform-list? obj)
     ;;  (string-append
     ;;   "(:uniform-list "
     ;;   (obj->string-to-display (get-uniform-list-element-type obj))
     ;;  ")"))
     ((is-type-loop? obj)
      (string-append
       "(type-loop "
       (tvar->string-to-display (vector-ref obj i-type-loop-iter-var))
       " "
       (obj->string-to-display (vector-ref obj i-type-loop-subtype-list)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-type-loop-iter-expr)
			       new-visited)
       ")"))
     ((is-class? obj)
      (vector-ref obj i-class-name))
     ((is-aplti? obj)
      (aplti->string-to-display obj new-visited))
     ((is-apci? obj)
      (apci->string-to-display obj new-visited))
     ((is-union? obj)
      (string-append
       "(:union "
       (list-contents-to-string (vector-ref obj i-union-member-types)
				new-visited)
       ")"))
     ((is-singleton? obj)
      (string-append
       "(<singleton> "
       (obj->string-to-display (vector-ref obj i-singleton-element)
			       new-visited)
       ")"))
     ((is-marker? obj)
      (string-append
       "(<marker> "
       (obj->string-to-display (vector-ref obj i-marker-object)
			       new-visited)
       ")"))
     ((eq? obj _b_none)
      "<none>")
     (else
      (let* ((cl (theme-class-of obj))
	     (class-name (vector-ref cl i-class-name)))
	(string-append "@" class-name))))))


(set! obj->string-to-display-fwd obj->string-to-display)


(define (prt obj)
  (display (obj->string-to-display obj '()))
  (newline))


(set! prt-fwd prt)
