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



;; *** Theme linker errors ***


(import (rnrs exceptions)
	(srfi srfi-35))


(define gl-error '())


(define (my-exit linker)
  (if (hfield-ref linker 'backtrace?)
      (raise 'error)
      (exit 1)))


(define (proc-inst-known? linker ent)
  (and
   (eq? ent
	(hfield-ref (hfield-ref linker 'binder-instantiation)
		    'expr-cur-proc))
   (not (null? (hfield-ref
		(hfield-ref linker 'binder-instantiation)
		's-cur-toplevel)))))

(define (get-proc-inst-str2 linker exc)
  (let ((expr (cdr (assq 'expr-appl (cdr exc)))))
    (if (not (proc-inst-known? linker expr))
	(let* ((l-arg-names (hfield-ref expr 'arg-names))
	       (l-str-arg-names (map symbol->string l-arg-names))
	       (str-args (join-strings-with-sep l-str-arg-names " "))
	       (to-result-type (hfield-ref expr 'result-type))
	       (str-result-type (target-object-as-string
				 to-result-type)))
	  (string-append
	   " while binding procedure with arguments ("
	   str-args
	   ") and result type "
	   str-result-type))
	"")))

(define (convert-string-list-to-string lst)
  (cond
   ((null? lst) "")
   ((null? (cdr lst)) (car lst))
   (else
    (string-append (car lst) " "
		   (convert-string-list-to-string (cdr lst))))))


(define (convert-module-to-text module)
  (cond
   ((list? module)
    (let ((strings (map symbol->string module)))
      (string-append "("
		     (convert-string-list-to-string strings)
		     ")")))
   ((symbol? module)
    (symbol->string module))
   (else "?")))
      


;; It is possible that we get non-symbol exceptions
;; from the system libraries.

(define (get-error-text linker exc)
  (let ((lst? (list? exc)))
    (cond
     ((eq? exc 'main-procedure-not-defined)
      "Main procedure not defined")
     ((symbol? exc)
      (string-append "Error " (symbol->string exc)))
     ((null? exc) "Error")
     ((not lst?) "Error")
     ((eq? (car exc) 'did-not-deduce-all-type-vars-2)
      (string-append "Failed to deduce all type variables in an application "
		     "of procedure "
		     (symbol->string (cadr exc))))
     ((eq? (car exc) 'type-mismatch-in-proc-appl)
      (if (not-null? (cadr exc))
	  (string-append "Argument type mismatch in an application "
			 "of procedure "
			 (symbol->string (cadr exc)))
	  "Argument type mismatch in an application of a procedure"))
     ((eq? (car exc) 'purity-mismatch)
      (string-append
       "Purity mismatch"
       (get-proc-inst-str2 linker exc)))
     ((eq? (car exc) 'return-attr-mismatch)
      (string-append
       "Return attribute mismatch"
       (get-proc-inst-str2 linker exc)))
     ((eq? (car exc) 'result-type-mismatch)
      (string-append
       "Result type mismatch"
       (get-proc-inst-str2 linker exc)))
     ((eq? (car exc) 'param-class-inst-error)
      (let* ((repr (list-ref exc 2))
	     (l-tvar-bindings (list-ref exc 3))
	     (str-pc-name (tno-field-ref (get-entity-type repr) 'str-name)))
	;;	   (l-tvar-values (map cdr l-tvar-bindings))
	;;	   (l-str-tvars (map get-class-name l-tvar-values))
	;;	   (str-tvar-list (join-strings-with-sep l-str-tvars " ")))
	(string-append
	 "Error instantiating parametrized class "
	 str-pc-name)))
     ((eq? (car exc) 'forward-definition-type-mismatch)
      (let* ((al-props (cdr exc))
	     (str-name (symbol->string (cdr (assq 's-name al-props))))
	     (str-module (symbol-list->string (cdr (assq 'module al-props)))))
	(string-append "Forward definition type mismatch with variable "
		       str-name
		       " in module "
		       str-module)))
     ((eq? (car exc) 'param-proc-inst:invalid-number-of-parameters)
      (let ((s-name (cadr exc))
	    (i-count (caddr exc)))
	(string-append "Invalid number of type parameters for "
		       (symbol->string s-name)
		       " ("
		       (number->string i-count)
		       ")")))
     ((eq? (car exc) 'variable-numbering-error)
      (let ((sym-source-name (cadr exc))
	    (i-number (caddr exc))
	    (x-module (cadddr exc)))
	(string-append
	 "Variable numbering error: ("
	 (symbol->string sym-source-name)
	 ", "
	 (number->string i-number)
	 ", "
	 (symbol-list->string x-module)
	 ")")))
     ((eq? (car exc) 'generic-static-dispatch-error-1)
      (let* ((gen-proc (cdr (assq 'gen-proc (cdr exc))))
	     (addr (hfield-ref gen-proc 'address)))
	(if (not-null? addr)
	    (string-append
	     "Error in the static dispatch of generic procedure "
	     (symbol->string (hfield-ref addr 'source-name)))
	    "Error in the static dispatch of a generic procedure")))
     ((eq? (car exc) 'let-variable-type-mismatch-1)
      (let ((s-name (cdr (assq 's-name (cdr exc)))))
	(string-append "Type mismatch in let variable "
		       (symbol->string s-name))))
     ((eq? (car exc) 'cyclic-prelink-dependency)
      (let ((x-name (cdr (assq 'module-name (cdr exc)))))
	(string-append "Cyclic prelink dependency with module "
		       (convert-module-to-text x-name)
		       ".")))
     ((eq? (car exc) 'static-cast-type-mismatch)
      "Type mismatch in a static cast")
     ((eq? (car exc) 'invalid-object-ref)
      (let* ((address (cdr (assq 'address (cdr exc))))
	     (s-source-name (hfield-ref address 'source-name)))
	(if (not-null? s-source-name)
	    (string-append "Invalid object reference to variable "
			   (symbol->string s-source-name)
			   " in module "
			   (convert-module-to-text
			    (hfield-ref address 'module)))
	    (string-append "Invalid object reference in module "
			   (convert-module-to-text
			    (hfield-ref address 'module))))))
     ((eq? (car exc) 'module-body-not-found)
      (let ((x-name (cdr (assq 'module-name (cdr exc)))))
	(string-append "Body for module "
		       (convert-module-to-text x-name)
		       " not found.")))
     (else
      (if (= (length exc) 1)
	  (if (symbol? (car exc))
	      (string-append "Error " (symbol->string (car exc)))
	      "?")
	  (if (symbol? (car exc))
	      (string-append "Error (" (symbol->string (car exc)) " ...)")
	      "?"))))))


(define (make-message . parts)
  (let ((actual-parts (filter (lambda (a) a) parts)))
    (convert-string-list-to-string actual-parts)))


(define (get-expr-text expr)
  (cond
   ((null? expr) #f)
   ((and (list? expr) (>= (length expr) 1))
    (symbol->string (car expr)))
   (else #f)))


(define (get-pcode-toplevel-expr-text expr)
  (cond
   ((null? expr) #f)
   ((and (list? expr) (>= (length expr) 1))
    (if (and (eq? (car expr) 'general-variable)
	     (>= (length expr) 2))
	(string-append "variable " (symbol->string (cadr expr)))
	(string-append "expression of type "
		       (symbol->string (car expr)))))
   (else #f)))


(define (get-instance-text instance)
  (case (car instance)
    ((class) "an instance of a parametrized class")
    ((ltype) "an instance of a parametrized logical type")
    ((proc) "an instance of a parametrized procedure")
    (else "?")))


(define (make-pcode-reading-error-message linker exc)
  (let ((error-text (get-error-text linker exc))
	(module (hfield-ref linker 'current-module))
	(expr (hfield-ref linker 'current-expr))
	(toplevel-expr (hfield-ref linker 'current-toplevel-expr)))
    (let* ((module-text
	   (if (not-null? module)
	       (string-append
		"from module "
		(convert-module-to-text module))
	       #f))
	  (whole-expr-text
	   (if (eqv? expr toplevel-expr)
	       (if (not-null? expr)
		   (let ((toplevel-expr-text
			  (get-pcode-toplevel-expr-text toplevel-expr)))
		     (if toplevel-expr-text
			 (string-append
			  "while reading toplevel "
			  toplevel-expr-text)
			 (if module-text "while reading" #f)))
		   (if module-text "while reading" #f))
	       (let ((expr-text (get-expr-text expr))
		     (toplevel-expr-text
		      (get-pcode-toplevel-expr-text toplevel-expr)))
		 (cond
		  ((and expr-text toplevel-expr-text)
		   (string-append
		    "while reading expression of type "
		    expr-text
		    " from toplevel "
		    toplevel-expr-text))
		  ((and (not expr-text) toplevel-expr-text)
		   (string-append
		    "while reading toplevel "
		    toplevel-expr-text))
		  ((and expr-text (not toplevel-expr-text))
		   (string-append
		    "while reading expression of type "
		    expr-text))
		  (else (if module-text "while reading" #f)))))))
      (string-append
       (make-message error-text whole-expr-text module-text) "."))))


;; Perhaps we should use word "translation" instead of
;; "compilation" here.
(define (make-target-compilation-error-message linker exc)
  (let ((error-text (get-error-text linker exc))
	(module (hfield-ref linker 'current-module))
	(repr (hfield-ref linker 'current-repr))
	(toplevel-repr (hfield-ref linker 'current-toplevel-repr)))
    (if (or
	 (eq? exc 'main-procedure-not-defined)
	 (and (list? exc)
	      (or
	       (eq? (car exc) 'cyclic-prelink-dependency)
	       (eq? (car exc) 'module-body-not-found))))
	error-text
	(let ((module-text
	       (if (not-null? module)
		   (string-append
		    "from module "
		    (convert-module-to-text module))
		   #f))
	      (whole-repr-text
	       (if (eqv? repr toplevel-repr)
		   (let ((toplevel-repr-text (get-repr-text toplevel-repr #t)))
		     (if toplevel-repr-text
			 (string-append
			  "while compiling "
			  toplevel-repr-text)
			 "while compiling"))
		   (let ((repr-text (get-repr-text repr #f))
			 (toplevel-repr-text (get-repr-text toplevel-repr #t)))
		     (cond
		      ((and repr-text toplevel-repr-text)
		       (string-append
			"while compiling "
			repr-text
			" from "
			toplevel-repr-text))
		      ((and (not repr-text) toplevel-repr-text)
		       (string-append
			"while compiling "
			toplevel-repr-text))
		      ((and repr-text (not toplevel-repr-text))
		       (string-append
			"while compiling "
			repr-text))
		      (else "during compilation"))))))
	  (string-append
	   (make-message error-text whole-repr-text module-text) ".")))))


(define (make-instantiation-error-message linker exc)
  "Error in parametrized entity instantiation.")
  ;; (let* ((module (hfield-ref linker 'current-module))
  ;; 	 (module-text (convert-module-to-text module))
  ;; 	 (toplevel-repr (hfield-ref linker 'current-toplevel-repr))
  ;; 	 (repr-text (get-repr-text toplevel-repr #t)))
    ;; (string-append
    ;;  "Error in instantiation of " toplevel-repr " in module "
    ;;  module-text ".")))


(define (make-coverage-error-message linker exc)
  "Error in coverage analysis.")


(define (make-instance-compilation-error-message linker exc)
  (let ((error-text (get-error-text linker exc))
	(module (hfield-ref linker 'current-module))
	(instance (hfield-ref linker 'current-instance))
	(toplevel-repr (hfield-ref linker 'current-toplevel-repr)))
    (let ((module-text
	   (if (not-null? module)
	       (string-append
		"from module "
		(convert-module-to-text module))
	       #f))
	  (whole-repr-text
	   (let ((instance-text (get-instance-text instance))
		 (toplevel-repr-text (get-repr-text toplevel-repr #t)))
	     (cond
	      ((and instance-text toplevel-repr-text)
	       (string-append
		"while compiling "
		instance-text
		" from "
		toplevel-repr-text))
	      ((and (not instance-text) toplevel-repr-text)
	       (string-append
		"while compiling parametrized object instance from"
		toplevel-repr-text))
	      ((and instance-text (not toplevel-repr-text))
	       (string-append
		"while compiling "
		instance-text))
	      (else "while compiling parametrized object instances")))))
      (string-append
       (make-message error-text " " whole-repr-text module-text) "."))))


(define (make-binding-error-message linker exc)
  (let* ((error-text (get-error-text linker exc))
	 (module (hfield-ref linker 'current-module))
	 (repr (hfield-ref linker 'current-repr-to-bind))
	 ;; We use the same field current-toplevel-repr
	 ;; for both target compilation and binding.
	 (toplevel-repr (hfield-ref linker 'current-toplevel-repr))
	 (while-text?
	  (not (and (list? exc)
		    (not-null? exc)
		    (memq (car exc)
			  '(proc-inst-error proc-appl-inst-error)))))
	 (str-while-text
	  (if while-text?
	      "while binding instances in "
	      "in ")))
    (let* ((module-text
	    (if (not-null? module)
		(string-append
		 "in module "
		 (convert-module-to-text module))
		#f))
	   (str-proc-text
	    (let ((s-cur (hfield-ref
		      (hfield-ref linker 'binder-instantiation)
		      's-cur-toplevel)))
	      (if (not (null? s-cur))
		  (string-append "in procedure " (symbol->string s-cur))
		  "")))
	   (whole-repr-text
	    (cond
	     ((not (string-null? str-proc-text))
	      str-proc-text)
	     ((eqv? repr toplevel-repr)
	      (let ((toplevel-repr-text (get-repr-text toplevel-repr #t)))
		(string-append
		 str-while-text
		 toplevel-repr-text)))
	     (else
	      (let* ((repr-text (get-repr-text repr #f))
		     (toplevel-repr-text
		      (get-repr-text toplevel-repr #t)))
		(cond
		 ((and repr-text toplevel-repr-text)
		  (string-append
		   str-while-text
		   repr-text
		   " arising from "
		   toplevel-repr-text))
		 ((and (not repr-text) toplevel-repr-text)
		  (string-append
		   (if while-text?
		       "while binding instances arising from "
		       "arising from ")
		   toplevel-repr-text))
		 ((and repr-text (not toplevel-repr-text))
		  (string-append
		   str-while-text
		   repr-text))
		 (else "while binding instances")))))))
      (string-append
       (make-message error-text whole-repr-text module-text) "."))))


(define (make-other-error-message linker exc)
  (string-append (get-error-text linker exc) "."))


(define (delete-target-files linker)
  (let ((interm-file (hfield-ref linker 'interm-file)))
    (if (not-null? interm-file)
	(guard
	 (exc1 (else #t))
	 (close-output-port interm-file))))
  (let ((filename (hfield-ref linker 'interm-filename)))
    (if (not (string-null? filename))
	(begin
	  (guard
	   (exc (else
		 (display "Error cleaning intermediate file.")
		 (newline)))
	   (if (file-exists? filename) (delete-file filename))))))
  (let ((filename (hfield-ref linker 'target-filename)))
    (if (not (string-null? filename))
	(begin
	  (guard
	   (exc (else
		 (display "Error cleaning target file.")
		 (newline)))
	   (if (file-exists? filename) (delete-file filename))))))
  (hfield-set! linker 'interm-filename "")
  (hfield-set! linker 'target-filename "")
  (hfield-set! linker 'interm-file '()))


(define (handle-linker-error linker exc)
  (delete-target-files linker)
  ;; (display "module: ")
  ;; (display (hfield-ref linker 'current-module))
  ;; (newline)
  ;; (display "expression: ")
  ;; (display (hfield-ref linker 'current-expr))
  ;; (newline)
  ;; (display "toplevel expression: ")
  ;; (display (hfield-ref linker 'current-toplevel-expr))
  ;; (newline)
  ;; (display (hfield-ref linker 'state))
  ;; (newline)
  (cond
   ((and (condition? exc) (theme-file-exception? exc))
    (display (get-file-error-message exc))
    (newline)
    (my-exit linker))
   ((and (list? exc)
	 (not-null? exc)
	 (or (memq (car exc) '(noncovariant-method-definition
			       noncovariant-method-declaration))))
    (display (get-noncov-method-error-text exc))
    (display ".")
    (newline)
    (my-exit linker))
   ((or (symbol? exc) (list? exc))
    (let ((message
	   (if (eqv? exc 'module-not-found)
	       (let ((module-name (hfield-ref linker 'current-module)))
		 (if (not-null? module-name)
		     (string-append
		      "Module "
		      (convert-module-to-text module-name)
		      " not found.")
		     "Module not found."))
	       (case (hfield-ref linker 'state)
		 ((pcode-reading)
		  (make-pcode-reading-error-message linker exc))
		 ((target-compilation)
		  (make-target-compilation-error-message linker exc))
		 ((final-compilation)
		  "Final compilation of the program failed.")
		 ((instantiation)
		  (set! gl-error exc)
		  (make-instantiation-error-message linker exc))
		 ((coverage-analysis)
		  (make-coverage-error-message linker exc))
		 ((instance-compilation)
		  (make-instance-compilation-error-message linker exc))
		 ((binding)
		  (make-binding-error-message linker exc))
		 ((() initial) (make-other-error-message linker exc))
		 (else
		  "Internal error in error handling.")))))
      (display message)
      (newline)
      (if (hfield-ref linker 'verbose-errors?)
	  (cond
	   ((and (list? exc) (> (length exc) 3)
		 (memq (car exc)
		       '(result-type-mismatch)))
	    (let* ((al-prop (drop exc 3))
		   (actual-type (cdr (assq 'actual-type al-prop)))
		   (declared-type (cdr (assq 'declared-type al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)))
	   ((and (list? exc) (>= (length exc) 2)
		 (eq? (car exc) 'type-mismatch-in-proc-appl))
	    (let* ((al-prop (drop exc 2))
		   (actual-type (cdr (assq 'actual-type al-prop)))
		   (declared-type (cdr (assq 'declared-type al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)))
	   ((and (list? exc) (>= (length exc) 6)
		 (eq? (car exc) 'did-not-deduce-all-type-vars-2))
	    (let* ((al-prop (drop exc 2))
		   (actual-type (cdr (assq 'actual-type al-prop)))
		   (declared-type (cdr (assq 'declared-type al-prop)))
		   (bindings (cdr (assq 'bindings al-prop)))
		   (l-needed (cdr (assq 'needed al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)
	      (display-bindings bindings)
	      (display "Needed type variables: ")
	      (display (target-object-as-string l-needed))
	      (newline)))
	   ((and (list? exc) (= (length exc) 3)
		 (eq? (car exc) 'generic-static-dispatch-error-1))
	    (let ((l-arg-types (cdr (assq 'arg-types (cdr exc)))))
	      (display "Argument types: ")
	      (display (target-object-as-string l-arg-types))
	      (newline)))
	   ((and (list? exc) (= (length exc) 4)
		 (eq? (car exc) 'let-variable-type-mismatch-1))
	    (let* ((al-prop (cdr exc))
		   (tt-expr (cdr (assq 'tt-expr al-prop)))
		   (tt-decl (cdr (assq 'tt-decl al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string tt-expr))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string tt-decl))
	      (newline)))
	   ((and (list? exc)
		 (eq? (car exc) 'forward-definition-type-mismatch))
	    (let* ((al-prop (cdr exc))
	   	   (tt-actual (cdr (assq 'tt-actual al-prop)))
	   	   (tt-declared (cdr (assq 'tt-declared al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string tt-actual))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string tt-declared))
	      (newline)))))
      (my-exit linker)))
   (else
    (raise exc))))
