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


(define-module (theme-d util phr-int)
  #:declarative? #f
  #:export (phr-int g))


(import (rnrs)
        (oop goops))

(import (th-scheme-utilities hrecord)
        (th-scheme-utilities stdutils))

(import (theme-d translator theme-d-linker))

(define-hrecord-type <hrecord-printer> ()
  obj-cur
  i-cur-index
  s-mode
  s-output-mode
  l-stack
  str-message)


(define g '())


(define phr-line-prefix2 "  ")
(define phr-tto-prefix2 "  *")


(define (print2 . args)
  (cond
    ((null? args) '())
    ((pair? args)
     (display (car args))
     (apply print2 (cdr args)))
    (else (raise 'invalid-argument))))


(define (print-object obj)
  (cond
    ((null? obj)
     (print2 "null"))
    ((list? obj)
     (print2 "(...)"))
    (else
     (print2 obj))))


(define (print-object-briefly obj)
  (cond
    ((is-target-object? obj)
     (let ((type (get-entity-type obj)))
       (if (is-t-class? type)
         (print2 "//" (tno-field-ref (get-entity-type obj) 'str-name) "//")
         (print2 "// ? //"))))
    ((hrecord? obj)
     (print2 "/" (hrecord-type-name-of obj) "/"))
    ((null? obj)
     (print2 "nil"))
    ((list? obj)
     (print2 "(...)"))
    ((pair? obj)
     (print2 "(... . ...)"))
    (else
     (print2 obj))))


(define (print-field2 index name value)
  (print2 phr-line-prefix2 index " " name ": ")
  (print-object-briefly value)
  (newline))


(define (get-all-fields clas)
  (map slot-definition-name (class-slots clas)))


(define (object->list x)
  (let ((l-s-fields (get-all-fields (class-of x))))
    (map (lambda (s-field) (slot-ref x s-field)) l-s-fields)))


(define (obj-ref x i-field)
  (assert (>= i-field 1))
  (let ((l-fields (get-all-fields (class-of x))))
    (slot-ref x (list-ref l-fields (- i-field 1)))))


(define (print-contents2 hr)
  ;;  (assert (hrecord? hr))
  (let* ((hrt (hrecord-type-of hr))
         (fields (hrecord-type-get-all-fields hrt))
         (field-values (object->list hr)))
    (assert (= (length fields) (length field-values)))
    (do ((l-cur-fields fields (cdr l-cur-fields))
         (l-cur-values field-values (cdr l-cur-values))
         (i 1 (+ i 1)))
      ((null? l-cur-fields))
      (print-field2 i (car l-cur-fields) (car l-cur-values)))))


(define (print-hrecord2 hr)
  ;;  (assert (hrecord? hr))
  (print2 (hrecord-type-name-of hr))
  (newline)
  (print2 phr-line-prefix2 "{")
  (newline)
  (print-contents2 hr)
  (print2 phr-line-prefix2 "}")
  (newline))


(define (print-tto-field index name value)
  (print2 phr-tto-prefix2 index " " name ": ")
  (print-object-briefly value)
  (newline))


(define (print-proper-tto-fields tto)
  ;;  (assert (hrecord? hr))
  (let ((al-field-values (hfield-ref tto 'al-field-values)))
    (if (not (eq? al-field-values #f))
      (let ((i-hr-field-count (hrecord-type-get-field-count <target-object>)))
        (do ((al-cur-fields al-field-values (cdr al-cur-fields))
             (i (+ i-hr-field-count 1) (+ i 1)))
          ((null? al-cur-fields))
          (print-tto-field i (caar al-cur-fields) (cdar al-cur-fields)))))))


(define (print-tto-contents tto)
  (print-contents2 tto)
  (print-proper-tto-fields tto))


(define (print-tto tto)
  ;;  (assert (hrecord? tto))
  (let ((type (get-entity-type tto)))
    (if (is-t-class? type)
      (begin
       (print2 (tno-field-ref type 'str-name))
       (newline))))
  (print2 phr-line-prefix2 "{")
  (newline)
  (print-tto-contents tto)
  (print2 phr-line-prefix2 "}")
  (newline))


(define (print-list l)
  (print2 "list")
  (newline)
  (do ((i 0 (+ i 1))
       (l-cur l (cdr l-cur)))
    ((null? l-cur))
    (print2 phr-line-prefix2 i " ")
    (print-object-briefly (car l-cur))
    (newline)))


(define (print-pair l)
  (print2 "pair")
  (newline)
  (print2 phr-line-prefix2 0 " ")
  (print-object-briefly (car l))
  (newline)
  (print2 phr-line-prefix2 1 " ")
  (print-object-briefly (cdr l))
  (newline))


(define (print-data obj)
  (cond
    ((is-target-object? obj)
     (print-tto obj))
    ((hrecord? obj)
     (print-hrecord2 obj))
    ((list? obj)
     (print-list obj))
    ((pair? obj)
     (print-pair obj))
    (else
     (print-object obj)
     (newline))))


(define (get-mode obj)
  (cond
    ((is-target-object? obj) 'tto)
    ((hrecord? obj) 'hrecord)
    ((list? obj) 'list)
    ((pair? obj) 'pair)
    (else 'simple)))


(define (phr-rep hrecord-printer)
  (display "> ")
  (let ((obj-choice (read))
        (obj-cur (hfield-ref hrecord-printer 'obj-cur))
        (s-mode (hfield-ref hrecord-printer 's-mode)))
    (cond
      ((integer? obj-choice)
       (case s-mode
         ((hrecord)
          (assert (hrecord? obj-cur))
          (let* ((hrt (hrecord-type-of obj-cur))
                 (i-field-count (hrecord-type-get-field-count hrt)))
            (if (and (>= obj-choice 0) (<= obj-choice i-field-count))
              (begin
               (hfield-set! hrecord-printer 'i-cur-index obj-choice)
               (hfield-set! hrecord-printer 'obj-cur
                            (obj-ref obj-cur obj-choice))
               (hfield-set! hrecord-printer 's-mode
                            (get-mode (hfield-ref hrecord-printer 'obj-cur)))
               (hfield-set! hrecord-printer 's-output-mode 'data)
               (hfield-set! hrecord-printer 'l-stack
                            (cons (obj-ref obj-cur obj-choice)
                                  (hfield-ref hrecord-printer 'l-stack))))
              (begin
               (hfield-set! hrecord-printer 's-output-mode 'message)
               (hfield-set! hrecord-printer 'str-message
                            "index out of range")))))
         ((tto)
          (assert (is-target-object? obj-cur))
          (let* ((hrt (hrecord-type-of obj-cur))
                 (i-hr-field-count (hrecord-type-get-field-count hrt))
                 (tto-type (get-entity-type obj-cur))
                 (i-tto-field-count
                  (if (not (eq? (hfield-ref obj-cur 'al-field-values) #f))
                    (length (tno-field-ref tto-type 'l-all-fields))
                    0))
                 (i-field-count (+ i-hr-field-count i-tto-field-count)))
            (if (and (>= obj-choice 0) (<= obj-choice i-field-count))
              (let ((obj-result
                     (if (<= obj-choice i-hr-field-count)
                       (obj-ref obj-cur obj-choice)
                       (cdr (list-ref
                             (hfield-ref obj-cur 'al-field-values)
                             (- obj-choice (+ i-hr-field-count 1)))))))
                (begin
                 (hfield-set! hrecord-printer 'i-cur-index obj-choice)
                 (hfield-set! hrecord-printer 'obj-cur obj-result)
                 (hfield-set! hrecord-printer 's-mode
                              (get-mode obj-result))
                 (hfield-set! hrecord-printer 's-output-mode 'data)
                 (hfield-set! hrecord-printer 'l-stack
                              (cons obj-result
                                    (hfield-ref hrecord-printer 'l-stack)))))
              (begin
               (hfield-set! hrecord-printer 's-output-mode 'message)
               (hfield-set! hrecord-printer 'str-message
                            "index out of range")))))
         ((list)
          (assert (list? obj-cur))
          (let ((i-count (length obj-cur)))
            (if (and (>= obj-choice 0) (<= obj-choice i-count))
              (begin
               (hfield-set! hrecord-printer 'i-cur-index obj-choice)
               (hfield-set! hrecord-printer 'obj-cur
                            (list-ref obj-cur obj-choice))
               (hfield-set! hrecord-printer 's-mode
                            (get-mode (hfield-ref hrecord-printer 'obj-cur)))
               (hfield-set! hrecord-printer 's-output-mode 'data)
               (hfield-set! hrecord-printer 'l-stack
                            (cons (list-ref obj-cur obj-choice)
                                  (hfield-ref hrecord-printer 'l-stack))))
              (begin
               (hfield-set! hrecord-printer 's-output-mode 'message)
               (hfield-set! hrecord-printer 'str-message
                            "index out of range")))))
         ((pair)
          (assert (pair? obj-cur))
          (if (or (= obj-choice 0) (= obj-choice 1))
            (let ((obj-next (if (= obj-choice 0) (car obj-cur) (cdr obj-cur))))
              (hfield-set! hrecord-printer 'i-cur-index obj-choice)
              (hfield-set! hrecord-printer 'obj-cur obj-next)
              (hfield-set! hrecord-printer 's-mode
                           (get-mode obj-next))
              (hfield-set! hrecord-printer 's-output-mode 'data)
              (hfield-set! hrecord-printer 'l-stack
                           (cons obj-next
                                 (hfield-ref hrecord-printer 'l-stack))))
            (begin
             (hfield-set! hrecord-printer 's-output-mode 'message)
             (hfield-set! hrecord-printer 'str-message
                          "index out of range"))))
         (else
          (hfield-set! hrecord-printer 's-output-mode 'message)
          (hfield-set! hrecord-printer 'str-message
                       "improper command"))))
      ((eq? obj-choice 'x)
       (hfield-set! hrecord-printer 's-mode 'exit))
      ((eq? obj-choice 'u)
       (let ((l-stack (hfield-ref hrecord-printer 'l-stack)))
         (if (>= (length l-stack) 2)
           (let* ((l-new-stack (cdr l-stack))
                  (obj-next (car l-new-stack)))
             (hfield-set! hrecord-printer 'obj-cur obj-next)
             (hfield-set! hrecord-printer 'l-stack l-new-stack)
             (hfield-set! hrecord-printer 's-output-mode 'data)
             (hfield-set! hrecord-printer 's-mode
                          (get-mode obj-next)))
           (begin
            (hfield-set! hrecord-printer 's-output-mode 'message)
            (hfield-set! hrecord-printer 'str-message
                         "improper command")))))
      
      (else
       (hfield-set! hrecord-printer 's-output-mode 'message)
       (hfield-set! hrecord-printer 'str-message
                    "invalid command")))
    (cond
      ((eq? (hfield-ref hrecord-printer 's-mode) 'exit)
       (set! g (hfield-ref hrecord-printer 'obj-cur)))
      ((eq? (hfield-ref hrecord-printer 's-output-mode) 'message)
       (display (hfield-ref hrecord-printer 'str-message))
       (newline))
      ((eq? (hfield-ref hrecord-printer 's-output-mode) 'data)
       (print-data (hfield-ref hrecord-printer 'obj-cur)))
      (else
       (raise 'internal-error)))))


(define (phr-repl hrecord-printer)
  (do () ((eq? (hfield-ref hrecord-printer 's-mode) 'exit))
    (phr-rep hrecord-printer)))


(define (phr-int obj)
  (let* ((s-mode (if (hrecord? obj) 'hrecord 'simple))
         (hrecord-printer
          (make-hrecord <hrecord-printer> obj 0 s-mode '() '() "")))
    (hfield-set! hrecord-printer 'obj-cur obj)
    (hfield-set! hrecord-printer 's-mode
                 (get-mode obj))
    (hfield-set! hrecord-printer 'l-stack (list obj))
    (print-data obj)
    (phr-repl hrecord-printer)))
