unikernel/duniverse/dune_/editor-integration/emacs/dune.el

@@ -0,0 +1,463 @@
+;;; dune.el --- Integration with the dune build system
+
+;; Copyright 2018 Jane Street Group, LLC <opensource@janestreet.com>
+;;           2017- Christophe Troestler
+;; URL: https://github.com/ocaml/dune
+;; Version: 1.0
+
+;;; Commentary:
+
+;; This package provides helper functions for interacting with the
+;; dune build system from Emacs.  It also prevides a mode to edit dune
+;; files.
+
+;; Installation:
+;; You need to install the OCaml program ``dune''.  The
+;; easiest way to do so is to install the opam package manager:
+;;
+;;   https://opam.ocaml.org/doc/Install.html
+;;
+;; and then run "opam install dune".
+
+;; This file is not part of GNU Emacs.
+
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS.  IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+;; LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+;;; Code:
+
+(defgroup dune nil
+  "Integration with the dune build system."
+  :tag "Dune build system."
+  :version "1.0"
+  :group 'languages)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;               Syntax highlighting of dune files
+
+(defface dune-error-face
+  '((t (:inherit error)))
+  "Face for errors (e.g. obsolete constructs)."
+  :group 'dune)
+
+(defvar dune-error-face 'dune-error-face
+  "Face for errors (e.g. obsolete constructs).")
+
+(defface dune-separator-face
+  '((t (:inherit default)))
+  "Face for various kind of separators such as ':'."
+  :group 'dune)
+(defvar dune-separator-face 'dune-separator-face
+  "Face for various kind of separators such as ':'.")
+
+(defconst dune-stanzas-regex
+  (eval-when-compile
+    (concat (regexp-opt
+             '("library" "executable" "executables" "rule" "toplevel"
+               "ocamllex" "ocamlyacc" "menhir" "alias" "install"
+               "copy_files" "copy_files#" "include" "tests" "test" "dirs"
+               "env" "ignored_subdirs" "include_subdirs" "data_only_dirs"
+               "documentation" "cinaps" "coqlib" "coq.theory" "coq.pp"
+               "foreign_library")
+             ) "\\(?:\\_>\\|[[:space:]]\\)"))
+  "Stanzas in dune files.")
+
+(defconst dune-fields-regex
+  (eval-when-compile
+    (regexp-opt
+     '("name" "public_name" "synopsis" "modules" "libraries" "wrapped"
+       "preprocess" "preprocessor_deps" "optional" "c_names" "cxx_names"
+       "foreign_stubs" "foreign_archives" "install_c_headers" "modes"
+       "no_dynlink" "kind" "ppx_runtime_libraries" "virtual_deps" "js_of_ocaml"
+       "flags" "ocamlc_flags" "ocamlopt_flags" "library_flags" "c_flags"
+       "cxx_flags" "c_library_flags" "self_build_stubs_archive" "inline_tests"
+       "modules_without_implementation" "private_modules"
+       ;; + special_builtin_support
+       "special_builtin_support" "build_info" "data_module" "api_version"
+       ;; +stdlib
+       "stdlib" "modules_before_stdlib" "exit_module" "internal_modules"
+       ;; + virtual libraries
+       "virtual_modules" "implements" "variant" "default_implementation"
+       "allow_overlapping_dependencies"
+       ;; + for "executable" and "executables":
+       "package" "link_flags" "link_deps" "names" "public_names" "variants"
+       "forbidden_libraries"
+       ;; + for "foreign_library" and "foreign_stubs":
+       "archive_name" "language" "names" "flags" "include_dirs" "extra_deps"
+       ;; + for "rule":
+       "targets" "action" "deps" "mode" "fallback" "locks"
+       ;; + for "menhir":
+       "merge_into"
+       ;; + for "cinaps":
+       "files"
+       ;; + for "alias"
+       "enabled_if"
+       ;; + for env
+       "binaries"
+       ;; + for "install"
+       "section" "files"
+       ;; Coq fields
+       "theories" "modules_flags" "plugins")
+     'symbols))
+  "Field names allowed in dune files.")
+
+(defconst dune-builtin-regex
+  (eval-when-compile
+    (concat (regexp-opt
+             '(;; Linking modes
+               "byte" "native" "best"
+               ;; modes
+               "standard" "fallback" "promote" "promote-until-clean"
+               ;; Actions
+               "run" "chdir" "setenv"
+               "with-stdout-to" "with-stderr-to" "with-outputs-to"
+               "ignore-stdout" "ignore-stderr" "ignore-outputs"
+               "with-stdin-from" "with-exit-codes"
+               "progn" "echo" "write-file" "cat" "copy" "copy#" "system"
+               "bash" "diff" "diff?" "cmp"
+               ;; FIXME: "flags" is already a field and we do not have enough
+               ;; context to distinguishing both.
+               "backend" "generate_runner" "runner_libraries" "flags"
+               "extends"
+               ;; Dependency specification
+               "file" "alias" "alias_rec" "glob_files" "files_recursively_in"
+               "universe" "package" "source_tree" "env_var")
+             t)
+            "\\(?:\\_>\\|[[:space:]]\\)"))
+  "Builtin sub-fields in dune.")
+
+(defconst dune-builtin-labels-regex
+  (regexp-opt '("standard" "include") 'words)
+  "Builtin :labels in dune.")
+
+(defvar dune-var-kind-regex
+  (eval-when-compile
+    (regexp-opt
+     '("ocaml-config"
+       "dep" "exe" "bin" "lib" "libexec" "lib-available"
+       "version" "read" "read-lines" "read-strings")
+     'words))
+  "Optional prefix to variable names.")
+
+(defmacro dune--field-vals (field &rest vals)
+  "Build a `font-lock-keywords' rule for the dune FIELD accepting values VALS."
+  `(list (concat "(" ,field "[[:space:]]+" ,(regexp-opt vals t))
+         1 font-lock-constant-face))
+
+(defvar dune-font-lock-keywords
+  `((,(concat "(\\(" dune-stanzas-regex "\\)") 1 font-lock-keyword-face)
+    ("([^ ]+ +\\(as\\) +[^ ]+)" 1 font-lock-keyword-face)
+    (,(concat "(" dune-fields-regex) 1 font-lock-function-name-face)
+    (,(concat "%{" dune-var-kind-regex " *\\(\\:\\)[^{}:]*\\(\\(?::\\)?\\)")
+     (1 font-lock-builtin-face)
+     (2 dune-separator-face)
+     (3 dune-separator-face))
+    ("%{\\([^{}]*\\)}" 1 font-lock-variable-name-face keep)
+    (,(concat "\\(:" dune-builtin-labels-regex "\\)[[:space:]()\n]")
+     1 font-lock-builtin-face)
+    ;; Named dependencies:
+    ("(\\(:[a-zA-Z]+\\)[[:space:]]+" 1 font-lock-variable-name-face)
+    ("\\(true\\|false\\)" 1 font-lock-constant-face)
+    ("(\\(select\\)[[:space:]]+[^[:space:]]+[[:space:]]+\\(from\\)\\>"
+     (1 font-lock-constant-face)
+     (2 font-lock-constant-face))
+    ,(eval-when-compile
+       (dune--field-vals "kind" "normal" "ppx_rewriter" "ppx_deriver"))
+    ,(eval-when-compile
+       (dune--field-vals "mode" "standard" "fallback" "promote"
+                                "promote-until-clean"))
+    (,(concat "(" dune-builtin-regex) 1 font-lock-builtin-face)
+    ("(preprocess[[:space:]]+(\\(pps\\)" 1 font-lock-builtin-face)
+    ("(name +\\(runtest\\))" 1 font-lock-builtin-face)
+    (,(eval-when-compile
+        (concat "(" (regexp-opt '("fallback") t)))
+     1 dune-error-face)))
+
+(defvar dune-mode-syntax-table
+  (let ((table (make-syntax-table)))
+    (modify-syntax-entry ?\; "< b" table)
+    (modify-syntax-entry ?\n "> b" table)
+    (modify-syntax-entry ?\( "()" table)
+    (modify-syntax-entry ?\) ")(" table)
+    (modify-syntax-entry ?\{ "(}" table)
+    (modify-syntax-entry ?\} "){" table)
+    (modify-syntax-entry ?\[ "(]" table)
+    (modify-syntax-entry ?\] ")[" table)
+    table)
+  "Dune syntax table.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                             SMIE
+
+(require 'smie)
+
+(defvar dune-smie-grammar
+  (when (fboundp 'smie-prec2->grammar)
+    (smie-prec2->grammar
+     (smie-bnf->prec2 '()))))
+
+(defun dune-smie-rules (kind token)
+  "Rules for `smie-setup'.
+See `smie-rules-function' for the meaning of KIND and TOKEN."
+  (cond
+   ((eq kind :close-all) '(column . 0))
+   ((and (eq kind :after) (equal token ")"))
+    (save-excursion
+      (goto-char (cadr (smie-indent--parent)))
+      (if (looking-at-p dune-stanzas-regex)
+          '(column . 0)
+        1)))
+   ((eq kind :before)
+    (if (smie-rule-parent-p "(")
+        (save-excursion
+          (goto-char (cadr (smie-indent--parent)))
+          (cond
+           ((looking-at-p dune-stanzas-regex) 1)
+           ((looking-at-p dune-fields-regex)
+            (smie-rule-parent 0))
+           ((smie-rule-sibling-p) (cons 'column (current-column)))
+           (t (cons 'column (current-column)))))
+      '(column . 0)))
+   ((eq kind :list-intro)
+    nil)
+   (t 1)))
+
+(defun dune-smie-rules-verbose (kind token)
+  "Same as `dune-smie-rules' but echoing information.
+See `smie-rules-function' for the meaning of KIND and TOKEN."
+  (let ((value (dune-smie-rules kind token)))
+    (message
+     "%s '%s'; sibling-p:%s parent:%s hanging:%s = %s"
+     kind token
+     (ignore-errors (smie-rule-sibling-p))
+     (ignore-errors smie--parent)
+     (ignore-errors (smie-rule-hanging-p))
+     value)
+    value))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                          Skeletons
+;; See Info node "Autotype".
+
+(define-skeleton dune-insert-library-form
+  "Insert a library stanza."
+  nil
+  "(library" > \n
+  "(name        " _ ")" > \n
+  "(public_name " _ ")" > \n
+  "(libraries   " _ ")" > \n
+  "(synopsis \"" _ "\"))" > ?\n)
+
+(define-skeleton dune-insert-executable-form
+  "Insert an executable stanza."
+  nil
+  "(executable" > \n
+  "(name        " _ ")" > \n
+  "(public_name " _ ")" > \n
+  "(modules     " _ ")" > \n
+  "(libraries   " _ "))" > ?\n)
+
+(define-skeleton dune-insert-executables-form
+  "Insert an executables stanza."
+  nil
+  "(executables" > \n
+  "(names        " _ ")" > \n
+  "(public_names " _ ")" > \n
+  "(libraries    " _ "))" > ?\n)
+
+(define-skeleton dune-insert-rule-form
+  "Insert a rule stanza."
+  nil
+  "(rule" > \n
+  "(targets " _ ")" > \n
+  "(deps    " _ ")" > \n
+  "(action  (" _ ")))" > ?\n)
+
+(define-skeleton dune-insert-ocamllex-form
+  "Insert an ocamllex stanza."
+  nil
+  "(ocamllex (" _ "))" > ?\n)
+
+(define-skeleton dune-insert-ocamlyacc-form
+  "Insert an ocamlyacc stanza."
+  nil
+  "(ocamlyacc (" _ "))" > ?\n)
+
+(define-skeleton dune-insert-menhir-form
+  "Insert a menhir stanza."
+  nil
+  "(menhir" > \n
+  "((modules (" _ "))))" > ?\n)
+
+(define-skeleton dune-insert-alias-form
+  "Insert an alias stanza."
+  nil
+  "(alias" > \n
+  "(name " _ ")" > \n
+  "(deps " _ "))" > ?\n)
+
+(define-skeleton dune-insert-install-form
+  "Insert an install stanza."
+  nil
+  "(install" > \n
+  "(section " _ ")" > \n
+  "(files   " _ "))" > ?\n)
+
+(define-skeleton dune-insert-copyfiles-form
+  "Insert a copy_files stanza."
+  nil
+  "(copy_files " _ ")" > ?\n)
+
+(define-skeleton dune-insert-test-form
+  "Insert a test stanza."
+  nil
+  "(test" > \n
+  "(name " _ "))" > ?\n)
+
+(define-skeleton dune-insert-tests-form
+  "Insert a tests stanza."
+  nil
+  "(tests" > \n
+  "(names " _ "))" > ?\n)
+
+(define-skeleton dune-insert-env-form
+  "Insert a env stanza."
+  nil
+  "(env" > \n
+  "(" _ " " _ "))" > ?\n)
+
+(define-skeleton dune-insert-ignored-subdirs-form
+  "Insert a ignored_subdirs stanza."
+  nil
+  "(ignored_subdirs (" _ "))" > ?\n)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar dune-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map "\C-c\C-c" 'compile)
+    (define-key map "\C-c.l" 'dune-insert-library-form)
+    (define-key map "\C-c.e" 'dune-insert-executable-form)
+    (define-key map "\C-c.x" 'dune-insert-executables-form)
+    (define-key map "\C-c.r" 'dune-insert-rule-form)
+    (define-key map "\C-c.p" 'dune-insert-ocamllex-form)
+    (define-key map "\C-c.y" 'dune-insert-ocamlyacc-form)
+    (define-key map "\C-c.m" 'dune-insert-menhir-form)
+    (define-key map "\C-c.a" 'dune-insert-alias-form)
+    (define-key map "\C-c.i" 'dune-insert-install-form)
+    (define-key map "\C-c.c" 'dune-insert-copyfiles-form)
+    (define-key map "\C-c.t" 'dune-insert-tests-form)
+    (define-key map "\C-c.v" 'dune-insert-env-form)
+    (define-key map "\C-c.d" 'dune-insert-ignored-subdirs-form)
+    map)
+  "Keymap used in dune mode.")
+
+(defun dune-build-menu ()
+  "Build the menu for `dune-mode'."
+  (easy-menu-define
+    dune-mode-menu  (list dune-mode-map)
+    "dune mode menu."
+    '("Dune/jbuild"
+      ("Stanzas"
+       ["library" dune-insert-library-form t]
+       ["executable" dune-insert-executable-form t]
+       ["executables" dune-insert-executables-form t]
+       ["rule" dune-insert-rule-form t]
+       ["alias" dune-insert-alias-form t]
+       ["ocamllex" dune-insert-ocamllex-form t]
+       ["ocamlyacc" dune-insert-ocamlyacc-form t]
+       ["menhir" dune-insert-menhir-form t]
+       ["install" dune-insert-install-form t]
+       ["copy_files" dune-insert-copyfiles-form t]
+       ["test" dune-insert-test-form t]
+       ["env" dune-insert-env-form t]
+       ["ignored_subdirs" dune-insert-ignored-subdirs-form t]
+       )))
+  (easy-menu-add dune-mode-menu))
+
+
+;;;###autoload
+(define-derived-mode dune-mode prog-mode "dune"
+  "Major mode to edit dune files.
+For customization purposes, use `dune-mode-hook'."
+  (set (make-local-variable 'font-lock-defaults) '(dune-font-lock-keywords))
+  (set (make-local-variable 'comment-start) ";")
+  (set (make-local-variable 'comment-end) "")
+  (setq indent-tabs-mode nil)
+  (set (make-local-variable 'require-final-newline) mode-require-final-newline)
+  (smie-setup dune-smie-grammar #'dune-smie-rules)
+  (dune-build-menu))
+
+
+;;;###autoload
+(add-to-list 'auto-mode-alist
+             '("\\(?:\\`\\|/\\)dune\\(?:\\.inc\\|\\-project\\|\\-workspace\\)?\\'" . dune-mode))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                     Interacting with dune
+
+(defcustom dune-command "dune"
+  "The dune command."
+  :type 'string)
+
+;;;###autoload
+(defun dune-promote ()
+  "Promote the correction for the current file."
+  (interactive)
+  (if (buffer-modified-p)
+      (error "Cannot promote as buffer is modified")
+    (shell-command
+     (format
+      "%s promote %s" dune-command
+      (shell-quote-argument (file-name-nondirectory (buffer-file-name)))))
+    (revert-buffer nil t)))
+
+;;;###autoload
+(defun dune-runtest-and-promote ()
+  "Run tests in the current directory and promote the current buffer."
+  (interactive)
+  (compile (format "%s build @@runtest" dune-command))
+  (dune-promote))
+
+(defun dune-project-p (directory)
+  "Return t if DIRECTORY is a dune project."
+  (file-exists-p (expand-file-name "dune-project" directory)))
+
+(defun dune-workspace-p (directory)
+  "Return t if DIRECTORY is a dune workspace."
+  (file-exists-p (expand-file-name "dune-workspace" directory)))
+
+(defun dune-root (&optional directory)
+  "Return the root directory of the dune project of DIRECTORY.
+
+DIRECTORY defaults to `default-directory' if not provided."
+  (let*
+      (root
+       workspace
+       (dir (or directory default-directory))
+       (project-p (lambda (dir)
+		    (cond
+		     ((dune-workspace-p dir)
+		      (setq workspace t)
+		      t)
+		     ((and
+		       (not workspace)
+		       (dune-project-p dir))
+		      t)))))
+    (while dir
+      (setq dir (locate-dominating-file dir project-p))
+      (when dir
+	(setq root dir
+	      dir (file-name-parent-directory dir))))
+    root))
+
+(provide 'dune)
+
+;;; dune.el ends here