;;; beluga-mode.el --- Major mode for Beluga source code -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2009-2018 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Maintainer: beluga-dev@cs.mcgill.ca
;; Version: 0
;; Keywords:
;; 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 3 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, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; BUGS
;; - Indentation thinks "." can only be the termination marker of
;; an LF declaration. This can mess things up badly.
;; - Indentation after curried terms like "fn x => fn y =>" is twice that
;; after "fn x y =>".
;;; Code:
(eval-when-compile (require 'cl-lib))
(require 'smie)
(require 'ansi-color)
(add-hook 'compilation-filter-hook 'ansi-color-compilation-filter)
(provide 'beluga-unicode-input-method)
(require 'quail)
(defconst beluga-input-method-name
"beluga-unicode"
"The name of the Beluga unicode input method.")
(quail-define-package
beluga-input-method-name ;; name
"UTF-8" ;; language
"B" ;; mode-line "title"
t ;; guidance
"Beluga unicode input method: actually replaces keyword strings with
a single unicode character instead of merely representing the keywords
in unicode using Font Lock mode."
nil nil nil nil nil nil nil nil nil nil t)
;; This very final t is the SIMPLE flag of quail-define-package, and
;; causes Quail to not affect the meanings of C-{f,b,n,p} or TAB.
(quail-define-rules
;; Greek letters
("\\alpha" ["α"])
("\\Alpha" ["Α"])
("\\beta" ["β"])
("\\Beta" ["Β"])
("\\gamma" ["γ"])
("\\Gamma" ["Γ"])
("\\delta" ["δ"])
("\\Delta" ["Δ"])
("\\epsilon" ["ε"])
("\\Epsilon" ["Ε"])
("\\zeta" ["ζ"])
("\\Zeta" ["Ζ"])
("\\eta" ["η"])
("\\Eta" ["Η"])
("\\theta" ["θ"])
("\\Theta" ["Θ"])
("\\iota" ["ι"])
("\\Iota" ["Ι"])
("\\kappa" ["κ"])
("\\Kappa" ["Κ"])
("\\lambda" ["λ"])
("\\Lambda" ["Λ"])
("\\lamda" ["λ"])
("\\Lamda" ["Λ"])
("\\mu" ["μ"])
("\\Mu" ["Μ"])
("\\nu" ["ν"])
("\\Nu" ["Ν"])
("\\xi" ["ξ"])
("\\Xi" ["Ξ"])
("\\omicron" ["ο"])
("\\Omicron" ["Ο"])
("\\pi" ["π"])
("\\Pi" ["Π"])
("\\rho" ["ρ"])
("\\Rho" ["Ρ"])
("\\sigma" ["σ"])
("\\Sigma" ["Σ"])
("\\tau" ["τ"])
("\\Tau" ["Τ"])
("\\upsilon" ["υ"])
("\\Upsilon" ["Υ"])
("\\phi" ["φ"])
("\\Phi" ["Φ"])
("\\chi" ["χ"])
("\\Chi" ["Χ"])
("\\psi" ["ψ"])
("\\Psi" ["Ψ"])
("\\omega" ["ω"])
("\\Omega" ["Ω"])
;; Common logical symbol
("\\conj" ["∧"])
("\\disj" ["∨"])
("\\imp" ["⊃"])
("\\top" ["⊤"])
("\\bot" ["⊥"])
("\\equiv" ["≣"])
;; Arrows
("->" ["→"])
("<-" ["←"])
("=>" ["⇒"])
;;LF
("|-" ["⊢"])
("\\not" ["¬"])
("::" ["∷"])
("FN" ["Λ"])
)
(defgroup beluga-mode ()
"Editing support for the Beluga language."
:group 'languages)
(defvar beluga-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-c" 'compile)
(define-key map "\C-c\C-l" 'beluga-highlight-holes)
(define-key map "\C-c\C-e" 'beluga-erase-holes)
(define-key map "\C-c\C-x" 'beluga-run-command)
(define-key map "\C-c\C-t" 'beluga-get-type)
(define-key map "\C-c\C-s" 'beluga-split-hole)
(define-key map "\C-c\C-i" 'beluga-intro-hole)
(define-key map "\C-c\C-j" 'beluga-hole-jump)
(define-key map "\C-c\C-p" 'beluga-hole-info)
map))
(defvar beluga-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?% "< 14" st)
(modify-syntax-entry ?\{ "(}2 b" st)
(modify-syntax-entry ?\} "){3 b" st)
(modify-syntax-entry ?\n ">" st)
(modify-syntax-entry ?/ "$/" st)
;; For application of dependent arguments "exp A < ctx . term >", we'd want
;; <..> to match, but that breaks ->, <-, and other things.
;; (modify-syntax-entry ?< "(>" st)
;; (modify-syntax-entry ?> ")<" st)
; see https://emacs.stackexchange.com/a/4149 for a possible solution
(modify-syntax-entry ?# "'" st)
(modify-syntax-entry ?< "." st)
(modify-syntax-entry ?> "." st)
(modify-syntax-entry ?- "." st)
(modify-syntax-entry ?| "." st)
(modify-syntax-entry ?= "." st)
(modify-syntax-entry ?\' "_" st)
st))
(defun beluga--proc-live-p (process)
"Return non-nil if PROCESS is alive.
A process is considered alive if its status is `run', `open',
`listen', `connect' or `stop'."
(and (not (eq process nil))
(memq (process-status process)
'(run open listen connect stop))))
(defun beluga-font-lock-compose-symbol (alist)
"Compose a sequence of ascii chars into a symbol.
Regexp match data 0 points to the chars."
;; Check that the chars should really be composed into a symbol.
(let* ((start (match-beginning 0))
(end (match-end 0))
(syntaxes (cond
((eq (char-syntax (char-after start)) ?w) '(?w))
;; Special case for the . used for qualified names.
((and (eq (char-after start) ?\.) (= end (1+ start)))
'(?_ ?\\ ?w))
(t '(?_ ?\\))))
sym-data)
(if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
(memq (char-syntax (or (char-after end) ?\ )) syntaxes)
(memq (get-text-property start 'face)
'(font-lock-doc-face font-lock-string-face
font-lock-comment-face))
(and (consp (setq sym-data (cdr (assoc (match-string 0) alist))))
(let ((pred (cadr sym-data)))
(setq sym-data (car sym-data))
(funcall pred start))))
;; No composition for you. Let's actually remove any composition
;; we may have added earlier and which is now incorrect.
(remove-text-properties start end '(composition))
;; That's a symbol alright, so add the composition.
(compose-region start end sym-data)))
;; Return nil because we're not adding any face property.
nil)
(defun beluga-font-lock-symbols-keywords ()
(when (and (fboundp 'compose-region) beluga-font-lock-symbols)
(let ((alist nil))
(dolist (x beluga-font-lock-symbols-alist)
(when (and (if (fboundp 'char-displayable-p)
(char-displayable-p (if (consp (cdr x)) (cadr x) (cdr x)))
t)
(not (assoc (car x) alist))) ;Not yet in alist.
(push x alist)))
(when alist
`((,(regexp-opt (mapcar #'car alist) t)
(0 (beluga-font-lock-compose-symbol ',alist)
;; In Emacs-21, if the `override' field is nil, the face
;; expressions is only evaluated if the text has currently
;; no face. So force evaluation by using `keep'.
keep)))))))
(defconst beluga-syntax-id-re
"[[:alpha:]_][[:alnum:]_']*"
"A regexp for matching a Beluga identifier.")
(defconst beluga-syntax-fundec-re
(regexp-opt '("rec" "proof") 'symbols)
"A regexp for matching a function declaration.
Note that this will also match the 'and' keyword!")
(defvar beluga-imenu-generic-expression
`(("Schemas"
,(concat "^[ \t]*schema[ \t\n]+\\(" beluga-syntax-id-re "\\)") 1)
("Constructors"
,(concat "^\\(" beluga-syntax-id-re "\\)[ \t\n]*:") 1)
("Type Constructors"
,(concat "^\\(?:inductive[ \t]+\\(" beluga-syntax-id-re
"\\)\\|\\(?1:" beluga-syntax-id-re
"\\)[ \t\n]*:[^.]*\\<type\\>[ \t\n]*.\\)")
1)
("Functions"
,(concat beluga-syntax-fundec-re "[ \t\n]+\\(" beluga-syntax-id-re "\\)") 1)))
(define-obsolete-variable-alias 'beluga-interpreter-path
;; A "path" is a list of file names, as in $PATH, $MANPATH.
'beluga-interpreter-name "Sep-2010")
(defcustom beluga-interpreter-name "beluga"
"Name of the interpreter executable."
:type 'string)
;;---------------------------- Interactive mode ----------------------------;;
(define-error 'beluga-interactive-error "Beluga interactive error")
(defun beluga-interactive-error (&rest data)
(signal 'beluga-interactive-error data))
;; ------ process management ----- ;;
(defvar beluga--proc ()
"Contain the process running beli.")
(make-variable-buffer-local 'beluga--proc)
(defvar beluga--output-wait-time
0.025
"How long to wait for output from Beluga on each iteration.")
(defvar beluga--output-timeout
1.0
"How long to wait in total for output before giving up.")
(defvar beluga--output-timer 0.0)
(defun beluga--proc ()
(unless (beluga--proc-live-p beluga--proc) (beluga-start))
beluga--proc)
(defun beluga-start ()
"Start an inferior Beluga Interactive process with the -emacs option.
The process is put into a buffer called \"*beluga*\"."
(interactive)
(unless (beluga--proc-live-p beluga--proc)
(setq beluga--proc
(get-buffer-process
(make-comint "beluga"
beluga-interpreter-name
nil "-I" "-emacs" ))))
beluga--proc)
(defun beluga-quit ()
"Stop the Beluga interactive process by sending the quit command.
This is a graceful termination."
(interactive)
(beluga--rpc "quit"))
(defun beluga-stop ()
"Stop the beli process."
(interactive)
(when (processp 'beluga--proc)
(kill-process 'beluga--proc)))
;; ----- Stuff for hole overlays ----- ;;
(defvar beluga--holes-overlays ()
"Will contain the list of hole overlays so that they can be resetted.")
(make-variable-buffer-local 'beluga--holes-overlays)
(defun beluga-sorted-holes ()
(cl-labels
((hole-comp (a b)
(let* ((s1 (overlay-start a))
(s2 (overlay-start b)))
(< s1 s2))))
(sort beluga--holes-overlays #'hole-comp)))
(defface beluga-holes
'((t :background "cyan")) ;; :foreground "white"
"Face used to highlight holes in Beluga mode.")
(defun beluga--pos (line bol offset)
;; According to http://caml.inria.fr/mantis/view.php?id=5159,
;; `line' can refer to line numbers in various source files,
;; whereas `bol' and `offset' refer to "character" (byte?) positions within
;; the actual parsed stream.
;; So if there might be #line directives, we need to do:
;; (save-excursion
;; (goto-char (point-min))
;; (forward-line (1- line)) ;Lines count from 1 :-(
;; (+ (point) (- offset bol))))
;; But as long as we know there's no #line directive, we can ignore all that
;; and use the more efficient code below. When #line directives can appear,
;; we will need to make further changes anyway, such as passing the file-name
;; to select the appropriate buffer.
;; Emacs considers the first character in the file to be at index 1,
;; but the Beluga lexer starts counting at zero, so we need to add
;; one here.
(+ (point-min) offset))
(defun beluga--create-overlay (pos)
"Create an overlay at the position described by POS (a Loc.to_tuple)."
(let* (;; (file-name (nth 0 pos))
(start-line (nth 1 pos))
(start-bol (nth 2 pos))
(start-off (nth 3 pos))
(stop-line (nth 4 pos))
(stop-bol (nth 5 pos))
(stop-off (nth 6 pos))
(ol
(make-overlay (beluga--pos start-line start-bol start-off)
(beluga--pos stop-line stop-bol stop-off))))
(overlay-put ol 'face 'beluga-holes)
ol))
(defun beluga-erase-holes ()
(interactive)
(mapc #'delete-overlay beluga--holes-overlays)
(setq beluga--holes-overlays nil))
;; ----- Interaction with the interactive mode ----- ;;
;; Sending and receiving strings from the inferior process.
;; Ultimately, all you really need to use is beluga--rpc to send a
;; command to the interactive mode and get back a string response.
(defun beluga--wait (proc)
(assert (eq (current-buffer) (process-buffer proc)))
(setq beluga--output-timer 0.0)
(while (progn
(goto-char comint-last-input-end)
(not (re-search-forward ".*?;" nil t)))
(accept-process-output proc beluga--output-wait-time)
(setq beluga--output-timer (+ beluga--output-timer beluga--output-wait-time))
(when (> beluga--output-timer beluga--output-timeout)
(error "Beluga command didn't produce complete output"))))
(defun beluga--chomp (str)
"Chomp leading and tailing whitespace from STR."
(replace-regexp-in-string (rx (or (: bos (* (any " \t\n")))
(: (* (any " \t\n")) eos)))
""
str))
(defun beluga--trim (str)
(let ((str2 (beluga--chomp str)))
(substring str2 0 (1- (length str2)))))
(defun beluga--send (cmd)
"Send CMD to beli."
; (interactive)
(let ((proc (beluga--proc)))
(with-current-buffer (process-buffer proc)
;; We could also just use `process-send-string', but then we wouldn't
;; have the input text in the buffer to separate the various prompts.
(goto-char (point-max))
(insert (concat "%:" cmd))
(comint-send-input)
(beluga--wait proc))))
(defun beluga--receive ()
"Read the last output of beli."
(let ((proc (beluga--proc)))
(with-current-buffer (process-buffer proc)
(beluga--wait proc)
(beluga--trim (buffer-substring-no-properties comint-last-input-end (point-max))))))
(defun beluga--rpc (cmd)
(beluga--send cmd)
(beluga--receive))
(defun beluga--is-response-error (resp)
"Determine whether a Beluga RPC response (RESP) is an error."
(string= "-" (substring resp 0 1)))
(defun beluga--rpc! (cmd)
"Variant of beluga--rpc that signals an error if CMD fails."
(let ((resp (beluga--rpc cmd)))
(when (beluga--is-response-error resp)
(beluga-interactive-error (list (format "%s" (substring resp 2)))))
resp))
(defvar beluga--last-load-time
'(0 0 0 0)
"The last time the file was loaded into the Beluga interpreter.
This variable is updated by `beluga--maybe-save-load-current-buffer'.")
(make-variable-buffer-local 'beluga--last-load-time)
(defun beluga--should-reload-p ()
"Decide whether the current buffer should be reloaded into beli.
The `visited-file-modtime' is compared to `beluga--last-load-time'.
If the former is greater than the latter, then the former is
returned. Else, nil is returned."
(let ((mtime (visited-file-modtime)))
(when (> (float-time mtime) (float-time beluga--last-load-time))
mtime)))
;; ----- Beluga Interactive basic functions ----- ;;
;; Each of these functions directly corresponds to a command in src/core/command.ml
;; Since the construction of these functions is totally tedious and
;; straightforward, we define a macro to do the real work.
;; This macro takes:
;; * the name of the function to define, e.g. beluga--printhole
;; * the real name of the command to invoke, e.g. "printhole"
;; * the arguments of the function, e.g. '((hole . "%s"))
;;
;; Note: the type of each argument is specified as a printf-style
;; format code. That's because the construction of the command will
;; construct a string formatting routine using these codes.
;;
;; What about constant portions of the string?
;; If you want to supply a constant portion in the format string,
;; simply provide a string as-is in the argument list.
;; e.g. ((hole . "%s") "with" (exp . "%s"))
;;
;; Two separate functions are generated by the macro invocation. The
;; first uses exactly the given function name, but the second appends
;; "!". This bang-variant will use beluga--rpc! under the hood, so you
;; get an exception-raising variant of every function for free.
(defun beluga--generate-format-string (args)
"Construct the format string from the ARGS."
(cons
"%s"
(mapcar
(lambda (x)
(if (stringp x)
x
(cdr x)))
args)))
(defun beluga--generate-arg-list (args)
"Construct a list of symbols representing the function arguments from ARGS."
(mapcar 'car (cl-remove-if 'stringp args)))
(defun beluga--define-command (rpc name realname args)
(let ((arglist (beluga--generate-arg-list args))
(fmt (beluga--generate-format-string args)))
`(defun ,name ,arglist
(,rpc
(format
;; construct the format string
,(mapconcat 'identity fmt " ")
;; construct the argument list
,realname ,@arglist)))))
(defmacro beluga-define-command (name realname args)
`(progn
,(beluga--define-command 'beluga--rpc name realname args)
,(beluga--define-command 'beluga--rpc! (intern (concat (symbol-name name) "!")) realname args)))
(beluga-define-command beluga--basic-chatteron "chatteron" nil)
(beluga-define-command beluga--basic-chatteroff "chatteroff" nil)
(beluga-define-command beluga--basic-load "load" ((path . "%s")))
(beluga-define-command beluga--basic-clearholes "clearholes" nil)
(beluga-define-command beluga--basic-countholes "countholes" nil)
(beluga-define-command beluga--basic-lochole "lochole" ((hole . "%s")))
(beluga-define-command beluga--basic-lochole-n "lochole" ((hole . "%d")))
(beluga-define-command beluga--basic-printhole "printhole" ((hole . "%s")))
(beluga-define-command beluga--basic-printhole-n "printhole" ((hole . "%d")))
(beluga-define-command beluga--basic-types "types" nil)
(beluga-define-command beluga--basic-constructors-lf "constructors" ((type . "%s")))
(beluga-define-command beluga--basic-fill "fill" ((hole . "%s") "with" (exp . "%s")))
(beluga-define-command beluga--basic-split "split" ((hole . "%s") (var . "%s")))
(beluga-define-command beluga--basic-intro "intro" ((hole . "%s")))
(beluga-define-command beluga--basic-constructors "constructors-comp" ((type . "%s")))
(beluga-define-command beluga--basic-signature "fsig" ((fun . "%s")))
(beluga-define-command beluga--basic-printfun "fdef" ((fun . "%s")))
(beluga-define-command beluga--basic-query "query" ((expected . "%s") (tries . "%s") (type . "%s")))
(beluga-define-command beluga--basic-get-type "get-type" ((line . "%d") (col . "%d")))
(beluga-define-command beluga--basic-reset "reset" nil)
(beluga-define-command beluga--basic-quit "quit" nil)
(beluga-define-command beluga--basic-lookuphole "lookuphole" ((hole . "%s")))
;; ----- Higher-level commands ----- ;;
;; These build off the basic commands, and will typically do something
;; like parse the response or display it in a message.
(defun beli ()
"Start beli mode."
(interactive)
(beluga-start))
(defun beluga-run-command (cmd)
"Run CMD in beli."
(interactive "MCommand: ")
(message "%s" (beluga--rpc cmd)))
(defun beluga--maybe-save ()
(if (buffer-modified-p)
(if (y-or-n-p "Save current file? ")
(save-buffer)
())))
(defun beluga-get-type ()
"Get the type at the current cursor position (if it exists)."
(interactive)
(message "%s" (beluga--basic-get-type (count-lines 1 (point)) (current-column))))
(defun beluga--load-current-buffer (&optional mtime)
"Load the current buffer in Beluga Interactive.
This command signals an error if loading fails.
The optional MTIME parameter, if given, will be written to `beluga--last-load-time'."
(let ((resp (beluga--basic-load! (buffer-file-name))))
(when mtime
(setq beluga--last-load-time mtime))
resp))
(defun beluga--maybe-save-load-current-buffer ()
"Load the current buffer if it has either never been loaded, or
modified since the last time it was loaded.
This will update `beluga--last-load-time' if a load is performed."
;; prompt the user to save the buffer if it is modified
(beluga--maybe-save)
;; retrieve the last time the file was written to disk, checking
;; whether a reload should occur
(let ((mtime (beluga--should-reload-p)))
(when mtime ;; mtime non-nil means we must reload
(beluga--load-current-buffer mtime))))
(defun beluga--lochole-n! (hole-num)
(read (beluga--basic-lochole-n! hole-num)))
(defun beluga--countholes! ()
"Get the number of holes in the file."
(string-to-number (beluga--basic-countholes!)))
(defun beluga--lookup-hole! (hole)
"Look up a hole number by its name (HOLE)."
(string-to-number (beluga--basic-lookuphole! hole)))
(defun beluga--highlight-holes ()
"Create overlays for each of the holes and color them."
(beluga-erase-holes)
(let ((numholes (beluga--countholes!)))
(dotimes (i numholes)
(let* ((pos (beluga--lochole-n! i))
(ol (beluga--create-overlay pos))
(info (beluga--basic-printhole-n! i)))
(overlay-put ol 'help-echo info)
(push ol beluga--holes-overlays)
))))
(defun beluga--get-hole-overlay! (hole)
"Get the overlay associated with HOLE."
(nth (beluga--lookup-hole! hole) (beluga-sorted-holes)))
(defun beluga--apply-quail-completions (str)
(if (string= current-input-method beluga-input-method-name)
(replace-regexp-in-string "=>" "⇒"
(replace-regexp-in-string "|-" "⊢" str))
str))
(defun beluga--insert-formatted (str start)
(goto-char start)
(insert (beluga--apply-quail-completions str))
(indent-region start (+ start (length str))))
(defun beluga--error-no-such-hole (n)
(message "Couldn't find hole %s - make sure the file is loaded" n))
(defconst beluga-named-hole-re
"\\_<?\\(\\sw+\\)\\_>")
(defun beluga-named-hole-at-point ()
"Retrieve the name of the hole at point, if any.
If e.g. point is over \"?abracadabra\", then this function returns
\"abracadabra\". Else, if point is not over a valid hole, then this
function returns nil."
(let ((thing (thing-at-point 'symbol)))
(when (and thing (string-match beluga-named-hole-re thing))
(match-string 1 thing))))
(defun beluga--prompt-with-hole-at-point (prompt)
"Prompt the user to specify a hole, giving the named hole at point
as the default if any."
(let ((name (beluga-named-hole-at-point)))
(if name
(read-string (format "%s (%s): " prompt name)
nil nil name)
(read-string (format "%s: " prompt)))))
(defun beluga--begin-command ()
"Perform necessary setup to begin a compound Beluga Interactive command.
Specifically, the following are performed, if necessary:
- Starting the Beluga inferior process.
- Saving the current buffer.
- Loading the current buffer into Beluga.
- Highlighting holes."
(beluga-start)
(beluga--maybe-save-load-current-buffer)
(beluga--highlight-holes))
(defun beluga--prompt-string (prompt)
"Prompts the user to input a string."
(read-string (format "%s: " prompt)))
;; ----- Top-level commands ----- ;;
(defun beluga-load ()
"Load the current file in Beluga Interactive.
This command will start the interactive mode if necessary and
prompt for saving."
(interactive)
(beluga-start)
(let ((r (beluga--maybe-save-load-current-buffer)))
(if r
(message "%s" r)
(message "Buffer does not require reload."))))
(defun beluga-highlight-holes ()
"Create overlays for each of the holes and color them."
(interactive)
(beluga--begin-command))
(defun beluga-hole-info (hole)
(interactive
(list
(beluga--prompt-with-hole-at-point "Hole to query")))
(beluga--begin-command)
(let ((resp (beluga--basic-printhole! hole)))
(message resp)))
(defun beluga-split-hole (hole var)
"Split on HOLE."
(interactive
(list
(beluga--prompt-with-hole-at-point "Hole to split at")
(beluga--prompt-string "Variable to split")))
(beluga--begin-command)
(let ((resp (beluga--basic-split! hole var))
(ovr (beluga--get-hole-overlay! hole)))
(if ovr
(let ((start (overlay-start ovr))
(end (overlay-end ovr)))
(delete-overlay ovr)
(delete-region start end)
(beluga--insert-formatted (format "(%s)" resp) start)
(save-buffer)
(beluga--load-current-buffer)
(beluga--highlight-holes))
(beluga--error-no-such-hole hole))))
(defun beluga-intro-hole (hole)
"Introduce variables into HOLE"
(interactive
(list
(beluga--prompt-with-hole-at-point "Hole to introduce variables into")))
(beluga--begin-command)
(let ((resp (beluga--basic-intro! hole))
(ovr (beluga--get-hole-overlay! hole)))
(if ovr
(let ((start (overlay-start ovr))
(end (overlay-end ovr)))
(delete-overlay ovr)
(delete-region start end)
(beluga--insert-formatted resp start)
(save-buffer)
(beluga--load-current-buffer)
(beluga--highlight-holes))
(beluga--error-no-such-hole hole))))
(defun beluga-hole-jump (hole)
(interactive "sHole to jump to: ")
(beluga--begin-command)
(let ((ovr (beluga--get-hole-overlay! hole)))
(if ovr
(goto-char (+ 1 (overlay-start ovr)))
(beluga--error-no-such-hole hole))))
(define-obsolete-function-alias 'hole-jump #'beluga-hole-jump "Jul-2018")
;; ----- Beluga indentation and navigation via SMIE ----- ;;
(defconst beluga-syntax-pragma-re
"--\\(\\(name\\|query\\|infix\\|prefix\\|assoc\\).*?\\.\\|\\w+\\)"
"A regexp for matching a Beluga pragma.
Long pragmas continue until a `.` is found, e.g. `--name oft D.`.
Short pragmas consist of only one word, e.g. `--nostrengthen`.
It's easy to use this regex to check which type of pragma (long or short)
was matched: simply check whether `match-string' 2 is non-nil. In that case,
a long pragma was matched and the result is the name of the long pragma.
Otherwise, `match-string' 1 will contain the name of the matched short.")
(defconst beluga-slim-arrows
'("->" "<-" "→" "←")
"A list of the slim arrow strings.")
(defconst beluga-fat-arrows
'("=>" "⇒")
"A list of the fat arrow strings.")
(defconst beluga-punct-re
(regexp-opt `(,@beluga-fat-arrows ,@beluga-slim-arrows "\\" "." "<" ">" "," ";" "..")))
(defconst beluga-syntax-keyword-re
(regexp-opt
'("FN" "and" "block" "case" "inductive" "LF" "coinductive"
"stratified" "else" "ffalse" "fn" "if" "in" "impossible" "let"
"mlam" "of" "rec" "proof" "schema" "some" "then" "type" "ctype" "ttrue"
"typedef"
"module" "struct" "end" "#stratified" "#positive" "fun")
'symbols)
"A regular expression to match any beluga keyword.")
(defface beluga-font-lock-annotation
'((t :inherit italic))
"Face used for Beluga's /.../ annotations.")
(defconst beluga-font-lock-keywords
`((,beluga-syntax-pragma-re . ,font-lock-warning-face)
,beluga-syntax-keyword-re
("/\\s-*\\_<\\(total\\)\\_>.*?/"
(0 'beluga-font-lock-annotation)
(1 'font-lock-keyword-face prepend))
(,(concat
"^\\(" beluga-syntax-id-re "\\)"
"\\s-*" ":"
"\\([^.]*\\_<type\\_>\\s-*.\\)?")
;; This is a regexp that can span multiple lines, so it may not
;; always highlight properly. `font-lock-multiline' tries to help.
(0 (if (match-end 2) '(face nil font-lock-multiline t)))
(1 (if (match-end 2)
font-lock-type-face font-lock-variable-name-face)))
(,(concat "^\\(?:schema\\|inductive\\|coinductive\\|LF\\|stratified\\)" "\\s-+"
"\\(" beluga-syntax-id-re "\\)")
(1 font-lock-type-face))
(,(concat beluga-syntax-fundec-re "\\s-+\\(" beluga-syntax-id-re "\\)")
(2 font-lock-function-name-face))
))
(defcustom beluga-indent-basic 4
"Basic amount of indentation."
:type 'integer)
(defun beluga-smie-forward-token ()
; skip all whitespace and comments
(forward-comment (point-max))
(cond
((looking-at "\\.[ \t]*$")
;; One of the LF-terminating dots.
(progn (forward-char 1) ";."))
((looking-at beluga-syntax-pragma-re)
;; move point to the end of the long-pragma name if a long-pragma was matched.
;; otherwise, move it to the end of the short pragma name.
(goto-char (or (match-end 2) (match-end 1)))
;; set to non-nil by beluga-syntax-pragma-re if the pragma is a long-form pragma
(if (match-string 2)
"--longpragma"
"--shortpragma"))
(t
; otherwise, we return a chunk of text that starts at point and
; ends according to the following `cond` check.
(buffer-substring-no-properties
(point)
(progn
(cond
((looking-at beluga-punct-re) (goto-char (match-end 0)))
((not (zerop (skip-syntax-forward "w_'"))))
;; In case of non-ASCII punctuation.
((not (zerop (skip-syntax-forward ".")))))
(point))))))
(defun beluga-short-pragma-before-p ()
"Decide whether there is a short pragma before point.
Return the starting position of the short pragma; else, nil."
(save-excursion
;; idea: move backward across word-characters, and then check if
;; there are two dashes before point.
(skip-syntax-backward "w")
(save-match-data
(when (looking-back "--" (- (point) 2))
(match-beginning 0)))))
(defun beluga-smie-backward-token ()
(forward-comment (- (point-max)))
(cond
((and (eq ?\. (char-before))
(looking-at "[ \t]*$") ;; "[ \t]*\\(?:$\\|[0-9]\\(\\)\\)"
(not (looking-back "\\.\\." (- (point) 2))))
;; Either an LF-terminating dot, or a projection-dot.
(progn (forward-char -1) ";."))
((setq pos (beluga-short-pragma-before-p))
(goto-char pos)
"--shortpragma")
(t
(buffer-substring-no-properties
(point)
(progn
(cond
((looking-back beluga-punct-re (- (point) 2) 'greedy)
(goto-char (match-beginning 0)))
((not (zerop (skip-syntax-backward "w_'"))))
;; In case of non-ASCII punctuation.
((not (zerop (skip-syntax-backward ".")))))
(point))))))
(defun beluga-smie-grammar (bnf resolvers precs)
(smie-prec2->grammar
(smie-merge-prec2s
(apply #'smie-bnf->prec2 bnf resolvers)
(smie-precs->prec2 precs))))
(defconst beluga-smie-grammar
;; The "." used for terminating LF declarations is syntactically completely
;; different from the "." used in the binding forms. Conflating the two
;; leads here to a lot of precedence conflicts, so we try and guess the two
;; based on a heuristic in the tokenizing code.
(beluga-smie-grammar
;; FIXME: without this dummy, "=>" is marked as "open paren" because it
;; can only bind to `atom' on the left.
'((atom ("--dummy--"))
(def (exp "=" exp) (atom ":" exp))
(decl
(atom ":" type)
(datatypes)
("schema" sdef)
("let" def)
("--shortpragma")
("--longpragma" atom)
(recs))
(datatypes
("inductive" datatype-def)
("coinductive" datatype-def)
("LF" datatype-def)
("stratified" datatype-def)
(datatypes "and" datatypes))
(simpletype
(simpletype "->" simpletype)
(simpletype "→" simpletype)
(simpletype "←" simpletype)
(simpletype "<-" simpletype))
(recs
("rec" def)
("proof" def)
(recs "and" recs))
(decls
(decl)
(decls ";" decls)
(decls ";." decls))
;; FIXME: only allow simple types here, otherwise we get nasty
;; precedence conflicts between "." and ",". In practice, this seems to
;; be sufficient.
(sdecl
(atom ":" type))
(sdecls
(sdecl)
(sdecls "," sdecls))
(dotted-type
(sdecls "|-" type)
(sdecls "⊢" type))
(type
(simpletype)
("\\" atom "." type) ;dotted-type
("block" sdecls "." type) ;dotted-type
;; ("{" blabla "}" type) ; FIXME!
;; FIXME: the projection via "." creates precedence conflicts.
;; (type "." atom)
)
(sdef
(atom "=" schema))
(schema
(type)
;; Not sure if it's correct, and create precedence conflicts.
;; ("some" sdecls "block" sdecls "." schema)
)
(datatype-name
(atom ":" type))
(datatype-def
(datatype-name "=" datatype-branches))
(datatype-branches
(datatype-branches "|" datatype-branches)
(atom ":" type))
(exp
("if" exp "then" exp "else" exp)
(type)
("let" def "in" exp)
("fun" atom "=>" exp)
("fun" atom "⇒" exp)
("fn" atom "=>" exp)
("fn" atom "⇒" exp)
("FN" atom "=>" exp)
("FN" atom "⇒" exp)
("mlam" atom "=>" exp)
("mlam" atom "⇒" exp)
("<" dotted-type ">")
("case" exp "of" cases))
(exps
(exps ";" exps)
(exp))
;; Separate cases/branch so that "|" is recognized as associative.
(cases
(branch)
(cases "|" cases))
(branch
(atom "=>" exp)
(atom "⇒" exp)))
; resolvers
`(((assoc ";" ";."))
((assoc ,@beluga-slim-arrows))
((assoc ","))
((assoc "and"))
((nonassoc "of") (assoc "|")) ; Trailing | ambiguity.
;; '((nonassoc "\\") (nonassoc ".")) ; Trailing . ambiguity.
;; '((nonassoc "block") (nonassoc ".")) ; Trailing . ambiguity.
)
;; The above BNF grammar should cover this already, so this ends up only
;; useful to check that the BNF entails the expected precedences.
; precs
`((assoc ";")
(assoc ",")
(left ":")
(assoc ,@beluga-slim-arrows)
(nonassoc " -dummy- ")))) ;Bogus anchor at the end.
(defconst beluga-pattern-fat-arrow
`(or ,@beluga-fat-arrows)
"A pattern for use in pcase that matches any fat arrow string.")
(defun beluga-rule-parent-p (parents)
`(smie-rule-parent-p ,@parents))
(defun beluga-smie-indent-rules (method token)
(pcase `(,method . ,token)
(`(:elem . basic)
beluga-indent-basic)
; describe the tokens that introduce lists (with no separators)
(`(:list-intro . ,(or ":" "fn" "fun" "FN" "mlam"))
't)
; if the token is a pipe preceded by an '=' or 'of', then we
; indent by adding the basic offset
(`(:before . ,(and "|" (guard (smie-rule-prev-p "=" "of" "fun"))))
2)
; if the token is a pipe, (and the preceding check didn't pass, so
; it isn't the first pipe in a sequence) then we consider it a
; separator
(`(method . ,"|")
(smie-rule-separator method))
(`(:after . ,"of")
beluga-indent-basic)
(`(:after . ,"in")
(when (smie-rule-hanging-p)
(smie-rule-parent)))
(`(:after . ,(and "=" (guard (smie-rule-parent-p "rec"))))
(smie-rule-parent))
(`(:after . ,(and "=" (guard (smie-rule-parent-p "proof"))))
(smie-rule-parent))
; if the token is a form that will use => eventually but is
; preceded by a =>, then this is a chain, e.g.
; mlam G => mlam Q => fn x => fn y =>
; (code should be here, not indented 8 characters)
(`(:before
.
,(and
(or "case" "fn" "FN" "mlam" "fun")
(guard `(smie-rule-prev-p ,@beluga-fat-arrows))))
(smie-rule-parent))
(`(:after . ".")
(smie-rule-parent))
(`(:after . ,(and ":" (guard (smie-rule-parent-p "{"))))
(smie-rule-parent 1))
(`(:after . ,(or ":" "let" "if"))
(smie-rule-parent beluga-indent-basic))
(`(:before
.
,(and "=" (guard `(smie-rule-parent-p ,@beluga-type-declaration-keywords))))
(smie-rule-parent))
))
;;---------------------------- Loading of the mode ----------------------------;;
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.s?bel\\'" . beluga-mode))
(defconst beluga-type-declaration-keywords
'("inductive" "coinductive" "LF" "stratified")
"The different keywords that introduce a type definition.")
(defconst beluga-type-declaration-keywords-re
(regexp-opt beluga-type-declaration-keywords 'symbols)
"A regular expression that matches any type definition keyword.")
;;;###autoload
(define-derived-mode beluga-mode prog-mode "Beluga"
"Major mode to edit Beluga source code."
(set (make-local-variable 'imenu-generic-expression)
beluga-imenu-generic-expression)
(set (make-local-variable 'outline-regexp)
(concat beluga-syntax-fundec-re "\\|^(inductive\\|coinductive\\|LF\\|stratified)\\_>"))
(set (make-local-variable 'require-final-newline) t)
(when buffer-file-name
(set (make-local-variable 'compile-command)
;; Quite dubious, but it's the intention that counts.
(concat beluga-interpreter-name
" "
(shell-quote-argument buffer-file-name))))
(set (make-local-variable 'comment-start) "%")
(set (make-local-variable 'comment-start-skip) "%[%{]*[ \t]*")
(set (make-local-variable 'comment-end-skip) "[ \t]*\\(?:\n\\|}%\\)")
(comment-normalize-vars)
(set (make-local-variable 'electric-indent-chars)
(append '(?|) (if (boundp 'electric-indent-chars)
electric-indent-chars
'(?\n))))
;QUAIL
(add-hook 'beluga-mode-hook
(lambda () (set-input-method "beluga-unicode")))
;Turn off hilighting
(setq input-method-highlight-flag nil)
(smie-setup
beluga-smie-grammar
'beluga-smie-indent-rules
:forward-token #'beluga-smie-forward-token
:backward-token #'beluga-smie-backward-token)
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set
(make-local-variable 'font-lock-defaults)
'(beluga-font-lock-keywords
nil
nil
()
nil
(font-lock-syntactic-keywords . nil)))
(message "beluga-mode loaded"))
(provide 'beluga-mode)
;;; beluga-mode.el ends here
