;;;; -*- Mode: Lisp; lexical-binding: t; -*-
;;;; web68.el --- major mode for editing Web 68 source
;;;; This file contains Web 68 mode.
;;;; It is used to colourise Web 68 and Algol 68 files.
;;;; Copyright (C) 2014 Sian Mountbatten
;;;; Author: Sian Mountbatten <mountbatten@poenikatu.co.uk>
;;;; Keywords: languages

(defgroup web68 nil
  "Major mode for editing Web 68/Algol 68 source in Emacs."
  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
  :group 'languages)

(defvar web68-mode-abbrev-table nil
  "Abbrev table in use in Web68 mode buffers.")
(define-abbrev-table 'web68-mode-abbrev-table ())

(defvar web68-mode-map
  (let ((map (make-sparse-keymap)))
    map)
  "Keymap used in Web68 mode.")

(defvar web68-imenu-generic-expression
  '((nil "^[ \t]*\\(PROC\\|OP\\)[ \t\n]+\\([a-zA-Z0-9_.:]+\\)" 2))
  "Imenu expression for Web68 mode. See `imenu-generic-expression'.")

(defvar web68-mode-syntax-table
  (let ((st (make-syntax-table)))
    (modify-syntax-entry ?\( "()" st)
    (modify-syntax-entry ?\) ")(" st)
    (modify-syntax-entry ?#  "$"  st)
    (modify-syntax-entry ?{  "<"  st)
    (modify-syntax-entry ?}  ">"  st)
    (modify-syntax-entry ?$  "$"  st)
    (modify-syntax-entry ?_  "_"  st)
    st)
  "Syntax table in use in Web68-mode buffers.")
    
;;; Define the font lock colours
(defface *web68-grey*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "#808080"))
  "Used for Web 68 text."
  :group 'web68)

(defface *web68-red*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "red"))
  "Used for numbers."
  :group 'web68)

(defface *web68-darkcyan*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "darkCyan"))
  "Used for punctuation."
  :group 'web68)

(defface *web68-yellow*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "yellow"))
  "Used for strings."
  :group 'web68)

(defface *web68-brown*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "brown"))
  "Used for comments."
  :group 'web68)

(defface *web68-magenta*
    '((((class color) (min-colors 88) (background dark))
       ;.
     :background "black" :foreground "magenta"))
  "Used for operators."
  :group 'web68)

(defface *web68-green*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "green"))
  "Used for dates/delimited text."
  :group 'web68)

(defface *web68-cyan*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "cyan"))
  "Used for Algol 68 modes and Web 68 commands."
  :group 'web68)

(defface *web68-blue*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "skyblue"))
  "Used for identifiers."
  :group 'web68)

(defface *web68-white*
    '((((class color) (min-colors 88) (background dark))
       ;.
       :background "black" :foreground "white"))
  "Used for bold tags."
  :group 'web68)

