;;; cfengine3.el --- mode for editing Cfengine 3 files

;; Copyright (C) 2001-2011  Free Software Foundation, Inc.

;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: languages

;; This file is 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Supports only cfengine 3, unlike the older cfengine.el which
;; supports 1.x and 2.x.

;; Possible customization for auto-mode selection:

;; (push '(("^cfagent.conf\\'" . cfengine3-mode)) auto-mode-alist)
;; (push '(("^cf\\." . cfengine3-mode)) auto-mode-alist)
;; (push '(("\\.cf\\'" . cfengine3-mode)) auto-mode-alist)

;;; Code:

(defgroup cfengine3 ()
  "Editing CFEngine 3 files."
  :group 'languages)

(defcustom cfengine3-indent 2
  "*Size of a CFEngine 3 indentation step in columns."
  :group 'cfengine3
  :type 'integer)

(eval-and-compile
  (defconst cfengine3-defuns
    (mapcar
     'symbol-name
     '(bundle body))
    "List of the CFEngine 3.x defun headings.")

  (defconst cfengine3-defuns-regex
    (regexp-opt cfengine3-defuns t)
    "Regex to match the CFEngine 3.x defuns.")

  (defconst cfengine3-class-selector-regex "\\([[:alnum:]_().&|!]+\\)::")

  (defconst cfengine3-category-regex "\\([[:alnum:]_]+\\):")

  (defconst cfengine3-vartypes
    (mapcar
     'symbol-name
     '(string int real slist ilist rlist irange rrange counter))
    "List of the CFEngine 3.x variable types."))

(defvar cfengine3-font-lock-keywords
  `(
    (,(concat "^[ \t]*" cfengine3-class-selector-regex)
     1 font-lock-keyword-face)
    (,(concat "^[ \t]*" cfengine3-category-regex)
     1 font-lock-builtin-face)
    ;; Variables, including scope, e.g. module.var
    ("[@$](\\([[:alnum:]_.]+\\))" 1 font-lock-variable-name-face)
    ("[@$]{\\([[:alnum:]_.]+\\)}" 1 font-lock-variable-name-face)
    ;; Variable definitions.
    ("\\<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)

    ;; CFEngine 3.x faces
    ;; defuns
    (,(concat "\\<" cfengine3-defuns-regex "\\>"
              "[ \t]+\\<\\([[:alnum:]_]+\\)\\>"
              "[ \t]+\\<\\([[:alnum:]_]+\\)\\((\\([^)]*\\))\\)?")
    (1 font-lock-builtin-face)
    (2 font-lock-constant-name-face)
    (3 font-lock-function-name-face)
    (5 font-lock-variable-name-face))
    ;; variable types
    (,(concat "\\<" (eval-when-compile (regexp-opt cfengine3-vartypes t)) "\\>")
     1 font-lock-type-face)))

(defun cfengine3-beginning-of-defun ()
  "`beginning-of-defun' function for Cfengine 3 mode.
Treats body/bundle blocks as defuns."
  (unless (<= (current-column) (current-indentation))
    (end-of-line))
  (if (re-search-backward (concat "^[ \t]*" cfengine3-defuns-regex "\\>") nil t)
      (beginning-of-line)
    (goto-char (point-min)))
  t)

(defun cfengine3-end-of-defun ()
  "`end-of-defun' function for Cfengine 3 mode.
Treats body/bundle blocks as defuns."
  (end-of-line)
  (if (re-search-forward (concat "^[ \t]*" cfengine3-defuns-regex "\\>") nil t)
      (beginning-of-line)
    (goto-char (point-max)))
  t)

(defun cfengine3-indent-line ()
  "Indent a line in Cfengine mode.
Intended as the value of `indent-line-function'."
  (let ((pos (- (point-max) (point)))
        parse)
    (save-restriction
      (narrow-to-defun)
      (back-to-indentation)
      (setq parse (parse-partial-sexp (point-min) (point)))
      (message "%S" parse)
      (cond
       ;; body/bundle blocks start at 0
       ((looking-at (concat cfengine3-defuns-regex "\\>"))
        (indent-line-to 0))
       ;; categories are indented one step
       ((looking-at (concat cfengine3-category-regex "[ \t]*$"))
        (indent-line-to cfengine3-indent))
       ;; class selectors are indented two steps
       ((looking-at (concat cfengine3-class-selector-regex "[ \t]*$"))
        (indent-line-to (* 2 cfengine3-indent)))
       ;; Outdent leading close brackets one step.
       ((or (eq ?\} (char-after))
            (eq ?\) (char-after)))
        (condition-case ()
            (indent-line-to (save-excursion
                              (forward-char)
                              (backward-sexp)
                              (current-column)))
          (error nil)))
       ;; inside a string and it starts before this line
       ((and (nth 3 parse)
             (< (nth 8 parse) (save-excursion (beginning-of-line) (point))))
        (indent-line-to 0))
       ;; inside a defun, but not a nested list (depth is 1)
       ((= 1 (nth 0 parse))
        (indent-line-to (* (+ 2 (nth 0 parse)) cfengine3-indent)))
       ;; Inside brackets/parens: indent to start column of non-comment
       ;; token on line following open bracket or by one step from open
       ;; bracket's column.
       ((condition-case ()
            (progn (indent-line-to (save-excursion
                                     (backward-up-list)
                                     (forward-char)
                                     (skip-chars-forward " \t")
                                     (cond
                                      ((looking-at "[^\n#]")
                                       (current-column))
                                      ((looking-at "[^\n#]")
                                       (current-column))
                                      (t
                                       (skip-chars-backward " \t")
                                       (+ (current-column) -1
                                          cfengine3-indent)))))
                   t)
          (error nil)))
       ;; Else don't indent.
       (t (indent-line-to 0))))
    ;; If initial point was within line's indentation,
    ;; position after the indentation.  Else stay at same point in text.
    (if (> (- (point-max) pos) (point))
        (goto-char (- (point-max) pos)))))

;; (defvar cfengine3-smie-grammar
;;   (smie-prec2->grammar
;;    (smie-merge-prec2s
;;    (smie-bnf->prec2
;;     '((token)
;;       (decls (decls "body" decls)
;;              (decls "bundle" decls))
;;       (insts (token ":" insts)))
;;     '((assoc "body" "bundle")))
;;    (smie-precs->prec2
;;     '((right ":")
;;       (right "::")
;;       (assoc ";")
;;       (assoc ",")
;;       (right "=>"))))))

;; (defun cfengine3-smie-rules (kind token)
;;   (pcase (cons kind token)
;;     (`(:elem . basic) 2)
;;     (`(:list-intro . ,(or `"body" `"bundle")) t)
;;     (`(:after . ":") 2)
;;     (`(:after . "::") 2)))

;; (defun cfengine3-show-all-tokens ()
;;   (interactive)
;;   (goto-char (point-min))
;;   (while (not (eobp))
;;     (let* ((p (point))
;;            (token (funcall smie-forward-token-function)))
;;       (delete-region p (point))
;;       (insert-before-markers token)
;;       (forward-char))))

;; (defun cfengine3-line-classes ()
;;   (interactive)
;;   (save-excursion
;;     (beginning-of-line)
;;     (let* ((todo (buffer-substring (point)
;;                                    (save-excursion (end-of-line) (point))))
;;            (original (concat (loop for c across todo
;;                                    collect (char-syntax c)))))
;;       (format "%s\n%s" original todo))))

;; (defun cfengine3-show-all-classes ()
;;   (interactive)
;;   (goto-char (point-min))
;;   (while (not (eobp))
;;     (let ((repl (cfengine3-line-classes)))
;;       (kill-line)
;;       (insert repl)
;;       (insert "\n"))))

;; specification: blocks
;; blocks: block | blocks block;
;; block:                 bundle typeid blockid bundlebody
;;                      | bundle typeid blockid usearglist bundlebody
;;                      | body typeid blockid bodybody
;;                      | body typeid blockid usearglist bodybody;

;; typeid: id
;; blockid: id
;; usearglist: '(' aitems ')';
;; aitems: aitem | aitem ',' aitems |;
;; aitem: id

;; bundlebody: '{' statements '}'
;; statements: statement | statements statement;
;; statement: category | classpromises;

;; bodybody: '{' bodyattribs '}'
;; bodyattribs: bodyattrib | bodyattribs bodyattrib;
;; bodyattrib: class | selections;
;; selections: selection | selections selection;
;; selection: id ASSIGN rval ';' ;

;; classpromises: classpromise | classpromises classpromise;
;; classpromise: class | promises;
;; promises: promise | promises promise;
;; category: CATEGORY
;; promise: promiser ARROW rval constraints ';' | promiser constraints ';';
;; constraints: constraint | constraints ',' constraint |;
;; constraint: id ASSIGN rval;
;; class: CLASS
;; id: ID
;; rval: ID | QSTRING | NAKEDVAR | list | usefunction
;; list: '{' litems '}' ;
;; litems: litem | litem ',' litems |;
;; litem: ID | QSTRING | NAKEDVAR | list | usefunction

;; functionid: ID | NAKEDVAR
;; promiser: QSTRING
;; usefunction: functionid givearglist
;; givearglist: '(' gaitems ')'
;; gaitems: gaitem | gaitems ',' gaitem |;
;; gaitem: ID | QSTRING | NAKEDVAR | list | usefunction

;; # from lexer:

;; bundle: "bundle"
;; body: "body"
;; COMMENT    #[^\n]*
;; NAKEDVAR   [$@][(][a-zA-Z0-9_\200-\377.]+[)]|[$@][{][a-zA-Z0-9_\200-\377.]+[}]
;; ID: [a-zA-Z0-9_\200-\377]+
;; ASSIGN: "=>"
;; ARROW: "->"
;; QSTRING: \"((\\\")|[^"])*\"|\'((\\\')|[^'])*\'|`[^`]*`
;; CLASS: [.|&!()a-zA-Z0-9_\200-\377]+::
;; CATEGORY: [a-zA-Z_]+:

;;;###autoload
(define-derived-mode cfengine3-mode prog-mode "CFEngine3"
  "Major mode for editing cfengine input.
There are no special keybindings by default.

Action blocks are treated as defuns, i.e. \\[beginning-of-defun] moves
to the action header."
  (modify-syntax-entry ?# "<" cfengine3-mode-syntax-table)
  (modify-syntax-entry ?\n ">#" cfengine3-mode-syntax-table)
  (modify-syntax-entry ?\" "\"" cfengine3-mode-syntax-table)
  ;; variable substitution:
  (modify-syntax-entry ?$ "." cfengine3-mode-syntax-table)
  ;; Doze path separators:
  (modify-syntax-entry ?\\ "." cfengine3-mode-syntax-table)
  ;; Otherwise, syntax defaults seem OK to give reasonable word
  ;; movement.

  ;; (smie-setup cfengine3-smie-grammar #'cfengine3-smie-rules)
  ;;             ;; :forward-token  #'cfengine3-smie-forward-token
  ;;             ;; :backward-token #'cfengine3-smie-backward-token)
  ;; (set (make-local-variable 'smie-indent-basic) 'cfengine3-indent)

  (set (make-local-variable 'parens-require-spaces) nil)
  (set (make-local-variable 'comment-start)  "# ")
  (set (make-local-variable 'comment-start-skip)
       "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
  (set (make-local-variable 'indent-line-function) #'cfengine3-indent-line)
  (setq font-lock-defaults
        '(cfengine3-font-lock-keywords nil nil nil beginning-of-defun))
  ;; Fixme: set the args of functions in evaluated classes to string
  ;; syntax, and then obey syntax properties.
  (set (make-local-variable 'syntax-propertize-function)
       ;; In the main syntax-table, \ is marked as a punctuation, because
       ;; of its use in DOS-style directory separators.  Here we try to
       ;; recognize the cases where \ is used as an escape inside strings.
       (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\"))))

  ;; use defuns as the essential syntax block
  (set (make-local-variable 'beginning-of-defun-function)
       #'cfengine3-beginning-of-defun)
  (set (make-local-variable 'end-of-defun-function)
       #'cfengine3-end-of-defun)

  ;; Like Lisp mode.  Without this, we lose with, say,
  ;; `backward-up-list' when there's an unbalanced quote in a
  ;; preceding comment.
  (set (make-local-variable 'parse-sexp-ignore-comments) t))

(provide 'cfengine3)

;;; cfengine3.el ends here