Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 289 lines (250 sloc) 10.431 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
; cg.el -- major mode for editing Constraint Grammar files

; See http://beta.visl.sdu.dk/constraint_grammar.html

;; 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, 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., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Author: Kevin Brubeck Unhammer <unhammer hos gmail punktum com>

;;; Usage:
;; (add-to-list 'load-path "/path/to/cg.el")
;; (require 'cg)

;;; I recommend using pabbrev-mode for tab-completion, and
;;; paredit-mode if you're used to it. However, if you have set names
;;; with hashes in them, like m#foo, paredit-mode may tell you that
;;; your parens are unbalenced since if you have it in a mode
;;; hook. The reason is that such exceptions to the rule that # starts
;;; a comment are handled in font-lock, and fontification happens
;;; after run-mode-hooks. To get paredit-mode to turn on automatically
;;; in cg-mode, you could use this hack:

;; (add-hook 'cg-mode-hook
;; (lambda nil
;; (run-with-idle-timer 1 nil (lambda nil (paredit-mode 1)))))

;;; sh-mode has the same problem, so I don't feel up to fixing it...

;;; TODO:
;;; - different syntax highlighting for sets and tags (difficult)
;;; - use something like prolog-clause-start to define M-a/e etc.
;;; - run vislcg3 --show-unused-sets and buttonise with line numbers (like Occur does)
;;; - indentation function (based on prolog again?)
;;; - the rest of the keywords
;;; - keyword tab-completion

(defconst cg-version "2010-03-04" "Version of cg-mode")

;;;============================================================================
;;;
;;; Define the formal stuff for a major mode named cg.
;;;

(defvar cg-mode-map (make-sparse-keymap)
  "Keymap for cg minor mode.")

(defgroup cg nil
  "Major mode for editing VISL CG-3 Constraint Grammar files."
  :tag "CG"
  :group 'languages)

(defcustom cg-indentation 8
  "The width for indentation in Constraint Grammar mode."
  :type 'integer
  :group 'cg)
(put 'cg-indentation 'safe-local-variable 'integerp)

(defvar cg-font-lock-keywords-1
  (let ((<word>? "\\(?:\"<\\(\\s_\\|\\sw\\)+>\"\\)?"))
    `(("^[ \t]*\\(LIST\\|SET\\|TEMPLATE\\)[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)"
       (1 font-lock-keyword-face)
       (2 font-lock-variable-name-face))
      ("^[ \t]*\\(MAPPING-PREFIX\\|DELIMITERS\\|SOFT-DELIMITERS\\)"
       1 font-lock-keyword-face)
      ("^[ \t]*\\(SECTION\\|AFTER-SECTIONS\\|BEFORE-SECTIONS\\|MAPPINGS\\|CONSTRAINTS\\|CORRECTIONS\\)"
       1 font-lock-warning-face)
      (,(concat "^[ \t]*" <word>? "[ \t]*\\(SETPARENT\\|SETCHILD\\|ADDRELATIONS?\\|SETRELATIONS?\\|REMRELATIONS?\\|SUBSTITUTE\\|ADD\\|MAP\\|SELECT\\|REMOVE\\)\\(\\(:\\(\\s_\\|\\sw\\)+\\)?\\)")
       (2 font-lock-keyword-face)
       (3 font-lock-variable-name-face))
      ("[ \t\n]\\([+-]\\)[ \t\n]"
       1 font-lock-function-name-face)))
  "Subdued level highlighting for CG mode.")

(defconst cg-font-lock-keywords-2
  (append cg-font-lock-keywords-1
'(("\\<\\(\\$\\$\\(\\s_\\|\\sw\\)+\\)\\>"
(1 font-lock-variable-name-face))
("\\<\\(NOT\\|NEGATE\\|NONE\\|LINK\\|BARRIER\\|CBARRIER\\|OR\\|TARGET\\|IF\\|TO\\|[psc]\\)\\>"
1 font-lock-function-name-face)
("\\B\\(\\^\\)" ; fail-fast
1 font-lock-function-name-face)))
  "Gaudy level highlighting for CG modes.")

(defvar cg-font-lock-keywords cg-font-lock-keywords-1
  "Default expressions to highlight in CG modes.")

(defvar cg-mode-syntax-table
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?# "<" table)
    (modify-syntax-entry ?\n ">#" table)
    ;; todo: better/possible to conflate \\s_ and \\sw into one class?
    (modify-syntax-entry ?@ "_" table)
    table))

;;;###autoload
(defun cg-mode ()
  "Major mode for editing Constraint Grammar files.
Only does basic syntax highlighting at the moment."
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'cg-mode
mode-name "CG")
  (use-local-map cg-mode-map)
  (make-local-variable 'comment-start)
  (make-local-variable 'comment-start-skip)
  (make-local-variable 'font-lock-defaults)
  (make-local-variable 'indent-line-function)
  (setq comment-start "#"
comment-start-skip "#+[\t ]*"
font-lock-defaults
`((cg-font-lock-keywords cg-font-lock-keywords-1 cg-font-lock-keywords-2)
nil ; KEYWORDS-ONLY
nil ; CASE-FOLD
((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w"))
nil ; beginning-of-line ; SYNTAX-BEGIN
(font-lock-syntactic-keywords . cg-font-lock-syntactic-keywords)
(font-lock-syntactic-face-function . cg-font-lock-syntactic-face-function)))
  (make-local-variable 'cg-mode-syntax-table)
  (set-syntax-table cg-mode-syntax-table)
  (set (make-local-variable 'parse-sexp-ignore-comments) t)
  (set (make-local-variable 'parse-sexp-lookup-properties) t)
  (setq indent-line-function 'cg-indent-line)
  (easy-mmode-pretty-mode-name 'cg-mode " cg")
  (when font-lock-mode
    (setq font-lock-set-defaults nil)
    (font-lock-set-defaults)
    (font-lock-fontify-buffer))
  (run-mode-hooks 'cg-mode-hook))


(defconst cg-font-lock-syntactic-keywords
  ;; A `#' begins a comment when it is unquoted and at the beginning
  ;; of a word; otherwise it is a symbol.
  ;; For this to work, we also add # into the syntax-table as a
  ;; comment, with \n to turn it off, and also need
  ;; (set (make-local-variable 'parse-sexp-lookup-properties) t)
  ;; to avoid parser problems.
  '(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 "_")
    ;; fail-fast, at the beginning of a word:
    ("[( \t\n]\\(\\^\\)" 1 "'")))

(defun cg-font-lock-syntactic-face-function (state)
  "Determine which face to use when fontifying syntactically. See
`font-lock-syntactic-face-function'.

TODO: something like
((= 0 (nth 0 state)) font-lock-variable-name-face)
would be great to differentiate SETs from their members, but it
seems this function only runs on comments and strings..."
  (cond ((nth 3 state) font-lock-string-face)
  (t font-lock-comment-face)))


;;; Indentation

(defvar cg-kw-list
  '("SUBSTITUTE"
    "MAP" "ADD"
    "SELECT" "REMOVE"
    "LIST" "SET"
    "SETPARENT" "SETCHILD"
    "ADDRELATION" "REMRELATION"
    "ADDRELATIONS" "REMRELATIONS"
    ";"))

(defun cg-calculate-indent ()
  "Return the indentation for the current line."
;;; idea from sh-mode, use font face?
;; (or (and (boundp 'font-lock-string-face) (not (bobp))
;; (eq (get-text-property (1- (point)) 'face)
;; font-lock-string-face))
;; (eq (get-text-property (point) 'face) sh-heredoc-face))
  (let ((origin (point))
(old-case-fold-search case-fold-search))
    (setq case-fold-search nil) ; for re-search-backward
    (save-excursion
      (let ((kw-pos (progn
(goto-char (1- (or (search-forward ";" (line-end-position) t)
(line-end-position))))
(re-search-backward (regexp-opt cg-kw-list) nil 'noerror))))
(setq case-fold-search old-case-fold-search)
(when kw-pos
(let* ((kw (match-string-no-properties 0)))
(if (and (not (equal kw ";"))
(> origin (line-end-position)))
cg-indentation
0)))))))

(defun cg-indent-line ()
  "Indent the current line. Very simple indentation: lines with
keywords from `cg-kw-list' get zero indentation, others get one
indentation."
  (interactive)
  (let ((indent (cg-calculate-indent))
(pos (- (point-max) (point))))
    (when indent
      (beginning-of-line)
      (skip-chars-forward " \t")
      (indent-line-to indent)
      ;; 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))))))


;;; Interactive functions:

(defvar cg-occur-history nil)
(defvar cg-occur-prefix-history nil)

(defun cg-permute (input)
  "From http://www.emacswiki.org/emacs/StringPermutations"
  (require 'cl)
  (if (null input)
      (list input)
    (mapcan '(lambda (elt)
(mapcan '(lambda (p)
(list (cons elt p)))
(cg-permute (remove* elt input :count 1))))
input)))

(defun cg-read-arg (prompt history)
  (let* ((default (car history))
(input
(read-from-minibuffer
(concat prompt
(if default
(format " (default: %s): " (query-replace-descr default))
": "))
nil
nil
nil
(quote history)
default)))
    (if (equal input "")
default
      input)))

(defun cg-occur-list (&optional prefix words)
  "Do an occur-check for the left-side of a LIST/SET
assignment. `words' is a space-separated list of words which
*all* must occur between LIST/SET and =. Optional prefix argument
`prefix' lets you specify a prefix to the name of LIST/SET.

This is useful if you have a whole bunch of this stuff:
LIST subst-mask/fem = (n m) (np m) (n f) (np f) ;
LIST subst-mask/fem-eint = (n m sg) (np m sg) (n f sg) (np f sg) ;
etc."
  (interactive (list (when current-prefix-arg
(cg-read-arg
"Word to occur between LIST/SET and disjunction"
cg-occur-prefix-history))
(cg-read-arg
"Words to occur between LIST/SET and ="
cg-occur-history)))
  (let* ((words-perm (cg-permute (split-string words " " 'omitnulls)))
;; can't use regex-opt because we need .* between the words
(perm-disj (mapconcat '(lambda (word)
(mapconcat 'identity word ".*"))
words-perm
"\\|")))
    (setq cg-occur-history (cons words cg-occur-history))
    (setq cg-occur-prefix-history (cons prefix cg-occur-prefix-history))
    (let ((tmp regexp-history))
      (occur (concat "\\(LIST\\|SET\\) +" prefix ".*\\(" perm-disj "\\).*="))
      (setq regexp-history tmp))))

;;; Keybindings --------------------------------------------------------------
(define-key cg-mode-map (kbd "C-c o") 'cg-occur-list)

;;; Run hooks -----------------------------------------------------------------
(run-hooks 'cg-load-hook)

(provide 'cg)

;;;============================================================================

;;; cg.el ends here
Something went wrong with that request. Please try again.