;;;; The next data structure is used to identify a bold tag.
;;;; The length of the tag determines which sorted list is used.
;;;; The `chop' function then finds the actual position of the
;;;; bold tag and, consequently, its face property.
;;;;
;;;; Define which face is used for each bold tag
(defconst *web68-bold-tags*
  '(nil
    (("I" *web68-magenta*))         ; length 1
    (("AT" *web68-white*)           ; length 2
     ("BY" *web68-white*)
     ("CO" *web68-white*)
     ("DO" *web68-white*)
     ("EQ" *web68-magenta*)
     ("FI" *web68-white*)
     ("GE" *web68-magenta*)
     ("GT" *web68-magenta*)
     ("IF" *web68-white*)
     ("IM" *web68-magenta*)
     ("IN" *web68-white*)
     ("IS" *web68-white*)
     ("LE" *web68-magenta*)
     ("LT" *web68-magenta*)
     ("NE" *web68-magenta*)
     ("OD" *web68-white*)
     ("OF" *web68-white*)
     ("OP" *web68-white*)
     ("OR" *web68-magenta*)
     ("RE" *web68-magenta*)
     ("TO" *web68-white*)
     ("UP" *web68-magenta*))
    (("ABS" *web68-magenta*)        ; length 3
     ("AND" *web68-magenta*)
     ("BIN" *web68-magenta*)
     ("DIV" *web68-magenta*)
     ("END" *web68-white*)
     ("FOR" *web68-white*)
     ("INT" *web68-cyan*)
     ("LOC" *web68-cyan*)
     ("LWB" *web68-magenta*)
     ("MOD" *web68-magenta*)
     ("NIL" *web68-red*)
     ("NOT" *web68-magenta*)
     ("OUT" *web68-white*)
     ("REF" *web68-cyan*)
     ("SHL" *web68-magenta*)
     ("SHR" *web68-magenta*)
     ("UPB" *web68-magenta*)
     ("USE" *web68-white*))
    (("BITS" *web68-cyan*)          ; length 4
     ("BOOL" *web68-cyan*)
     ("CASE" *web68-white*)
     ("CHAR" *web68-cyan*)
     ("CONJ" *web68-magenta*)
     ("DECS" *web68-white*)
     ("DOWN" *web68-magenta*)
     ("ELEM" *web68-magenta*)
     ("ELIF" *web68-white*)
     ("ELSE" *web68-white*)
     ("ESAC" *web68-white*)
     ("EXIT" *web68-white*)
     ("FILE" *web68-cyan*)
     ("FLEX" *web68-cyan*)
     ("FROM" *web68-white*)
     ("GOTO" *web68-white*)
     ("HEAP" *web68-cyan*)
     ("ISNT" *web68-white*)
     ("KEEP" *web68-white*)
     ("LONG" *web68-cyan*)
     ("MODE" *web68-white*)
     ("OUSE" *web68-white*)
     ("OVER" *web68-magenta*)
     ("PRIO" *web68-white*)
     ("PROC" *web68-cyan*)
     ("REAL" *web68-cyan*)
     ("REPR" *web68-magenta*)
     ("SKIP" *web68-white*)
     ("THEN" *web68-white*)
     ("TRUE" *web68-red*)
     ("VOID" *web68-cyan*))
    (("BEGIN" *web68-white*)        ; length 5
     ("COMPL" *web68-cyan*)
     ("DIVAB" *web68-magenta*)
     ("EMPTY" *web68-red*)
     ("FALSE" *web68-red*)
     ("MODAB" *web68-magenta*)
     ("SHORT" *web68-cyan*)
     ("UNION" *web68-cyan*)
     ("WHILE" *web68-white*))
    (("ENTIER" *web68-magenta*)     ; length 6
     ("FINISH" *web68-white*)
     ("OVERAB" *web68-magenta*)
     ("PLUSAB" *web68-magenta*)
     ("PLUSTO" *web68-magenta*)
     ("STRING" *web68-cyan*)
     ("STRUCT" *web68-cyan*))
    (("CHANNEL" *web68-cyan*)       ; length 7
     ("CONTEXT" *web68-white*)
     ("MINUSAB" *web68-magenta*)
     ("PROGRAM" *web68-white*)
     ("TIMESAB" *web68-magenta*))))

(setq *web68-font-lock-keywords*
  (let ((ops "\\<\\(A\\(?:BS\\|ND\\)\\|BIN\\|CONJ\\|D\\(?:IV\\(?:AB\\)?\\|OWN\\)\\|E\\(?:LEM\\|NTIER\\|Q\\)\\|G[ET]\\|IM?\\|L\\(?:WB\\|[ET]\\)\\|M\\(?:INUSAB\\|OD\\(?:AB\\)?\\)\\|N\\(?:E\\|OT\\)\\|O\\(?:R\\|VER\\(?:AB\\)?\\)\\|PLUS\\(?:AB\\|TO\\)\\|RE\\(?:PR\\)?\\|SH[LR]\\|TIMESAB\\|UPB?\\)\\>")
        (bold-tags "\\<\\(AT\\|B\\(?:EGIN\\|Y\\)\\|C\\(?:ASE\\|ONTEXT\\)\\|D\\(?:ECS\\|O\\)\\|E\\(?:L\\(?:IF\\|SE\\)\\|ND\\|SAC\\|XIT\\)\\|F\\(?:I\\(?:NISH\\)?\\|OR\\|ROM\\)\\|GOTO\\|I\\(?:SNT\\|[FNS]\\)\\|KEEP\\|MODE\\|O\\(?:U\\(?:SE\\|T\\)\\|[DFP]\\)\\|PR\\(?:IO\\|OGRAM\\)\\|SKIP\\|T\\(?:HEN\\|O\\)\\|\\(?:US\\|WHIL\\)E\\)\\>")
        (modes "\\<\\(B\\(?:ITS\\|OOL\\)\\|C\\(?:HA\\(?:NNEL\\|R\\)\\|OMPL\\)\\|F\\(?:ILE\\|LEX\\)\\|HEAP\\|INT\\|LO\\(?:C\\|NG\\)\\|PROC\\|RE\\(?:AL\\|F\\)\\|S\\(?:HORT\\|TR\\(?:ING\\|UCT\\)\\)\\|UNION\\|VOID\\)\\>")
        (number-tags "\\<\\(EMPTY\\|FALSE\\|NIL\\|TRUE\\)\\>"))
     '((list (ops . *web68-magenta*))
       (list (bold-tags . *web68-white*))
       (list (modes . *web68-cyan*))
       (list (number-tags . *web68-red*)))))
; Keywords for Web 68 mode. Font-locking is performed by `web68-finite-state-machine'."

