
;;; minlog-mode.el - Minlog minor mode
;;          
;; Copyright (C) 2006 Stefan Schimanski <sts@1stein.org>

;; This file is not part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;

;;; Install:
;; 
;;  (require 'minlog-mode)

;;; Usage:
;;
;;  A new minor mode minlog-font-lock-mode is defined. You can toggle
;;  it by calling minlog-font-lock-mode.

;;; Code:

(require 'easy-mmode)

(defgroup minlog nil
  "Minlog minor mode"
  :group 'tools)

(defgroup minlog-faces nil
  "Minlog minor mode faces"
  :group 'minlog)

(defface minlog-default-face 
  '((((class color)) (:background "grey95")))
  "Face for a whole formula, term or type. By default it just sets the 
   background to a light blue"
  :group 'minlog-faces)

(defgroup minlog-formula-faces nil
  "Faces to color elements inside of formulas, terms and types"
  :group 'minlog-faces)

(defface minlog-all-face 
  '((((class color)) (:weight bold :foreground "brown" :height 1.5)))
  "Face for the all quantifier"
  :group 'minlog-formula-faces)

(defface minlog-ex-face 
  '((((class color)) (:weight bold :foreground "brown" :height 1.5)))
  "Face for minlog ex quantifier"
  :group 'minlog-formula-faces)

(defface minlog-allnc-face 
  '((((class color)) (:weight bold :foreground "sandy brown" :height 1.5)))
  "Face for the allnc quantifier"
  :group 'minlog-formula-faces)

(defface minlog-exnc-face 
  '((((class color)) (:weight bold :foreground "sandy brown" :height 1.5)))
  "Face for minlog exnc quantifier"
  :group 'minlog-formula-faces)

(defface minlog-exc-face 
  '((((class color)) (:weight bold :foreground "red" :height 1.5)))
  "Face for minlog exc quantifier"
  :group 'minlog-formula-faces)

(defface minlog-paren-face 
  '((((class color)) (:foreground "dark orange" :weight bold)))
  "Face for parentheses ( )"
  :group 'minlog-formula-faces)

(defface minlog-dot-face 
  '((((class color)) (:foreground "dark orange" :weight bold)))
  "Face for the dot \".\" in formulas"
  :group 'minlog-formula-faces)

(defface minlog-type-arrow-face 
  '((((class color)) (:foreground "dark green" :weight bold)))
  "Face for => arrow in types"
  :group 'minlog-formula-faces)

(defface minlog-implication-arrow-face 
  '((((class color)) (:foreground "black" :weight bold)))
  "Face for -> arrow in formulas"
  :group 'minlog-formula-faces)

(defface minlog-variable-id-face 
  '((((class color)) (:foreground "blue")))
  "Face for variable identifiers"
  :group 'minlog-formula-faces)

(defface minlog-type-id-face 
  '((((class color)) (:foreground "dark green")))
  "Face for type identifiers"
  :group 'minlog-formula-faces)

(defgroup minlog-output-faces nil
  "Faces to color elements of the output, i.e. inside of the *scheme* buffer"
  :group 'minlog-faces)

(defface minlog-output-formula-face 
  '((((class color)) (:background "grey95")))
  "Face for a whole formula in the scheme output"
  :group 'minlog-output-faces)

(defface minlog-output-semicolon-face
  '((((class color)) (:foreground "red")))
  "Face for the ; at the beginning of a line in the scheme output"
  :group 'minlog-output-faces)

(defface minlog-output-goal-face
  '((((class color)) (:foreground "black" :weight bold)))
  "Face for the goal identifier"
  :group 'minlog-output-faces)

(defface minlog-output-assumption-face
  '((((class color)) (:foreground "black" :weight bold)))
  "Face for the assumption identifier"
  :group 'minlog-output-faces)

(defface minlog-output-sorry-face
  '((((class color)) (:foreground "red" :weight bold :height 1.5)))
  "Face for lines lie \"Minlog sorry\""
  :group 'minlog-output-faces)

(defface minlog-output-ok-face
  '((((class color)) (:foreground "green" :weight bold)))
  "Face for lines like \"ok, ...\""
  :group 'minlog-output-faces)

(defface minlog-output-proof-finished-face
  '((((class color)) (:foreground "green" :weight bold :height 2.0)))
  "Face the \"Proof finished.\" line"
  :group 'minlog-output-faces)

(defface minlog-output-coq-line
  '((((class color)) (:foreground "black" :weight bold)))
  "Face for the line between assumptions and goal in coq output mode"
  :group 'minlog-output-faces)

(setq minlog-parse-prefix "\\(?:([ \t]*p[ytf]\\|parse-\\(?:type\\|formula\\|term\\)\\)[ \t]+\"")
(defvar minlog-font-lock-keywords
  (let ((formula-keywords 
         (lambda (pre post)
           (list
            `("\\b\\([a-zA-Z]+\\(?:_?[0-9]+\\)?\\)\\b" ,pre ,post (1 'minlog-variable-id-face prepend))
            `("\\bold\\(nat\\|rat\\|real\\|pos\\|int\\|list\\|tsil\\)\\b" ,pre ,post (1 'minlog-type-id-face prepend))
            `("\\ball\\b" ,pre ,post (0 'minlog-all-face prepend))
            `("\\ballnc\\b" ,pre ,post (0 'minlog-allnc-face prepend))
            `("\\bex\\b" ,pre ,post (0 'minlog-ex-face prepend))
            `("\\bexnc\\b" ,pre ,post (0 'minlog-exnc-face prepend))
            `("\\bexc\\b" ,pre ,post (0 'minlog-exc-face prepend))
            `("[()]" ,pre ,post (0 'minlog-paren-face prepend))
            `("\\." ,pre ,post (0 'minlog-dot-face prepend))
            `("=>" ,pre ,post (0 'minlog-type-arrow-face prepend))
            `("->" ,pre ,post (0 'minlog-implication-arrow-face prepend)))))
        (search-for-pre (lambda (start limit-regexp)
                          `(progn 
                             ,start
                             (let ((limit (min (+ (point) 10000) (point-max))))
                               (save-match-data
                                 (if (save-excursion (search-forward ,limit-regexp limit t))
                                     (match-beginning 0)
                                   limit))))
                          ))
	(prompt "^\\(?:\\(?:guile\\)?>[ \t]*\\)*"))
    (list
;;      ;; formulas in assumptions and goals
;;      (append
;;       (list 
;;        (lambda (limit)
;;          (let (
;;                ; some ">" followed by ";", then either >=3 spaces and "foo bar:" or "?_foo", finally :
;;                (start "^\\(?:\\(?:guile\\)?>[ \t]+\\)*;\\(?: \\?[^ \t:\n]*\\|   [^ \t\n:][^\t:\n]*\\):[ \t]*")

;;                ; follow ups of started formulas on new lines: >=5 leading spaces
;;                (indented-line "; \\{5,\\}")

;;                ; any text, followed by \n and >=5 spaces, repeated; finally one line
;;                (body "\\(\\(?:.*\n; \\{5,\\}.*\\)*.*?\\)")

;;                ; ending with $ or " from"
;;                (end "\\(?: from\\)?$"))
;;            ; are we on a start line or followup?
;;            (if (save-excursion 
;;                  (beginning-of-line) 
;;                  (or (looking-at indented-line)
;;                      (looking-at start)))
;;                (let ((start-point (point)))
;;                  ; yes => look backwards until we are on a start line
;;                  (beginning-of-line)
;;                  (while (and (looking-at indented-line)
;;                              (not (looking-at start))
;;                              (= (forward-line -1) 0)
;;                              (> (point) (point-min))) nil)
;;                  ; look for assumption or goal block
;;                  (if (re-search-forward (concat start body end) (min (point-max) (+ (point) 10000)) t)
;;                      ; fount => does it end after our original position?
;;                      (if (> (point) start-point)
;;                          ; yes => we found a formula to highlight
;;                          t
;;                        ; no => the formula found stops before are original 
;;                        ; position, i.e. it should have been highlighted already
;;                        ; Hence, go back there and look forward
;;                        (progn (goto-char start-point)
;;                               (re-search-forward (concat start body end) (min (point-max) (+ (point) 10000)) t)))
;;                    ; no => nothing to be found until limit
;;                    (progn (goto-char limit) nil)))
;;              ; no => look forward
;;              (re-search-forward (concat start body end) (min (point-max) (+ (point) 10000)) t))))
;;             '(1 'minlog-output-formula-face t))
;;       (funcall formula-keywords 
;;                '(progn (goto-char (match-beginning 1)) (match-end 1))
;;                '(progn (goto-char (match-end 0)))))

     ;; assumption
     (append
      (list (concat prompt ";   \\([^? \t][^\n:]*:\\)\\(.*\\)$")
	    '(1 'minlog-output-assumption-face prepend)
	    '(2 'minlog-output-formula-face prepend))
      (funcall formula-keywords '(goto-char (match-beginning 2)) 'nil))

     ;; goals
     (append
      (list (concat prompt "; \\(\\?_[0-9]+:\\)\\(.*?\\)\\( from$\\|$\\)")
	    '(1 'minlog-output-goal-face prepend)
	    '(2 'minlog-output-formula-face prepend))
      (funcall formula-keywords '(goto-char (match-beginning 2)) 'nil))

     ;; indented formula
     (append
      (list (concat prompt "; \\{5,\\}\\(.*\\)$")
	    '(1 'minlog-output-formula-face prepend))
      (funcall formula-keywords '(goto-char (match-beginning 1)) 'nil))

     ;; lines starting with some > and then a ;
     (let ((pre '(goto-char (match-beginning 1)))
           (post '(goto-char (match-end 0))))
       (list (concat prompt "\\(;\\) .*$") 
             ;; the ;
             '(1 'minlog-output-semicolon-face prepend)           

             ;; assumptions
;             `(";   \\([^? \t][^\n:]*:\\)" ,pre ,post (1 'minlog-output-assumption-face prepend))

             ;; goals
;             `("; \\(\\?_[0-9]+:\\)" ,pre ,post (1 'minlog-output-goal-face prepend))

             ;; indented formula
;             `("; \\{5,\\}\\(.*\\)$" ,pre ,post (1 'minlog-default-face prepend))

             ;; the magic sentence you are after
             `("Proof finished\\." ,pre ,post (0 'minlog-output-proof-finished-face prepend))

             ;; ok, ....
             `("; \\(ok\\)," ,pre ,post (1 'minlog-output-ok-face prepend))

             ;; Minlog "sorry"
             `("\\(Minlog \"sorry\"\\)" ,pre ,post (1 'minlog-output-sorry-face prepend))
       
             ;; lines from the coq output
             `("; \\(-----*\\) \\(\\?_[0-9]+\\)$" ,pre ,post 
               (1 'minlog-output-coq-line prepend)
               (2 'minlog-output-goal-face prepend))
       ))

     ;; expression like (pf "formula"), (pt "term"), (py "type")
     (append
      (list (concat minlog-parse-prefix "\\([^\"]*\\)\\(?:\"\\|$\\)")
            '(1 'minlog-default-face t))
      (funcall formula-keywords               
               (funcall search-for-pre '(goto-char (match-beginning 1)) "\"")
               nil))))
  "Faces to highlight minlog formulas")
;(makunbound 'minlog-font-lock-keywords)

(easy-mmode-define-minor-mode
 minlog-font-lock-mode
 "Highlight minlog formulas"
 nil
 " MinlogFontLock")

(defun minlog-font-lock-mode-on ()
  (font-lock-add-keywords nil minlog-font-lock-keywords)
  (setq font-lock-multiline t)
  (when font-lock-fontified (font-lock-fontify-buffer)))

(defun minlog-font-lock-mode-off ()
	    (font-lock-remove-keywords nil minlog-font-lock-keywords)
	    (when font-lock-fontified (font-lock-fontify-buffer)))

(add-hook 'minlog-font-lock-mode-on-hook 'minlog-font-lock-mode-on)
(add-hook 'minlog-font-lock-mode-off-hook 'minlog-font-lock-mode-off)

(provide 'minlog-mode)
