;;; tuareg-jbuild.el --- Mode for editing jbuild files -*- coding: utf-8 -*- ;; Copyright (C) 2017- Christophe Troestler ;; This file is not part of GNU Emacs. ;; Permission to use, copy, modify, and distribute this software for ;; any purpose with or without fee is hereby granted, provided that ;; the above copyright notice and this permission notice appear in ;; all copies. ;; ;; 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. (require 'scheme) (defvar tuareg-jbuild-mode-hook nil "Hooks for the `tuareg-jbuild-mode'.") (defvar tuareg-jbuild-flymake nil "If t, check your jbuild file with flymake.") (defvar tuareg-jbuild-temporary-file-directory (expand-file-name "Tuareg-jbuild" temporary-file-directory) "Directory where to duplicate the files for flymake.") (defvar tuareg-jbuild-program (expand-file-name "jbuild-lint" tuareg-jbuild-temporary-file-directory) "Script to use to check the jbuild file.") (defgroup tuareg-jbuild nil "Support for Jbuilder files." :group 'languages) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Syntax highlighting (defface tuareg-jbuild-error-face '((t (:foreground "yellow" :background "red" :bold t))) "Face for errors (e.g. obsolete constructs).") (defvar tuareg-jbuild-error-face 'tuareg-jbuild-error-face "Face for errors (e.g. obsolete constructs).") (defconst tuareg-jbuild-keywords-regex (eval-when-compile (concat (regexp-opt '("jbuild_version" "library" "executable" "executables" "rule" "ocamllex" "ocamlyacc" "menhir" "alias" "install" "copy_files" "copy_files#" "include" "documentation") ) "\\(?:\\_>\\|[[:space:]]\\)")) "Keywords in jbuild files.") (defconst tuareg-jbuild-fields-regex (eval-when-compile (regexp-opt '("name" "public_name" "synopsis" "modules" "libraries" "wrapped" "inline_tests" "inline_tests.backend" "preprocess" "preprocessor_deps" "optional" "c_names" "cxx_names" "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" "modules_without_implementation" ;; + for "executable" and "executables": "package" "link_flags" "modes" "names" "public_names" ;; + for "rule": "targets" "action" "deps" "mode" ;; + for "menhir": "merge_into" ;; + for "install" "section" "files" "lib" "libexec" "bin" "sbin" "toplevel" "share" "share_root" "etc" "doc" "stublibs" "man" "misc" ;; for "documentation": "mld_files") 'symbols)) "Field names allowed in jbuild files.") (defvar tuareg-jbuild-builtin-regex (eval-when-compile (concat (regexp-opt '(;; Actions "run" "chdir" "setenv" "with-stdout-to" "with-stderr-to" "with-outputs-to" "ignore-stdout" "ignore-stderr" "ignore-outputs" "progn" "echo" "write-file" "cat" "copy" "copy#" "system" "bash" "diff" "diff?" ;; inline_tests and inline_tests.backend ;; 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") t) "\\(?:\\_>\\|[[:space:]]\\)")) "Builtin sub-fields in jbuild") (defvar tuareg-jbuild-var-kind-regex (eval-when-compile (regexp-opt '("path" "path-no-dep" "exe" "bin" "lib" "libexec" "lib-available" "version" "read" "read-lines" "read-strings") 'words)) "Optional prefix to variable names.") (defvar tuareg-jbuild-var-regex (concat "\\(!?\\)\\(\\(?:" tuareg-jbuild-var-kind-regex ":\\)?\\)\\([a-zA-Z][a-zA-Z0-9_.-]*\\|[<@^]\\)" "\\(\\(?::[a-zA-Z][a-zA-Z0-9_.-]*\\)?\\)")) (defmacro tuareg-jbuild--field-vals (field &rest vals) `(list (concat "(" ,field "[[:space:]]+" ,(regexp-opt vals t)) 1 font-lock-constant-face)) (defvar tuareg-jbuild-font-lock-keywords `((,tuareg-jbuild-keywords-regex . font-lock-keyword-face) (,(concat "(" tuareg-jbuild-fields-regex) 1 font-lock-function-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 (tuareg-jbuild--field-vals "kind" "normal" "ppx_rewriter" "ppx_deriver")) ,(eval-when-compile (tuareg-jbuild--field-vals "mode" "standard" "fallback" "promote" "promote-until-clean")) (,(concat "(" tuareg-jbuild-builtin-regex) 1 font-lock-builtin-face) ("(preprocess[[:space:]]+(\\(pps\\)" 1 font-lock-builtin-face) (,(eval-when-compile (concat "(" (regexp-opt '("fallback") t))) 1 tuareg-jbuild-error-face) (,(concat "${" tuareg-jbuild-var-regex "}") (1 tuareg-jbuild-error-face) (2 font-lock-builtin-face) (4 font-lock-variable-name-face) (5 font-lock-variable-name-face)) (,(concat "$(" tuareg-jbuild-var-regex ")") (1 tuareg-jbuild-error-face) (2 font-lock-builtin-face) (4 font-lock-variable-name-face) (5 font-lock-variable-name-face)) ("\\(:[a-zA-Z]+\\)\\b" 1 font-lock-builtin-face))) (defvar tuareg-jbuild-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) "Tuareg-jbuild syntax table.") ;; (defun tuareg-jbuild-syntax-propertize (start end) ;; (funcall ;; (syntax-propertize-rules)) ;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; SMIE (require 'smie) (defvar tuareg-jbuild-smie-grammar (when (fboundp 'smie-prec2->grammar) (smie-prec2->grammar (smie-bnf->prec2 '())))) (defun tuareg-jbuild-smie-rules (kind 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 tuareg-jbuild-keywords-regex) '(column . 0) 1))) ((eq kind :before) (if (smie-rule-parent-p "(") (save-excursion (goto-char (cadr (smie-indent--parent))) (cond ((looking-at-p tuareg-jbuild-keywords-regex) 1) ((looking-at-p tuareg-jbuild-fields-regex) (smie-rule-parent 0)) ((smie-rule-sibling-p) (cons 'column (current-column))) (t (cons 'column (current-column))))) '(column . 0))) (t 1))) (defun verbose-tuareg-jbuild-smie-rules (kind token) (let ((value (tuareg-jbuild-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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Linting (require 'flymake) (defun tuareg-jbuild-create-lint-script () "Create the lint script if it does not exist. This is nedded as long as See https://github.com/ocaml/dune/issues/241 is not fixed." (unless (file-exists-p tuareg-jbuild-program) (let ((dir (file-name-directory tuareg-jbuild-program)) (pgm "#!/usr/bin/env ocaml ;; #load \"unix.cma\";; #load \"str.cma\";; open Printf let filename = Sys.argv.(1) let root = try Some(Sys.argv.(2)) with _ -> None let read_all fh = let buf = Buffer.create 1024 in let b = Bytes.create 1024 in let len = ref 0 in while len := input fh b 0 1024; !len > 0 do Buffer.add_subbytes buf b 0 !len done; Buffer.contents buf let errors = let root = match root with | None | Some \"\" -> \"\" | Some r -> \"--root=\" ^ Filename.quote r in let cmd = sprintf \"jbuilder external-lib-deps %s %s\" root (Filename.quote (Filename.basename filename)) in let env = Unix.environment() in let (_,_,fh) as p = Unix.open_process_full cmd env in let out = read_all fh in match Unix.close_process_full p with | Unix.WEXITED (0|1) -> (* jbuilder will normally exit with 1 as it will not be able to perform the requested action. *) out | Unix.WEXITED 127 -> printf \"jbuilder not found in path.\\n\"; exit 1 | Unix.WEXITED n -> printf \"jbuilder exited with status %d.\\n\" n; exit 1 | Unix.WSIGNALED n -> printf \"jbuilder was killed by signal %d.\\n\" n; exit 1 | Unix.WSTOPPED n -> printf \"jbuilder was stopped by signal %d\\n.\" n; exit 1 let () = let re = \"\\\\(:?\\\\)[\\r\\n]+\\\\([a-zA-Z]+\\\\)\" in let errors = Str.global_substitute (Str.regexp re) (fun s -> let colon = Str.matched_group 1 s = \":\" in let f = Str.matched_group 2 s in if f = \"File\" then \"\\n File\" else if colon then \": \" ^ f else \", \" ^ f) errors in print_string errors")) (make-directory dir t) (append-to-file pgm nil tuareg-jbuild-program) (set-file-modes tuareg-jbuild-program #o777) ))) (defun tuareg-jbuild--temp-name (absolute-path) "Full path of the copy of the filename in `tuareg-jbuild-temporary-file-directory'." (let ((slash-pos (string-match "/" absolute-path))) (file-truename (expand-file-name (substring absolute-path (1+ slash-pos)) tuareg-jbuild-temporary-file-directory)))) (defun tuareg-jbuild-flymake-create-temp (filename _prefix) ;; based on `flymake-proc-create-temp-with-folder-structure'. (unless (stringp filename) (error "Invalid filename")) (tuareg-jbuild--temp-name filename)) (defun tuareg-jbuild--opam-files (dir) "Return all opam files in the directory DIR." (let ((files nil)) (dolist (f (directory-files-and-attributes dir t ".*\\.opam\\'")) (when (null (cadr f)) (push (car f) files))) files)) (defun tuareg-jbuild--root (filename) "Return the root and copy the necessary context files for jbuild." ;; FIXME: the root depends on jbuild-workspace. If none is found, ;; assume the commands are issued from the dir where opam files are found. (let* ((dir (locate-dominating-file (file-name-directory filename) #'tuareg-jbuild--opam-files))) (when dir (setq dir (expand-file-name dir)); In case it is ~/... (make-directory (tuareg-jbuild--temp-name dir) t) (dolist (f (tuareg-jbuild--opam-files dir)) (copy-file f (tuareg-jbuild--temp-name f) t))) dir)) (defvaralias 'tuareg-jbuild--temp-source-file-name (if (boundp 'flymake-proc--temp-source-file-name) 'flymake-proc--temp-source-file-name 'flymake-temp-source-file-name)) (defalias 'tuareg-jbuild--safe-delete-file (if (functionp #'flymake-proc--safe-delete-file) 'flymake-proc--safe-delete-file 'flymake-safe-delete-file)) (defun tuareg-jbuild--delete-opam-files (dir) "Delete all opam files in the directory DIR." (dolist (f (tuareg-jbuild--opam-files dir)) (tuareg-jbuild--safe-delete-file f))) (defun tuareg-jbuild-flymake-cleanup () "Attempt to delete temp dir created by `tuareg-jbuild-flymake-create-temp', do not fail on error." (let ((dir (file-name-directory tuareg-jbuild--temp-source-file-name)) (temp-dir (concat (directory-file-name tuareg-jbuild-temporary-file-directory) "/"))) (tuareg-jbuild--safe-delete-file tuareg-jbuild--temp-source-file-name) (condition-case nil (delete-directory (expand-file-name "_build" dir) t) (error nil)) ;; Also delete parent dirs if empty or only contain opam files (while (and (not (string-equal dir temp-dir)) (> (length dir) 0)) (condition-case nil (progn (tuareg-jbuild--delete-opam-files dir) (delete-directory dir) (setq dir (file-name-directory (directory-file-name dir)))) (error ; then top the loop (setq dir "")))))) (defalias 'tuareg-jbuild--flymake-proc-init-create-temp-buffer-copy (if (functionp #'flymake-proc-init-create-temp-buffer-copy) 'flymake-proc-init-create-temp-buffer-copy 'flymake-init-create-temp-buffer-copy)) (defun tuareg-jbuild-flymake-init () (tuareg-jbuild-create-lint-script) (let ((fname (tuareg-jbuild--flymake-proc-init-create-temp-buffer-copy 'tuareg-jbuild-flymake-create-temp)) (root (or (tuareg-jbuild--root buffer-file-name) ""))) (list tuareg-jbuild-program (list fname root)))) (defvaralias 'tuareg-jbuild--flymake-proc-allowed-file-name-masks (if (boundp 'flymake-proc-allowed-file-name-masks) 'flymake-proc-allowed-file-name-masks 'flymake-allowed-file-name-masks)) (defvar tuareg-jbuild--allowed-file-name-masks '("\\(?:\\`\\|/\\)jbuild\\'" tuareg-jbuild-flymake-init tuareg-jbuild-flymake-cleanup) "Flymake entry for jbuild files. See `flymake-proc-allowed-file-name-masks'.") (defvaralias 'tuareg-jbuild--flymake-proc-err-line-patterns (if (boundp 'flymake-proc-err-line-patterns) 'flymake-proc-err-line-patterns 'flymake-err-line-patterns)) (defvar tuareg-jbuild--err-line-patterns ;; Beware that the path from the root will be reported by jbuild ;; but flymake requires it to match the file name. '(("File \"[^\"]*\\(jbuild\\)\", line \\([0-9]+\\), \ characters \\([0-9]+\\)-\\([0-9]+\\): +\\([^\n]*\\)$" 1 2 3 5)) "Value of `flymake-err-line-patterns' for jbuild files.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Skeletons ;; See Info node "Autotype". (define-skeleton tuareg-jbuild-insert-version-form "Insert the jbuild version." nil "(jbuild_version 1" _ ")" > ?\n) (define-skeleton tuareg-jbuild-insert-library-form "Insert a library stanza." nil "(library" > \n "((name " _ ")" > \n "(public_name " _ ")" > \n "(libraries (" _ "))" > \n "(synopsis \"" _ "\")))" > ?\n) (define-skeleton tuareg-jbuild-insert-executable-form "Insert an executable stanza." nil "(executable" > \n "((name " _ ")" > \n "(public_name " _ ")" > \n "(modules (" _ "))" > \n "(libraries (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-executables-form "Insert an executables stanza." nil "(executables" > \n "((names (" _ "))" > \n "(public_names (" _ "))" > \n "(libraries (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-rule-form "Insert a rule stanza." nil "(rule" > \n "((targets (" _ "))" > \n "(deps (" _ "))" > \n "(action (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-ocamllex-form "Insert an ocamllex stanza." nil "(ocamllex (" _ "))" > ?\n) (define-skeleton tuareg-jbuild-insert-ocamlyacc-form "Insert an ocamlyacc stanza." nil "(ocamlyacc (" _ "))" > ?\n) (define-skeleton tuareg-jbuild-insert-menhir-form "Insert a menhir stanza." nil "(menhir" > \n "((modules (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-alias-form "Insert an alias stanza." nil "(alias" > \n "((name " _ ")" > \n "(deps (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-install-form "Insert an install stanza." nil "(install" > \n "((section " _ ")" > \n "(files (" _ "))))" > ?\n) (define-skeleton tuareg-jbuild-insert-copyfiles-form "Insert a copy_files stanza." nil "(copy_files " _ ")" > ?\n) (define-skeleton tuareg-jbuild-insert-documentation-form "Insert a documentation stanza." nil "(documentation" > \n "((package" _ ")" > \n "(mld_files :standard)))" > ?\n) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar tuareg-jbuild-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'compile) (define-key map "\C-c.v" 'tuareg-jbuild-insert-version-form) (define-key map "\C-c.l" 'tuareg-jbuild-insert-library-form) (define-key map "\C-c.e" 'tuareg-jbuild-insert-executable-form) (define-key map "\C-c.x" 'tuareg-jbuild-insert-executables-form) (define-key map "\C-c.r" 'tuareg-jbuild-insert-rule-form) (define-key map "\C-c.p" 'tuareg-jbuild-insert-ocamllex-form) (define-key map "\C-c.y" 'tuareg-jbuild-insert-ocamlyacc-form) (define-key map "\C-c.m" 'tuareg-jbuild-insert-menhir-form) (define-key map "\C-c.a" 'tuareg-jbuild-insert-alias-form) (define-key map "\C-c.i" 'tuareg-jbuild-insert-install-form) (define-key map "\C-c.c" 'tuareg-jbuild-insert-copyfiles-form) (define-key map "\C-c.d" 'tuareg-jbuild-insert-documentation-form) map) "Keymap used in Tuareg-jbuild mode.") (defun tuareg-jbuild-build-menu () (easy-menu-define tuareg-jbuild-mode-menu (list tuareg-jbuild-mode-map) "Tuareg-jbuild mode menu." '("Jbuild" ("Stanzas" ["version" tuareg-jbuild-insert-version-form t] ["library" tuareg-jbuild-insert-library-form t] ["executable" tuareg-jbuild-insert-executable-form t] ["executables" tuareg-jbuild-insert-executables-form t] ["rule" tuareg-jbuild-insert-rule-form t] ["ocamllex" tuareg-jbuild-insert-ocamllex-form t] ["ocamlyacc" tuareg-jbuild-insert-ocamlyacc-form t] ["menhir" tuareg-jbuild-insert-menhir-form t] ["alias" tuareg-jbuild-insert-alias-form t] ["install" tuareg-jbuild-insert-install-form t] ["copy_files" tuareg-jbuild-insert-copyfiles-form t] ))) (easy-menu-add tuareg-jbuild-mode-menu)) ;;;###autoload (define-derived-mode tuareg-jbuild-mode prog-mode "Tuareg-jbuild" "Major mode to edit jbuild files." (setq-local font-lock-defaults '(tuareg-jbuild-font-lock-keywords)) (setq-local comment-start ";") (setq-local comment-end "") (setq indent-tabs-mode nil) ;(setq-local syntax-propertize-function #'tuareg-jbuild-syntax-propertize) (setq-local require-final-newline mode-require-final-newline) (push tuareg-jbuild--allowed-file-name-masks tuareg-jbuild--flymake-proc-allowed-file-name-masks) (smie-setup tuareg-jbuild-smie-grammar #'tuareg-jbuild-smie-rules) (setq-local tuareg-jbuild--flymake-proc-err-line-patterns tuareg-jbuild--err-line-patterns) (when (and tuareg-jbuild-flymake buffer-file-name) (flymake-mode t)) (tuareg-jbuild-build-menu) (run-mode-hooks 'tuareg-jbuild-mode-hook)) ;;;###autoload (add-to-list 'auto-mode-alist '("\\(?:\\`\\|/\\)jbuild\\(?:\\.inc\\)?\\'" . tuareg-jbuild-mode)) (provide 'tuareg-jbuild-mode)