(defun web68-chop
    (object sequence &optional key comp order)
  "Finds OBJECT in a sorted SEQUENCE.
KEY   -- function to extract the key from an element of
         SEQUENCE (default #'identity).
COMP  -- function to compare OBJECTs (default #'string=).
ORDER -- function to order OBJECTs (default #'string<).
CHOP returns a list containing two values:
  if (cadr return) = nil, OBJECT is not in SEQUENCE
  else (car return) gives its index in SEQUENCE."
  (let ((fkey (if key key 'identity))
        (fcomp (if comp comp 'string=))
        (forder (if order order 'string<))
        (l 0)
        (u (1- (length sequence)))
        m item)
    (while
        (if (<= l u)
            (progn
              (setf m (/ (+ l u) 2))
              (setf item (elt sequence m))
              (not (funcall fcomp object (funcall fkey item))))
            nil)
      (if (funcall forder object (funcall fkey item))
          (setf u (1- m))
          (setf l (1+ m))))
    (list (if (> l u) u m)
          (if (> l u) nil m))))

(defvar *web68-tag* nil)  ; set to tag by web68-finite-state-machine

(defun web68-set-text-colour (leng face)
  "Set the colour of the chars at (POINT):(POINT+leng) to FACE."
  (put-text-property (point) (+ (point) leng) 'face face))

(defun web68-find-bold-tag ()
  "Identify the tag in *web68-tag* and colourise it accordingly.
If the tag is not identified, colourise it as a mode indicant."
  (let* ((lst (nth (length *web68-tag*) *web68-bold-tags*))
         (ret (web68-chop *web68-tag* lst)))
    (if (cadr ret)
        (web68-set-text-colour (length *web68-tag*)
                               (cadr (nth (car ret) lst)))
        (web68-set-text-colour (length *web68-tag*) *web68-cyan*))))

(defvar *states*
  '(;; ('face
    ;;  (flags/nil matcher face/nil 'function/next-state))
    (*web68-darkcyan*                 ; default: punctuation [0] Algol 68
     (nil "COMMENT" *web68-white* 1)  ; start of COMMENT comment
     (nil "#" *web68-white* 3)        ; start of # comment
     (nil "{" *web68-white* 4)        ; start of brace comment
     (nil "!" *web68-darkcyan* 9)     ; end of snippet
     (?-  "@[ 123adhim<^.!=\/,]" nil 9)    ; Web 68 command
     (nil "@@" *web68-magenta* 0)     ; AT operator
     (?-  "[A-Z]" nil 5)                   ; start of a bold tag
     (?-  "[a-z]" nil 6)                   ; start of an identifier
     (?-  "[0-9]" nil 7)                   ; start of a number
     (?-  "[.]" nil 7)                     ; start of a REAL
     (?-  "[-<=>+*/%^]" nil 8)             ; start of an operator
     (nil ":=:"  *web68-magenta* 0)
     (nil ":/=:" *web68-magenta* 0)
     (nil ":="   *web68-darkcyan* 0))

    (*web68-brown*                    ; default: comment [1] COMMENT state
     (nil "COMMENT" *web68-white* 0))

    (*web68-brown*                    ; default: comment [2] CO state
     (nil "CO[^A-Z]" '*web68-white* 0))

    (*web68-brown*                    ; default: comment [3] # state
     (nil "#" *web68-white* 0))       ; end of # comment

    (*web68-brown*                    ; default: comment [4] { state
     (nil "}" *web68-white* 0))
    
    (*web68-white*                    ; default: bold tag [5]
     (?f "[A-Z][0-9A-Z]*" nil 'web68-find-bold-tag))

    (*web68-blue*                     ; default: identifier [6]
     (nil "[a-z][0-9a-z ]" *web68-blue* 0))

    (*web68-red*                      ; default: number [7]
     (nil "2r[01 ]+" *web68-red* 0)                ; binary denotation
     (nil "4r[0-3 ]+" *web68-red* 0)               ; base-4     "
     (nil "8r[0-7 ]+" *web68-red* 0)               ; octal      "
     (nil "16r[0-9a-f ]+" *web68-red* 0)           ; hex        "
     ;; reals with exponent: -1e+10 .1e+10 +1.2e+10
     (nil "[-+]?[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
     (nil "[-+]?\.[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
     (nil "[-+]?[0-9 ]+\.[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
     ;; reals without exponent: -1 .1 +1.2
     (nil "[-+]?[0-9 ]+" *web68-red* 0)
     (nil "[-+]?\.[0-9 ]+" *web68-red* 0)
     (nil "[-+]?[0-9 ]+\.[0-9 ]+" *web68-red* 0))
     
    (*web68-magenta*                  ; default: operator [8]
     (nil "[-+*/%]:="     *web68-magenta* 0)
     (nil "\\(%*:=\\|+=:\\|\*\*\\|/=\\)" *web68-magenta* 0)
     (nil "\\(<=\\|>=\\)" *web68-magenta* 0)
     (nil "[-+*/%^<>=]"   *web68-magenta* 0))  ; simple operator
    
    (*web68-grey*                      ; default: Web 68 text [9]
     (nil "!" *web68-white* 0)         ; start of snippet
     (nil "<" *web68-magenta* 11)      ; start of HTML tag
     (nil "@[123 ]" *web68-cyan* 9)    ; section command
     (nil "@[adm]"  *web68-cyan* 0)    ; to Algol 68 state
     (nil "@h"      *web68-cyan* 12)   ; HTML state
     (nil "@[i<.^]" *web68-cyan* 10)   ; start of delimited text
     (nil "@[!\/,=]" '*web68-cyan* 0))
     
    (*web68-green*                     ; default: delimited text [10]
     (nil "@>=?"  *web68-cyan* 0))     ; end of delimited text

    (*web68-magenta*                   ; default: HTML tag [11]
     (nil ">" *web68-magenta* 9))      ; end of HTML tag

    (*web68-grey*                      ; default: HTML state [12]
     (nil "@>" *web68-cyan* 9))))      ; end of HTML state

(defmacro inc (var)
  (list 'setq var (list '1+ var)))

(defun web68-finite-state-machine (start end &optional verbose)
  "Executes the transitions defined in STATES starting at START
upto END. The elements of each transition have the following meanings:
Element 0: flags:
  nil   -- no flags
  -     -- (point) should not be moved after the match
  f     -- the 3rd element is a function instead of a face
Element 1:
  matcher
Element 2:
  face/function
Element 3:
  next state."
  (let ((current-state-index 0)
        state
        default
        index
        transition
        flags
        regexp
        transition-setup)
    (fset 'transition-setup
          (lambda (inx stat)
            (setq transition (nth inx stat)
                  flags  (car transition)
                  regexp (cadr transition))))
    (goto-char start)
    (while (< (point) end)
      (setq state (nth current-state-index *states*)
            default (car state)
            index 1)
      (while (< index (length state))
        ((symbol-function 'transition-setup) index state)
        ;; we need a function which computes transition, flags and regexp each
        ;; time index is incremented
        (while (not (looking-at regexp))
          ((symbol-function 'transition-setup) (inc index) state))
        (if (= index (length state))
            ;; no match
            (progn
              (web68-set-text-colour 1 default-face)
              (forward-char 1))
            ;; match
            (let ((matched (match-string 0)))
              (cond ((zerop (length flags)) ; no flags
                     (web68-set-text-colour (length matched)
                                            (nth 2 transition))
                     (forward-char (length matched)))
                    ((char-equal ?f flags) ; Element 2 is a function
                     (setq *web68-tag*
                           (buffer-substring-no-properties
                            (point) (+ (point) (length matched))))
                     (funcall (nth 2 transition))   ; call the function
                     (forward-char (length matched)))
                    ((char-equal ?- flags) ; Don't move point
                     (web68-set-text-colour (length matched)
                                            (nth 2 transition))))
              (setq current-state-index (nth 3 transition))))))))

(defun web68-find-font-lock-region ()
  "Finds the region over which font-locking will occur.
(1) Looks backward for a Web 68 sectioning command or the buffer beginning.
(2) Looks forward for a Web 68 sectioning command or the buffer end.
Due account is taken of the visible part of the text."
  (goto-char (window-start))
  (if (re-search-backward "@[123 ]" (point-min) t)
      (push-mark (point))
    (push-mark (point-min)))
  (goto-char (window-end))
  (if (re-search-forward "@[123 ]" (point-max) t)
      (beginning-of-line)
    (goto-char (point-max))))

(defun web68-find-font-lock-buffer ()
  "Sets POINT and MARK to POINT-MIN and POINT-MAX respectively."
  (push-mark (point-max))
  (goto-char (point-min)))

;;;###autoload
(define-derived-mode
    web68-mode prog-mode "Web 68"
    "Major mode for editing Web 68 code as well as displaying Algol 68 code."
    (setq-local case-fold-search nil)
    (setq-local blink-matching-paren-dont-ignore-comments t)
    ;; Font lock support
    (setq-local font-lock-defaults
                (list
                 *web68-font-lock-keywords* t nil nil nil
                 '(font-lock-fontify-region-function . web68-finite-state-machine)
                 '(font-lock-fontify-buffer-function . web68-find-font-lock-buffer)))
    (add-hook 'web68-mode-hook 'web68-find-font-lock-region))

(provide 'web68)

;;;; web68.el ends here