;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               nasal.el
;;;;LANGUAGE:           emacs lisp
;;;;SYSTEM:             POSIX
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Defines a nasal-mode.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@ogamita.com>
;;;;MODIFICATIONS
;;;;    2011-04-12 <PJB> Created, inspired from http://members.aon.at/mfranz/nasal.vim
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
;;;;
;;;;    This program 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 of the License, or (at your option) any later version.
;;;;
;;;;    This program 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 this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(require 'font-lock)
(require 'cc-mode)
(require 'cc-langs)


(defconst nasal-mode-version-number "0.1.0"
  "Nasal Mode version number.")

(defconst nasal-mode-modified "2011-04-12"
  "NASAL Mode build date.")


(defgroup nasal nil
  "Major mode `nasal-mode' for editing nasal code."
  :prefix "nasal-"
  :group 'languages)


(defcustom nasal-file-patterns '("\\.nas\\'")
  "List of file patterns for which to automatically invoke `nasal-mode'."
  :type '(repeat (regexp :tag "Pattern"))
  :set (lambda (sym val)
         (set-default sym val)
         (let ((nasal-file-patterns-temp val))
           (while nasal-file-patterns-temp
             (add-to-list 'auto-mode-alist
                          (cons (car nasal-file-patterns-temp) 'nasal-mode))
             (setq nasal-file-patterns-temp (cdr nasal-file-patterns-temp)))))
  :group 'nasal)

(defcustom nasal-mode-hook nil
  "List of functions to be executed on entry to `nasal-mode'."
  :type 'hook
  :group 'nasal)



(defun nasal-mode-version ()
  "Display string describing the version of NASAL mode."
  (interactive)
  (message "NASAL mode %s of %s" nasal-mode-version-number nasal-mode-modified))





(defvar nasal-beginning-of-defun-regexp
  "^\\s-*\\func\\s-+&?\\(\\(?:\\sw\\|\\s_\\)+\\)\\s-*("
  "Regular expression for a NASAL function.")

(defun nasal-beginning-of-defun (&optional arg)
  "Move to the beginning of the ARGth NASAL function from point.
Implements NASAL version of `beginning-of-defun-function'."
  (interactive "p")
  (let ((arg (or arg 1)))
    (while (> arg 0)
      (re-search-backward nasal-beginning-of-defun-regexp
                          nil 'noerror)
      (setq arg (1- arg)))
    (while (< arg 0)
      (end-of-line 1)
      (let ((opoint (point)))
        (beginning-of-defun 1)
        (forward-list 2)
        (forward-line 1)
        (if (eq opoint (point))
            (re-search-forward nasal-beginning-of-defun-regexp
                               nil 'noerror))
        (setq arg (1+ arg))))))

(defun nasal-end-of-defun (&optional arg)
  "Move the end of the ARGth NASAL function from point.
Implements NASAL befsion of `end-of-defun-function'

See `nasal-beginning-of-defun'."
  (interactive "p")
  (nasal-beginning-of-defun (- (or arg 1))))




(defvar nasal-warned-bad-indent nil)
(make-variable-buffer-local 'nasal-warned-bad-indent)


(defun nasal-check-html-for-indentation ()
;; Do it but tell it is not good if html tags in buffer.
  (let ((html-tag-re "^\\s-*</?\\sw+.*?>")
        (here (point)))
    (if (not (or (re-search-forward html-tag-re (line-end-position) t)
                 (re-search-backward html-tag-re (line-beginning-position) t)))
        t
        (goto-char here)
        (setq nasal-warned-bad-indent t)
        (lwarn 'nasal-indent :warning
               "\n\t%s\n\t%s\n\t%s\n"
               "Indentation fails badly with mixed XML and NASAL."
               "Look for an Emacs Lisp library that supports \"multiple"
               "major modes\" like mumamo, mmm-mode or multi-mode.")
        nil)))

(defun nasal-cautious-indent-region (start end &optional quiet)
  (if (or nasal-warned-bad-indent
          (nasal-check-html-for-indentation))
      (funcall 'c-indent-region start end quiet)))

(defun nasal-cautious-indent-line ()
  (if (or nasal-warned-bad-indent
          (nasal-check-html-for-indentation))
      (funcall 'c-indent-line)))




(defun opt (regexps)
  (mapconcat 'identity regexps "\\|"))



(defvar nasal-comment-delimiter  nil)

(defvar nasal-comment
  (list "#.*$"
        (concat "\\<\\("
                (opt
                 '("TODO" "FIXME" "XXX" "contained"))
                "\\)\\>")))

(defvar nasal-constant
  (concat "\\<\\("
          (opt
           '("math\\.\\(e\\|pi\\)"
             "-?\\<0x[0-9a-fA-F]+\\>"
             "-?\\<[0-9]+\\>"
             "-?\\.[0-9]+\\([eE][+-]?[0-9]+\\)?\\>"
             "-?\\<[0-9]+\\.?\\([eE][+-]?[0-9]+\\)?\\>"
             "-?\\<[0-9]+\\.[0-9]+\\([eE][+-]?[0-9]+\\)?\\>"))
          "\\)\\>"))

(defvar nasal-doc                nil)

(defvar nasal-function-name
  (concat "\\<\\("
          (opt
           '("display" "contains" "size" "keys" "append" "pop" "setsize"
             "subvec" "delete" "int" "num" "streq" "substr" "chr" "typeof"
             "compile" "call" "die" "sprintf" "caller" "closure" "find" "cmp"
             "split" "rand" "bind" "sort" "ghosttype" "id"
             "math\\.\\(sin\\|cos\\|exp\\|ln\\|sqrt\\|atan2\\)"
             "io\\.\\(close\\|read\\|write\\|seek\\|tell\\|flush\\|open\\|readln\\|stat\\)"
             "bits\\.\\(sfld\\|fld\\|setfld\\|buf\\)"))
          "\\)\\>"))

(defvar  nasal-flightgear-function-name
  (concat "\\<\\("
          (opt
           '("getprop" "setprop" "print" "_fgcommand" "settimer" "_setlistener"
             "_cmdarg" "_interpolate" "rand" "srand" "directory"
             "removelistener" "systime" "geodtocart" "carttogeod" "geodinfo"
             "parsexml" "airportinfo" "abort" "isa" "fgcommand" "cmdarg" "abs"
             "interpolate" "setlistener" "defined" "printlog" "thisfunc"
             "printf" "values" "getType" "getName" "getIndex" "getValue"
             "setValue" "setIntValue" "setBoolValue" "setDoubleValue"
             "getParent" "getChild" "getChildren" "getAttribute" "setAttribute"
             "alias" "unalias" "getAliasTarget" "clearValue" "removeChild"
             "removeChildren" "getNode" "initNode" "getPath" "getBoolValue"
             "setValues" "getValues"
             "\\<props\\.\\(_\\?globals\\|Node\\|nodeList\\|condition\\)\\>\\.\\="))
          "\\)\\>"))

(defvar nasal-highlightings      nil)

(defvar nasal-block-stmt-1-kwds  '("else"))
(defvar nasal-block-stmt-2-kwds  '("if" "elsif" "while" "for" "foreach" "forindex"))

(defvar nasal-keyword
  (concat "\\<\\("
          (opt
           (append '("func" "return" "var" "break" "continue")
                   nasal-block-stmt-1-kwds
                   nasal-block-stmt-2-kwds))
          "\\)\\>"))


(defvar nasal-preprocessor       nil)
(defvar nasal-reference          nil)

(defvar nasal-string
  (opt
   '("\"\\([^\\\"]\\|\\[\"rnt]\\)*\""
     "'\\([^\\']\\|\\['rnt]\\)*'"
     "`[^`]`"
     "`\\[`\\rnt]`"
     "`\\x[0-9a-fA-F][0-9a-fA-F]`")))


(defvar nasal-syntactic-function
  (concat "\\<\\("
          (opt
           '("and" "or"))
          "\\)\\>"))

(defvar nasal-type
  (concat "\\<\\("
          (opt
           '("nil"))
          "\\)\\>"))

(defvar nasal-variable-name
  (concat "\\<\\("
          (opt
           '("me" "arg" "parents"
             "io\\.\\(SEEK_SET\\|SEEK_CUR\\|SEEK_END\\|stdin\\|stdout\\|stderr\\)"))
          "\\)\\>"))

(defvar nasal-warning
  (opt '("``?"
         "`\\[^`\\rnt]`"
         "`[^`][^`]+`")))


(defun nasal-font-lock-keywords ()
  "Subdued level highlighting for NASAL mode."
  (flet ((flk (regexp face)
           (when regexp
             (list (list (typecase regexp
                           (string regexp)
                           (list   (regexp-opt regexp)))
                         1
                         face)))))
    (append
     (flk nasal-comment-delimiter          'font-lock-comment-delimiter-face)
     (flk nasal-comment                    'font-lock-comment-face)
     (flk nasal-constant                   'font-lock-constant-face)
     (flk nasal-doc                        'font-lock-doc-face)
     (flk nasal-function-name              'font-lock-function-name-face)
     (flk nasal-flightgear-function-name   'font-lock-function-name-face)
     (flk nasal-highlightings              'font-lock-highlightings-face)
     (flk nasal-keyword                    'font-lock-keyword-face)
     (flk nasal-preprocessor               'font-lock-preprocessor-face)
     (flk nasal-reference                  'font-lock-reference-face)
     (flk nasal-string                     'font-lock-string-face)
     (flk nasal-syntactic-function         'font-lock-syntactic-function-face)
     (flk nasal-type                       'font-lock-type-face)
     (flk nasal-variable-name              'font-lock-variable-name-face)
     (flk nasal-warning                    'font-lock-warning-face)
     (list
      ;; Fontify ASP-style tag
      '("<\\%\\(=\\)?" . font-lock-preprocessor-face)
      '("\\%>"         . font-lock-preprocessor-face)

      ;; HTML >
      '("<[^>]*\\(>\\)" (1 font-lock-constant-face))

      ;; HTML tags
      '("\\(<[a-z]+\\)[[:space:]]+\\([a-z:]+=\\)[^>]*?" (1 font-lock-constant-face) (2 font-lock-constant-face) )
      '("\"[[:space:]]+\\([a-z:]+=\\)" (1 font-lock-constant-face))


      ))))



(put 'define-derived-mode 'indent 3)

(define-derived-mode nasal-mode c-mode "Nasal"
  "Major mode for editing Nasal code.\n\n\\{nasal-mode-map}"
  (c-add-language 'nasal-mode 'c-mode)
  (c-set-offset 'cpp-macro 0)
  (set (make-local-variable 'c-block-stmt-1-key) nasal-block-stmt-1-kwds)
  (set (make-local-variable 'c-block-stmt-2-key) nasal-block-stmt-2-kwds)

  ;; ;; Specify that nasal-mode recognize Javadoc comment style
  ;; (set (make-local-variable 'c-doc-comment-style)
  ;;      '((nasal-mode . javadoc)))

  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults
        '(nasal-font-lock-keywords
          nil                               ; KEYWORDS-ONLY
          nil                               ; CASE-FOLD
          (("_" . "w"))                     ; SYNTAX-ALIST
          nil))                             ; SYNTAX-BEGIN


  ;; Electric behaviour must be turned off, they do not work since
  ;; they can not find the correct syntax in embedded NASAL.
  ;;
  ;; Seems to work with narrowing so let it be on if the user prefers it.
  ;;(setq c-electric-flag nil)

  (setq font-lock-maximum-decoration t
        case-fold-search t)         ; NASAL vars are case-sensitive
   ;; (setq imenu-generic-expression nasal-imenu-generic-expression)

  ;; Do not force newline at end of file.  Such newlines can cause
  ;; trouble if the NASAL file is included in another file before calls
  ;; to header() or cookie().
  (set (make-local-variable 'require-final-newline) nil)
  (set (make-local-variable 'next-line-add-newlines) nil)


  (set (make-local-variable  'tab-width) 4)
  (set (make-local-variable  'c-basic-offset) 4)
  (set (make-local-variable  'indent-tabs-mode) nil)
  (c-set-offset 'block-open  '- )
  (c-set-offset 'block-close '0 )


  (setq indent-line-function   'nasal-cautious-indent-line)
  (setq indent-region-function 'nasal-cautious-indent-region)
  (setq c-special-indent-hook  nil)

  (set (make-local-variable 'beginning-of-defun-function)            'nasal-beginning-of-defun)
  (set (make-local-variable 'end-of-defun-function)                  'nasal-end-of-defun)
  (set (make-local-variable 'open-paren-in-column-0-is-defun-start)  nil)
  (set (make-local-variable 'defun-prompt-regexp)                    "^\\s-*function\\s-+&?\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\s-*")
  (set (make-local-variable 'add-log-current-defun-header-regexp)    nasal-beginning-of-defun-regexp)

  (run-hooks 'nasal-mode-hook))

;; " :let nasal_no_fgfs=1               " turn off FlightGear extensions



;; syn match   nasalParenError	"[()]"
;; syn match   nasalBraceError	"[{}]"
;; syn match   nasalBrackError	"[\[\]]"



(provide 'nasal)
ViewGit