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


;; *** Common definitions for errors ***


(import (th-scheme-utilities stdutils))


(define gl-let-source-keywords
  (list
   (cons (list #f #f #f) skw-let-variables)
;;   (cons (list #f #f #t) skw-let*-variables)
   (cons (list #f #t #f) skw-letrec-variables)
   (cons (list #f #t #t) skw-letrec*-variables)
   (cons (list #t #f #f) skw-let)
;;   (cons (list #t #f #t) skw-let*)
   (cons (list #t #t #f) skw-letrec)
   (cons (list #t #t #t) skw-letrec*)))


(define (get-let-source-keyword let-repr)
  (assert (hrecord-is-instance? let-repr <let-expression>))
  (let* ((properties (list
		      (hfield-ref let-repr 'readonly-bindings?)
		      (hfield-ref let-repr 'recursive?)
		      (hfield-ref let-repr 'order?)))
	 (keyword-assoc
	  (assoc properties gl-let-source-keywords)))
    (assert (not (eqv? keyword-assoc #f)))
    (cdr keyword-assoc)))


(define (get-repr-text repr toplevel?)
  (let ((prefix (if toplevel? "toplevel " "")))
    (cond
     ((null? repr) #f)
     ((hrecord-is-instance? repr <prim-class-def>)
      (string-append prefix "definition of " (hfield-ref repr 'name)))
     ((hrecord-is-instance? repr <variable-definition>)
      (let ((var-name (hfield-ref
     		       (hfield-ref
     			(hfield-ref repr 'variable)
     			'address)
     		       'source-name)))
     	(cond
	 ((eqv? var-name '_main)
	  (string-append prefix "definition of main"))
	 ((not-null? var-name)
	  (string-append prefix
			 "definition of "
			 (symbol->string var-name)))
	 (else "definition of an unknown procedure"))))
     ((hrecord-is-instance? repr <let-expression>)
      (let ((prefix2 (if toplevel? prefix "a ")))
	(string-append prefix2
		       (symbol->string (get-let-source-keyword repr))
		       " expression")))
     ((hrecord-is-instance? repr <proc-appl>)
      (let ((proc
	     (if (hrecord-is-instance? repr <proc-appl>)
		 (hfield-ref repr 'proc)
		 '())))
	(if (and
	     (hrecord-is-instance? proc <variable-reference>)
	     (is-normal-variable? (hfield-ref proc 'variable)))
	    (let ((address (hfield-ref (hfield-ref proc 'variable) 'address)))
	      (if (not (eqv? (hfield-ref address 'module) #f))
		  (string-append
		   "an application of procedure "
		   (symbol->string
		    (get-var-orig-name (hfield-ref address 'source-name))))
		  "an application of a procedure generated in translation"))
	    "an application of a procedure")))
     (else
      (let ((name (hrecord-type-name-of repr)))
	(string-append prefix name))))))


(define (get-file-error-message file-exception)
  (assert (theme-file-exception? file-exception))
  (let ((error-type (condition-ref file-exception 'type))
	(file-name (condition-ref file-exception 'filename)))
    (let* ((error-text
	    (case error-type
	      ((error-opening-input-file) "Error opening input file")
	      ((error-reading-file) "Error reading file")
	      ((error-closing-input-file) "Error closing input file")
	      ((error-opening-output-file) "Error opening output file")
	      ((error-writing-file) "Error writing file")
	      ((error-closing-output-file) "Error closing output file")
	     (else "?"))))
      (if (string? file-name)
	  (string-append error-text " " file-name ".")
	  (string-append error-text ".")))))


(define (is-some-procedure-type? o)
  (or (is-tt-procedure? o) (is-tc-simple-proc? o) (is-tc-param-proc? o)))


(define (get-class-name o)
  (cond
   ((is-t-class? o) (tno-field-ref o 'str-name))
   ((is-t-type-variable? o)
    (symbol->string (hfield-ref (tno-field-ref o 'address) 'source-name)))
   (else "?")))


(define (get-noncov-method-error-text exc)
  (let* ((r-gen-proc (list-ref exc 1))
	 (r-method-type (list-ref exc 2)))
    (assert (is-t-gen-proc? r-gen-proc))
    (assert (is-some-procedure-type? r-method-type))
    (let* ((r-type
	    (if (is-tc-param-proc? r-method-type)
		(tno-field-ref r-method-type 'type-contents)
		r-method-type))
	   (str-name (tno-field-ref r-gen-proc 'str-name))
	   (o-arg-desc (tno-field-ref r-type 'type-arglist))
	   (type-result (tno-field-ref r-type 'type-result))
	   (l-arg-list (tuple-type->list-reject-cycles o-arg-desc))
	   (l-str-args (map target-object-as-string l-arg-list))
	   (str-arglist (join-strings-with-sep l-str-args " ")))
      (string-append
       "Error: Noncovariant or identical method ("
       str-name " " str-arglist ")"))))


(define (warning str-text)
  (display str-text)
  (newline))


(define (display-goops-warning target-name)
  (display "warning: multiple goops class definitions ")
  (display "for Scheme goops class ")
  (display target-name)
  (newline))


(define (display-prim-warning member-pred)
  (display "warning: multiple primitive class definitions ")
  (display "for Scheme predicate ")
  (display member-pred)
  (newline))


(define (get-proc-name repr)
  (if (not-null? (hfield-ref
		  (hfield-ref repr 'proc)
		  'address))
      (hfield-ref
       (hfield-ref (hfield-ref repr 'proc)
		   'address)
       'source-name)
      '()))


(define (display-bindings l-bindings)
  (display "Deduced type variables:")
  (newline)
  (for-each (lambda (binding)
	      (display "  ")
	      (display (target-object-as-string (car binding)))
	      (display " : ")
	      (display (target-object-as-string (cdr binding)))
	      (newline))
	    l-bindings))


