
;; Copyright (C) 2008 Tommi Höynälänmaa

;; Distributed under GNU Lesser General Public Licence version 3,
;; see file doc/LGPL-3.


(library (th-scheme-utilities hrecord)


  (export
   hrecord-error-info
   hrecord-type-empty
   hrecord-type
   hrecord-type?
   hrecord?
   hrecord-type-get-name
   hrecord-type-get-field-count
   hrecord-type-get-parent
   hrecord-type-get-fields
   hrecord-type-get-all-fields
   make-hrecord
   hfield-ref
   hfield-set!
   hrecord-type-of
   hrecord-type=?
   hrecord=?
   hrecord-is-direct-instance?
   hrecord-type-is-subtype?
   hrecord-is-instance0?
   hrecord-is-instance?
   make-hrecord-type
   hrecord-type-name-of
   get-hrecord-type-predicate0
   get-hrecord-type-predicate
   define-hrecord-type)


  (import (guile)
	  (rnrs base)
	  (th-scheme-utilities stdutils))


  (define hrecord-error-info '())


  (define hrecord-type-empty
    (vector
     #f
     "hrecord-type-empty"
     0
     '()
     '()
     '()))


  (define hrecord-type-fields
    (list 'name 'n-all-fields 'parent 'fields 'all-fields))


  (define hrecord-type
    (vector
     #f
     "hrecord-type"
     5
     hrecord-type-empty
     hrecord-type-fields
     hrecord-type-fields))


  (vector-set! hrecord-type-empty 0 hrecord-type)

  (vector-set! hrecord-type 0 #t)


  (define (%make-hrecord-type-raw name n-all-fields parent fields all-fields)
    (vector
     hrecord-type
     name
     n-all-fields
     parent
     fields
     all-fields))


  (define (hrecord-type? obj)
    (and (vector? obj)
	 (>= (vector-length obj) 6)
	 (let ((type (vector-ref obj 0)))
	   (eq? type hrecord-type))))


  (define (hrecord? obj)
    (and (vector? obj)
	 (>= (vector-length obj) 1)
	 (hrecord-type? (vector-ref obj 0))))


  (define (hrecord-type-get-name hrt)
    (assert (hrecord-type? hrt))
    (vector-ref hrt 1))


  (define (hrecord-type-get-field-count hrt)
    (assert (hrecord-type? hrt))
    (vector-ref hrt 2))


  (define (hrecord-type-get-parent hrt)
    (assert (hrecord-type? hrt))
    (vector-ref hrt 3))


  (define (hrecord-type-get-fields hrt)
    (assert (hrecord-type? hrt))
    (vector-ref hrt 4))


  (define (hrecord-type-get-all-fields hrt)
    (assert (hrecord-type? hrt))
    (vector-ref hrt 5))


  (define (%make-hrecord-type name parent fields)
    (let* ((n-len (length fields))
	   (parent-fields
	    (if (null? parent) '() (hrecord-type-get-all-fields parent)))
	   (n-totallen 
	    (if (null? parent)
		n-len
		(+ (length parent-fields) n-len)))
	   (all-fields (append parent-fields fields)))
      (%make-hrecord-type-raw name n-totallen parent fields all-fields)))


  (define gl-dbg-counter 0)
  
  (define (make-hrecord hrt . initargs)
    (assert (hrecord-type? hrt))
    (let ((n-initargs (length initargs)))
      (if (= n-initargs (hrecord-type-get-field-count hrt))
	  (let ((result (list->vector (cons hrt initargs))))

	    ;; TBR!!!
	    ;; (if (string=? (hrecord-type-get-name hrt) "<proc-appl>")
	    ;; 	(begin
	    ;; 	  (display "make <proc-appl> ")
	    ;; 	  (display gl-dbg-counter)
	    ;; 	  (display " ")
	    ;; 	  (display (object-address result))
	    ;; 	  ;; (if (= gl-dbg-counter 5447)
	    ;; 	  ;;     (begin
	    ;; 	  ;; 	(backtrace #f)
	    ;; 	  ;; 	(raise 'stop5447)))
	    ;; 	  (set! gl-dbg-counter (+ gl-dbg-counter 1))
	    ;; 	  (newline)))
    
	    result)
	  (begin
	    (write-line (hrecord-type-get-name hrt))
	    (write-line n-initargs)
	    (raise 'hrecord-wrong-number-of-args)))))


  ;; No checks here.
  (define (%get-field-index hr field)
    (let ((hrt (vector-ref hr 0)))
      (search field (hrecord-type-get-all-fields hrt))))


  (define (hfield-ref hr field)
    (assert (hrecord? hr))
    (assert (symbol? field))
    (let ((i (%get-field-index hr field)))
      (if (>= i 0)
	  (vector-ref hr (+ i 1))
	  (begin
	    (set! hrecord-error-info hr)
	    (display field)
	    (newline)
	    (raise 'hrecord-nonexistent-field-ref)))))


  (define (hfield-set! hr field x)
    (assert (hrecord? hr))
    (assert (symbol? field))
    (let ((i (%get-field-index hr field)))
      (if (>= i 0)
	  (vector-set! hr (+ i 1) x)
	  (begin
	    (set! hrecord-error-info hr)
	    (display field)
	    (newline)
	    (raise 'hrecord-nonexistent-field-set)))))


  (define (hrecord-type-of hr)
    (assert (hrecord? hr))
    (let ((result (vector-ref hr 0)))
      (if (eq? result #t) hrecord-type result)))


  (define hrecord-type=? eq?)


  (define hrecord=? eq?)


  (define (hrecord-is-direct-instance? hr hrt)
    (assert (hrecord? hr))
    (assert (hrecord-type? hrt))
    (hrecord-type=? (hrecord-type-of hr) hrt))


  (define (hrecord-type-is-subtype? hrt1 hrt2)
    (assert (hrecord-type? hrt1))
    (assert (hrecord-type? hrt2))
    (if (hrecord-type=? hrt1 hrt2)
	#t
	(let ((hrt-parent (hrecord-type-get-parent hrt1)))
	  (if (null? hrt-parent)
	      #f
	      (hrecord-type-is-subtype? hrt-parent hrt2)))))


  (define (hrecord-is-instance0? hr hrt)
    (assert (hrecord? hr))
    (assert (hrecord-type? hrt))
    (hrecord-type-is-subtype?
     (hrecord-type-of hr) hrt))


  (define (hrecord-is-instance? hr hrt)
    (assert (hrecord-type? hrt))
    (and (hrecord? hr) (hrecord-type-is-subtype? (hrecord-type-of hr) hrt)))


  (define (make-hrecord-type name parent fields)
    (%make-hrecord-type name
			(if (null? parent) hrecord-type-empty parent)
			fields))


  (define (hrecord-type-name-of hr)
    (assert (hrecord? hr))
    (hrecord-type-get-name (hrecord-type-of hr)))


  (define (get-hrecord-type-predicate0 type)
    (lambda (obj) (hrecord-is-instance0? obj type)))


  (define (get-hrecord-type-predicate type)
    (lambda (obj) (hrecord-is-instance? obj type)))


  (define-syntax define-hrecord-type
    (syntax-rules ()
      ((define-hrecord-type name ())
       (define name (make-hrecord-type
		     (symbol->string 'name) '() '())))
      ((define-hrecord-type name () field1 ...)
       (define name
	 (make-hrecord-type (symbol->string 'name)
			    '() '(field1 ...))))
      ((define-hrecord-type name (parent))
       (define name (make-hrecord-type
		     (symbol->string 'name) parent '())))
      ((define-hrecord-type name (parent) field1 ...)
       (define name
	 (make-hrecord-type (symbol->string 'name)
			    parent '(field1 ...)))))))
