;; -*-theme-d-*-

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

(define-body (standard-library object-string-conversion)

  (import (standard-library string-utilities)
	  (standard-library list-utilities))
  
  (define general-object->string
    (lambda (((obj <object>)) <string> pure)
      (string-append
       "["
       (field-ref (class-of obj) 'str-name)
       "]")))

  (define integer->string
    (prim-proc number->string (<integer>) <string> pure))

  (define real->string
    (prim-proc number->string (<real>) <string> pure))

  (define symbol->string
    (prim-proc symbol->string (<symbol>) <string> pure))

  (define null->string
    (lambda (((obj <null>)) <string> pure)
      "()"))

  (define character->string
    (lambda (((obj <character>)) <string> pure)
      (string obj)))

  (define string->string
    (lambda (((obj <string>)) <string> pure)
      obj))

  (define boolean->string
    (lambda (((b <boolean>)) <string> pure)
      (if b "#t" "#f")))

  (define-simple-proc to-string0
      (((obj <object>) (visited (:uniform-list <pair>)))
       <string> pure)
    (cond 
     ((is-instance? obj <pair>)
      (let* ((o (cast <pair> obj)) 
	     (o1 (car o))
	     (o2 (cdr o)))
	(cond
	 ((member-objects? o visited) "...")
	 ((null? o2)
	  (string-append "(" (to-string0 o1 (cons o visited)) ")"))
	 ((is-instance? o2 <nonempty-list>)
	  (let* ((new-visited (cons o visited))
		 (lst
		  (append
		   (list (to-string0 o1 new-visited))
		   (map (lambda (((obj2 <object>)) <string> pure)
			  (to-string0 obj2 new-visited))
			(cast <list> o2))))
		 (str (join-strings-with-sep lst " ")))
	    (string-append "(" str ")")))
	 (else
	  (let ((str1 (to-string0 o1 visited))
		(str2 (to-string0 o2 visited)))
	    (string-append "(" str1 " . " str2 ")"))))))
     (else (object->string obj))))

  (define-simple-proc pair->string
      (((p <pair>)) <string> pure)
    (to-string0 p null))

  (add-method object->string general-object->string)
  (add-method object->string integer->string)
  (add-method object->string real->string)
  (add-method object->string string->string)
  (add-method object->string symbol->string)
  (add-method object->string null->string)
  (add-method object->string character->string)
  (add-method object->string boolean->string)
  (add-method object->string pair->string)

  (define string->symbol
    (unchecked-prim-proc string->symbol (<string>) <symbol> pure))

  (define string->integer
    (prim-proc theme-string->integer (<string>) <integer> pure))

  (define string->real
    (prim-proc theme-string->real (<string>) <real> pure)))
