;;; Interface to SWI-Prolog
;;; Author: Jan Wielemaker, SWI, University of Amsterdam
;;; E-mail: jan@swi.psy.uva.nl

;;; This package forms a layer around the Quintus-Prolog interface.  It
;;; should be used together with the Prolog library 'emacs_interface.pl'.

;;; It implements hooks that allow SWI-Prolog to give compilation-warnings
;;; back to EMACS, so the user can step through them using the normal
;;; ^X` command

;;; Usage:
;;;
;;;     Put the following lines in your ~/.emacs:
;;;
;;;	(autoload 'run-prolog "swi-prolog" "Run an inferior prolog process" t)
;;;	(autoload 'prolog-mode "swi-prolog" "SWI-Prolog mode" t)

;;; Notes:
;;;
;;; As far as I was able to figure out, the Quintus Prolog GNU-Emacs lisp
;;; interface can be distributed under the normal GNU general public licence
;;;
;;; This file is distributed confirm the GNU general public licence.


(defconst qplisp-directory "/usr/local/Emacs19/lib/emacs/site-lisp/qplisp"
  "Directory with all the quintus interface files")
(defvar run-prolog-command "pl"
  "Command to start SWI-Prolog")
(defconst prolog-warning-buffer "*compilation*"
  "SWI-Prolog buffer for warnings")

;;; Get the Quintus EMACS library in your load path

(setq load-path (cons qplisp-directory load-path))
(load-library "qprolog-mode")

;;; "compile.el" that comes with Emacs19 does not seem to work very well.
;;; Especially, error messages are not parsed correctly. It might be the
;;; case that errors are treated somewhat differently in Emacs19. Jan?
;;;
(load-library "compile18")

(setq prolog-prompt-pattern "^[0-9]+ \\?- ")


;;; Prolog Mode popup windows (Manfred Aben)
;;;

(require 'easymenu)

(defvar prolog-menu nil
  "Popup menu with the available commands for SWI-prolog mode")

(setq prolog-menu
      '("Prolog"
	["Start SWI-Prolog" 		run-prolog 			t]
	["Interrupt Prolog" 		interrupt-prolog 		t]
	" "
	["Consult this file"  	       	prolog-compile-buffer-only	t]
	["Reconsult modified files"    	prolog-recompile 	        t]
	"  "
	["Go to next error" 	       	next-error 			t]
	"   "
	["Previous query"		prolog-previous-command 	t]
	["Next query" 			prolog-next-command 		t]
	"    "
	["Find source file of this term" find-definition       		t]
	["Find other source files"     	find-more-definition 		t]
	"     "
	["Select clause" 		mark-clause 		        t]
	["Delete clause" 		kill-clause 			t]
	["Indent clause" 		prolog-indent-clause 		t]
	))


(or (fboundp 'old-prolog-mode)
    (fset 'old-prolog-mode
	  (symbol-function 'prolog-mode)))

(defun prolog-mode ()
  "Major mode for editing files of prolog code.
 The following commands are available:
\\{prolog-mode-map}."
  (interactive)
  ;;; HACK; Q-prolog-mode complains about "mark not active"
  (set-mark (beginning-of-buffer))
  (old-prolog-mode)
  (easy-menu-define menu-bar-swi-prolog1-commands
      prolog-mode-map
      "SWI-Prolog mode commands"
    prolog-menu))

(defun prolog-compilation-start (dir)
  "Clear *compilation* buffer"
  (save-excursion
    (set-buffer (get-buffer-create prolog-warning-buffer))
    (erase-buffer)
    (setq default-directory dir)
    (compilation-forget-errors)
    (setq compilation-error-list t)
    (setq compilation-error-message "No more SWI-Prolog errors")
    (insert "cd " dir)
    (newline)
    (insert "SWI-Prolog warnings")
    (newline)))


(defun prolog-compilation-finish ()
  "Finish prolog-compilation"
  (save-excursion
    (set-buffer prolog-warning-buffer)
    (end-of-buffer)
    (newline 2)
    (insert "Compilation finished at " (current-time-string))
    (newline)
    (setq compilation-parsing-end 1)))


(defun prolog-compilation-warning (file line msg)
  "Put a prolog error-message in *compilation*"
  (save-excursion
    (set-buffer prolog-warning-buffer)
    (end-of-buffer)
    (display-buffer (current-buffer))
    (insert file ":" line ": " msg)
    (newline)))


;;; STARTING PROLOG
;;; This function is a modified version of run-prolog in qprolog-mode.el

(defun run-prolog (command)
  "Run an inferior SWI-Prolog process, input and output via buffer
*prolog*."
  (interactive (list (read-string "Run prolog: " run-prolog-command)))
  (setq run-prolog-command command)
  (ensure-prolog-syntax)
  (qprequire 'shell)
  (get-prolog-exec-and-flags (concat command startup-jcl))
  (switch-to-buffer-other-window (apply 'make-comint "prolog"
					*prolog-executable* nil  
					*prolog-flags*))
  (set-process-filter (get-process "prolog") 'prolog-process-filter)
  (sleep-for 2)
  (inferior-prolog-mode)
  (local-set-key "\t" 'prolog-dabbrev-atom)
  (local-set-key "\C-d" 'prolog-complete-atom)
  (local-set-key "\C-c\C-n" 'prolog-next-command)
  (local-set-key "\C-c\C-p" 'prolog-previous-command)
  
  (easy-menu-define menu-bar-swi-prolog2-commands
      inferior-prolog-mode-map
      "SWI-Prolog mode commands"
    prolog-menu))

;;; ATOM COMPLETION

(defvar *prolog-start-completion* nil
  "Start of prolog completion")
(defvar *prolog-end-completion* nil
  "End of prolog completion")
(defvar *prolog-atom-completions* nil
  "Collect-list for prolog completions")
(defvar *prolog-completion-process-mark* nil
  "Process mark when starting completion")

(defun prolog-completion-backward-word ()
  (interactive)
  (backward-word 1)
  (backward-char 1)
  (if (looking-at "_")
      (prolog-completion-backward-word)
      (forward-char 1)))


(defun prolog-completion-sofar ()
  (setq *prolog-end-completion* (point))
  (let ((end (point)))
    (save-excursion
      (backward-char 1)
      (cond ((looking-at "[a-zA-Z0-9_]\\b")
	     (prolog-completion-backward-word)
	     (setq *prolog-start-completion* (point))
	     (setq *prolog-completion-process-mark*
		   (marker-position (process-mark
				     (get-buffer-process "*prolog*"))))
	     (buffer-substring (point) end))
	    (t nil)))))

(defun prolog-complete-atom-with (extended unique)
  (cond ((eq *prolog-end-completion* (point))
	 (kill-region *prolog-start-completion* *prolog-end-completion*)
	 (insert extended)
	 (setq *saved-prolog-process-mark* *prolog-completion-process-mark*)
	 (if (not unique) (message "[incomplete]")))
	(t
	 (prolog-completion-error-message "Mismatch of dabbrev-point"))))

(defun prolog-completion-error-message (string)
  (message string)
  (setq *saved-prolog-process-mark* *prolog-completion-process-mark*))

;;; DABBREV

(defun prolog-dabbrev-atom ()
  (interactive)
  (let (sofar)
    (cond ((setq sofar (prolog-completion-sofar))
	   (send-prolog (concat 
			 "'$silent'(emacs_dabbrev_atom(\""
			 sofar
			 "\"))")))
	  (t
	   (message "Point not at end of atom")))))

;;; COMPLETION

(defun prolog-complete-atom ()
  (interactive)
  (let (sofar)
    (cond ((setq sofar (prolog-completion-sofar))
	   (send-prolog (concat
			 "'$silent'(emacs_complete_atom(\""
			 sofar
			 "\"))")))
	  (t
	   (message "Point not at end of atom")))))
		
(defun prolog-completions-start-collect ()
  (setq *prolog-atom-completions* nil))

(defun prolog-transfer-completion (atom number)
  (setq *prolog-atom-completions*
	(cons (list atom number)
	      *prolog-atom-completions*)))

(defun prolog-completions-run (sofar)
  (prolog-complete-atom-with
   (completing-read "Complete atom: "
		    *prolog-atom-completions*
		    nil
		    nil
		    sofar)
   t))
  
;;; HISTORY

(defun prolog-previous-command ()
  (interactive)
  (end-of-buffer)
  (setq *prolog-completion-process-mark*
	(marker-position (process-mark (get-buffer-process "*prolog*"))))
  (send-prolog "'$silent'(emacs_previous_command)"))


(defun prolog-next-command ()
  (interactive)
  (end-of-buffer)
  (setq *prolog-completion-process-mark*
	(marker-position (process-mark (get-buffer-process "*prolog*"))))
  (send-prolog "'$silent'(emacs_next_command)"))


(defun prolog-insert-history-command (cmd)
  (kill-region *prolog-completion-process-mark* (point))
  (insert cmd ".")
  (setq *saved-prolog-process-mark* *prolog-completion-process-mark*))


;;; COMPILATION

(defun prolog-recompile ()
  (interactive)
  (save-some-buffers)
  (if (not (eq (current-buffer) (get-buffer "*prolog*")))
      (pop-to-buffer (get-buffer "*prolog*") nil))
  (end-of-buffer)
  (insert "make.\n")
  (send-prolog "make"))

(defun prolog-compile-buffer-only ()
  "to avoid complications with compile-region and compile-predicate"
  (interactive)
  (let* ((file-name (buffer-file-name))
	 (command (concat "['" file-name "']")))
    (if (eq (current-buffer) (get-buffer "*prolog*"))
	(error "Cannot compile *prolog* buffer!")
      (save-some-buffers)
      (pop-to-buffer (get-buffer "*prolog*") nil)
      (end-of-buffer)
      (insert command)
      (insert ".\n")
      (send-prolog command))))

;;; Show SWI prolog help info in separate window
(defun prolog-help (filename from to)
  (find-file-other-window filename)
  (widen)
  (narrow-to-region from to))