;;; This file contains general error handling routines.
 
 ;;; This is the general error handler.  It has three arguments: an
 ;;; id, error type, and an error message.  The message is a list of
 ;;; format, arglist combinations.
 
 ;;; The error types are:
 ;;;   warning       -> control returns and compilation proceeds
 ;;;                    The message may be suppressed
 ;;;   recoverable   -> control returns and compilation proceeds
 ;;;   phase         -> control returns but compilation is aborted
 ;;;                         after the phase in *abort-point*.
 ;;;   fatal         -> control goes back to the top level
 ;;;   internal      -> enters the break loop or does a fatal error
 
 ;;; Two globals control error behavior:
 ;;;   *break-on-error?* enter the break loop on any error
 ;;;   *never-break?* never enter the break loop, even for internal errors.
 
 ;;; The global *error-output-port* controls where errors are printer.
 
 ;;; The strategy here is to first write a banner message based on the id and
 ;;; type, write out the messages, and then take action depending on the type.
 
 (define *in-error-handler?* '#f)
 
 (define (haskell-error id type messages)
   (format *error-output-port* "~&[~A] ~A in phase ~A:~%"
 	  id (err-type->banner type) (dynamic *phase*))
   (dolist (m messages)
     (apply (function format) *error-output-port* m)
     (fresh-line *error-output-port*))
   (maybe-show-context (dynamic *context*))
   (if (dynamic *in-error-handler?*)
       (error "Recursive error in haskell-error.")
       (begin
         (dynamic-let ((*in-error-handler?*  '#t))
 	  (cond (*break-on-error?*
 		 (haskell-breakpoint))
 		((eq? type 'internal)
 		 (if *never-break?*
 		     (abort-compilation)
 		     (haskell-breakpoint)))
 		((eq? type 'fatal)
 		 (abort-compilation))
 		((eq? type 'phase)
 		 (halt-compilation))))
 	(when (and (memq type '(recoverable phase))
 		   (dynamic *recoverable-error-handler*))
 	  (funcall (dynamic *recoverable-error-handler*)))
 	'ok)))
 
 (define (err-type->banner err-type)
   (cond ((eq? err-type 'warning)
 	 "Warning")
 	((eq? err-type 'recoverable)
 	 "Recoverable error")
 	((eq? err-type 'phase)
 	 "Phase error")
 	((eq? err-type 'fatal)
 	 "Fatal error")	
 	((eq? err-type 'internal)
 	 "Internal-error")
 	(else "???")))
 
 (define (maybe-show-context context)
   (when context
     (with-slots source-pointer (line file) (ast-node-line-number context)
       (fresh-line *error-output-port*)
       (format *error-output-port* "Error occurred at line ~A in file ~A.~%"
          line (filename-name file)))))
 
 ;;; A few entry points into the error system.
 ;;; As a matter of convention, there should be a signaling function defined
 ;;; for each specific error condition that calls one of these functions.
 ;;; Error messages should be complete sentences with proper punctuation
 ;;; and capitalization.  The signaling function should use the message
 ;;; to report the error and not do any printing of its own.
 
 (define (fatal-error id . msg)
  (haskell-error id 'fatal (list msg)))
 
 (define (haskell-warning id . msg)
  (haskell-error id 'warning (list msg)))
 
 (define (recoverable-error id . msg)
  (haskell-error id 'recoverable (list msg)))
 
 (define (compiler-error id . msg)
  (haskell-error id 'internal (list msg)))
 
 (define (phase-error id . msg)
  (haskell-error id 'phase (list msg)))
 
 ;;; This function puts the compiler into the lisp breakloop.  this may
 ;;; want to fiddle the programming envoronment someday.
 
 (define (haskell-breakpoint)
  (error "Haskell breakpoint."))
 
 
 ;;; This deals with error at runtime
 
 (define (haskell-runtime-error msg)
   (format '#t "~&Haskell runtime abort.~%~A~%" msg)
   (funcall (dynamic *runtime-abort*)))
 
 ;; Some common error handlers
 
 (define (signal-unknown-file-type filename)
   (fatal-error 'unknown-file-type
     "The filename ~a has an unknown file type."
     filename))
 
 (define (signal-file-not-found filename)
   (fatal-error 'file-not-found
     "The file ~a doesn't exist."
     filename))