

(import (th-scheme-utilities stdutils))


(define target-object-as-string0-fwd '())

(define (is-t-tuple-type? to lst-visited)
  (cond
   ;; Empty tuple type is tc-nil, not null.
   ((null? to) (raise 'internal-error))
   ((eq? to tc-nil) #t)
   ((memq to lst-visited) #f)
   ((hfield-ref to 'incomplete?) #f)
   ((is-tc-pair? to)
    (is-t-tuple-type? (cadr (tno-field-ref to 'l-tvar-values))
		      (cons to lst-visited)))
   (else #f)))

(define (target-car to)
  (let* ((lst-tvv (tno-field-ref to 'l-tvar-values)))
;;    (assert (equal? (length lst-tvv) 2))
    (car lst-tvv)))

(define (target-cdr to)
  (let* ((lst-tvv (tno-field-ref to 'l-tvar-values)))
;;    (assert (equal? (length lst-tvv) 2))
    (cadr lst-tvv)))

(define (pair-class-to-string to lst-visited)
  (string-append
   "{"
   (target-object-as-string0 (target-car to) lst-visited)
   " . "
   (target-object-as-string0 (target-cdr to) lst-visited)
   "}"))

(define (tuple-type-contents-to-string lst lst-visited)
  (if (or (null? lst) (eq? lst tc-nil))
      ""
      (let ((head (target-car lst))
	    (tail (target-cdr lst)))
	(string-append
	 (target-object-as-string0-fwd head lst-visited)
	 (if (and (not-null? tail) (not (eq? tail tc-nil))) " " "")
	 (tuple-type-contents-to-string tail lst-visited)))))

(define (list-contents-to-string lst lst-visited)
  (if (null? lst)
      ""
      (let ((head (car lst))
	    (tail (cdr lst)))
	(string-append
	 (target-object-as-string0-fwd head lst-visited)
	 (if (not-null? tail) " " "")
	 (list-contents-to-string tail lst-visited)))))

(define (tuple-type-to-string lst lst-visited)
  (string-append "{" (tuple-type-contents-to-string lst lst-visited) "}"))

(define (list-to-string lst lst-visited)
  (string-append "(" (list-contents-to-string lst lst-visited) ")"))

(define (default-class-output to)
  (if (not (hfield-ref to 'incomplete?))
      (tno-field-ref to 'str-name)
      "/incomplete/"))

(define (proc-type-to-string to lst-visited simple?)
  (let* ((argl (tno-field-ref to 'type-arglist))
	 (res (tno-field-ref to 'type-result))
	 (pure? (tno-field-ref to 'pure-proc?))
	 (always-returns? (tno-field-ref to 'appl-always-returns?))
	 (never-returns? (tno-field-ref to 'appl-never-returns?))
	 (str-keyword (if simple? ":simple-proc" ":procedure"))
	 (str-attr1 (if pure? "pure" "nonpure"))
	 (str-attrs2
	  (cond
	   ((and always-returns? (not never-returns?))
	    " always-returns")
	   ((and (not always-returns?) never-returns?)
	    " never-returns")
	   ((and (not always-returns?) (not never-returns?))
	    "")
	   (else (raise 'invalid-attributes))))
	 (str-attrs (string-append "(" str-attr1 str-attrs2 ")")))
    (string-append
     "(" str-keyword " "
     (target-object-as-string0 argl lst-visited)
     " "
     (target-object-as-string0 res lst-visited)
     " "
     str-attrs
     ")")))

(define (union-to-string to lst-visited)
  (let* ((lst-members (tno-field-ref to 'l-member-types))
	 (str-contents (list-contents-to-string lst-members lst-visited)))
    (string-append "(:union " str-contents ")")))

(define (type-list-to-string to lst-visited)
  (let* ((lst-subtypes (tno-field-ref to 'l-subtypes))
	 (str-contents (list-contents-to-string lst-subtypes lst-visited)))
    (string-append "(type-list " str-contents ")")))

(define (splice-to-string to lst-visited)
  (let* ((obj-component (tno-field-ref to 'type-component))
	 (str-component (target-object-as-string0 obj-component lst-visited)))
    (string-append "(splice " str-component ")")))

(define (plti-to-string to lst-visited)
  (let* ((param-ltype (tno-field-ref to 'type-meta))
	 (tvar-values (tno-field-ref to 'l-tvar-values))
	 (str-param-ltype (target-object-as-string0 param-ltype lst-visited))
	 (str-tvar-values (list-contents-to-string tvar-values lst-visited)))
    (string-append "(" str-param-ltype " " str-tvar-values ")")))

(define (tvar-to-string tvar)
  (string-append
   (symbol->string (get-var-orig-name
		    (hfield-ref (tno-field-ref tvar 'address)
				'source-name)))
   "["
   (number->string (hfield-ref (tno-field-ref tvar 'address)
  			       'number))
   "]"))

(define (param-proc-class-to-string ppc lst-visited)
  (string-append
   "(:param-proc ("
   (list-contents-to-string (tno-field-ref ppc 'l-tvars) lst-visited)
   ") "
   (target-object-as-string0 (tno-field-ref ppc 'type-contents) lst-visited)
   ")"))

(define (type-loop-to-string to lst-visited)
  (let ((iter-var (tno-field-ref to 'tvar))
	(subtypes (tno-field-ref to 'x-subtypes))
	(iter-expr (tno-field-ref to 'x-iter-expr)))
    (string-append
     "(type-loop "
     (tvar-to-string iter-var)
     (cond
      ((list? subtypes)
       (string-append
	" ("
	(list-contents-to-string subtypes lst-visited)
	") "))
      ((is-t-tuple-type? subtypes lst-visited)
       (string-append
	" {"
	(tuple-type-contents-to-string subtypes lst-visited)
	"} "))
      ((is-t-type-variable? subtypes)
       (string-append
	" "
       (tvar-to-string subtypes)
       " "))
      (else "//unknown//"))
     (target-object-as-string0 iter-expr lst-visited)
     ")")))

(define (pci-to-string to lst-visited)
  (let ((pc (get-entity-type to))
	(params (tno-field-ref to 'l-tvar-values)))
    (string-append
     "("
     (default-class-output pc)
     " "
     (list-contents-to-string params lst-visited)
     ")")))

(define (apti-to-string to lst-visited)
  (let ((pt (tno-field-ref to 'type-meta))
	(params (tno-field-ref to 'l-type-args)))
    (string-append
     "(*"
     (default-class-output pt)
     " "
     (list-contents-to-string params lst-visited)
     "*)")))

(define (target-object-as-string0 to lst-visited)
  (let ((lst-new-visited (cons to lst-visited)))
    (cond
     ((null? to) "()")
     ((eq? to tc-nil) "{}")
     ((memq to lst-visited) "/cycle/")
     ((list? to) (list-to-string to lst-visited))
     ((not (hrecord-is-instance? to <target-object>))
      "/NONOBJECT/")
     ((eq? to to-this) "/this/")
     ((is-forward-decl-entity? to)
      (string-append "(/incomplete/ " (number->string (hashq to 1000000)) ")"))
     ((not (is-known-object? to)) "/unknown/")
     ((is-t-type-variable? to)
      (tvar-to-string to))
     ((is-t-tuple-type? to lst-visited)
      (tuple-type-to-string to lst-new-visited))
     ((is-tc-pair? to)
      (pair-class-to-string to lst-new-visited))
     ((is-tc-simple-proc? to)
      (proc-type-to-string to lst-new-visited #t))
     ((is-tt-procedure? to)
      (proc-type-to-string to lst-new-visited #f))
     ((is-tc-param-proc? to)
      (param-proc-class-to-string to lst-new-visited))
     ((is-tt-union? to)
      (union-to-string to lst-new-visited))
;;     ((is-t-param-ltype-inst? to)
;;      (plti-to-string to lst-new-visited))
     ((is-t-type-list? to)
      (type-list-to-string to lst-new-visited))
     ((is-t-type-loop? to)
      (type-loop-to-string to lst-new-visited))
     ((is-t-splice? to)
      (splice-to-string to lst-new-visited))
     ((is-t-param-class-instance? to)
      (pci-to-string to lst-new-visited))
     ((is-t-class? to) (default-class-output to))
     ((eq? to tt-none) "<none>")
     ((is-t-apti? to)
      (apti-to-string to lst-new-visited))
     ((is-t-signature? to)
      (let ((address (hfield-ref to 'address)))
	(if (not-null? address)
	    (string-append "[<signature> "
			   (symbol->string (hfield-ref address 'source-name))
			   "]")
	    "[<signature>]")))
     (else
      "/unknown/"))))

(set! target-object-as-string0-fwd target-object-as-string0)

(define (target-object-as-string to)
  (target-object-as-string0 to '()))

(define (ptno2 to)
  (display (target-object-as-string to))
  (newline))

