├── .gitignore ├── LICENSE ├── README.md ├── highlights.scm ├── matches.scm ├── smelt-core.el ├── smelt-fl.el ├── smelt-ts-hl.el ├── smelt-ts-match.el ├── smelt-ts.el └── smelt.el /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | *-autoloads.el 3 | /dist 4 | 5 | /bin 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Matthew Fluet 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # smelt 2 | 3 | Forging Standard ML (SML) in emacs 4 | -------------------------------------------------------------------------------- /highlights.scm: -------------------------------------------------------------------------------- 1 | ;; ******************************************************************* 2 | ;; Comments 3 | ;; ******************************************************************* 4 | 5 | [(block_comment) (line_comment)] @comment 6 | 7 | ;; ******************************************************************* 8 | ;; Keywords 9 | ;; ******************************************************************* 10 | 11 | [ 12 | ;; Reserved Words Core 13 | "abstype" "and" "andalso" "as" "case" "datatype" "do" "else" "end" 14 | "exception" "fn" "fun" "handle" "if" "in" "infix" "infixr" "let" 15 | "local" "nonfix" "of" "op" "open" "orelse" "raise" "rec" "then" 16 | "type" "val" "with" "withtype" "while" 17 | ;; Reserved Words Modules 18 | "eqtype" "functor" "include" "sharing" "sig" "signature" "struct" 19 | "structure" "where" 20 | ] @keyword 21 | 22 | ;; ******************************************************************* 23 | ;; Reserved Words 24 | ;; ******************************************************************* 25 | 26 | ;; Because tree-sitter uses context-sensitive scanning, a reserved word can be 27 | ;; parsed as an identifier if that reserved word cannot occur in a particular 28 | ;; context; for example, `val x = struct` is parsed as a valbind with `struct` 29 | ;; parsed as a vid. Highlight such misinterpreted identifiers. 30 | ([(vid) (tycon) (strid) (sigid) (fctid)] @warning 31 | (#match? @warning "^(?:a(?:bstype|nd(?:also)?|s)|case|d(?:atatype|o)|e(?:lse|nd|qtype|xception)|f(?:n|un(?:ctor)?)|handle|i(?:n(?:clude|fixr?)|[fn])|l(?:et|ocal)|nonfix|o(?:pen|relse|[fp])|r(?:aise|ec)|s(?:haring|ig(?:nature)?|truct(?:ure)?)|t(?:hen|ype)|val|w(?:h(?:(?:er|il)e)|ith(?:type)?)|:|_|\\||=>|->|#)$")) 32 | 33 | ;; As an additional special case, The Defn of SML excludes `*` from tycon. 34 | ([(tycon)] @warning 35 | (#match? @warning "^\\*$")) 36 | 37 | ;; ******************************************************************* 38 | ;; Constants 39 | ;; ******************************************************************* 40 | 41 | [(integer_scon) (word_scon) (real_scon)] @number 42 | [(string_scon) (char_scon)] @string 43 | 44 | ;; ******************************************************************* 45 | ;; Tyvar Identifiers 46 | ;; ******************************************************************* 47 | 48 | ;; binding occurrences 49 | (tyvarseq (["(" "," ")"] @type.def)? (tyvar) @type.def) 50 | 51 | ;; ******************************************************************* 52 | ;; Value Identifiers (Constructors) 53 | ;; ******************************************************************* 54 | 55 | ;; Assume value identifiers starting with capital letter are constructors. 56 | 57 | ;; binding occurrences 58 | (conbind name: ((vid) @variant.def 59 | (#match? @variant.def "^[A-Z].*"))) 60 | (exbind name: ((vid) @variant.def 61 | (#match? @variant.def "^[A-Z].*"))) 62 | (condesc name: ((vid) @variant.def 63 | (#match? @variant.def "^[A-Z].*"))) 64 | (exdesc name: ((vid) @variant.def 65 | (#match? @variant.def "^[A-Z].*"))) 66 | 67 | ;; use occurrences 68 | (vid_exp (longvid ((vid) @vid 69 | (#match? @vid "^[A-Z].*"))) @variant.use) 70 | (exbind def: (longvid ((vid) @vid 71 | (#match? @vid "^[A-Z].*"))) @variant.use) 72 | (vid_pat (longvid ((vid) @vid 73 | (#match? @vid "^[A-Z].*"))) @variant.use) 74 | 75 | ;; "true", "false", "nil", "::", and "ref" are built-in constructors. 76 | (vid_exp (longvid ((vid) @vid 77 | (#match? @vid "^(true|false|nil|::|ref)$"))) @variant.builtin) 78 | (vid_pat (longvid ((vid) @vid 79 | (#match? @vid "^(true|false|nil|::|ref)$"))) @variant.builtin) 80 | 81 | ;; ******************************************************************* 82 | ;; Value Identifiers 83 | ;; ******************************************************************* 84 | 85 | ;; binding occurrences 86 | (fmrule name: (vid) @variable) 87 | 88 | (infix_dec (vid) @variable.def) 89 | (infixr_dec (vid) @variable.def) 90 | (nonfix_dec (vid) @variable.def) 91 | 92 | (vid_pat (longvid . (vid) @variable.def)) 93 | (labvar_patrow (vid) @variable.def) 94 | ; (as_pat (vid) @variable.def) 95 | 96 | (valdesc (vid) @variable) 97 | 98 | ;; use occurrences 99 | (vid_exp (longvid) @variable.use) 100 | (labvar_exprow (vid) @variable.use) 101 | 102 | ;; ******************************************************************* 103 | ;; Tycon Identifiers 104 | ;; ******************************************************************* 105 | 106 | ;; binding occurrences 107 | (typbind name: (tycon) @type.def) 108 | (datbind name: (tycon) @type.def) 109 | (datarepl_dec name: (tycon) @type.def) 110 | 111 | (wheretype_sigexp (longtycon) @type.def) 112 | 113 | (typedesc (tycon) @type.def) 114 | (datdesc (tycon) @type.def) 115 | (datarepl_spec name: (tycon) @type.def) 116 | 117 | (sharingtype_spec (longtycon) @type.def) 118 | 119 | ;; use occurrences: see `Types` 120 | 121 | ;; ******************************************************************* 122 | ;; Structure Identifiers 123 | ;; ******************************************************************* 124 | 125 | ;; binding occurrences 126 | (strbind name: (strid) @module.def) 127 | 128 | (strdesc (strid) @module.def) 129 | 130 | (sharing_spec (longstrid) @type.def) 131 | 132 | (fctbind (strid) @module.def) 133 | 134 | ;; use occurences 135 | (open_dec (longstrid) @module.use) 136 | (strid_strexp (longstrid) @module.use) 137 | 138 | ;; ******************************************************************* 139 | ;; Signature Identifiers 140 | ;; ******************************************************************* 141 | 142 | ;;; binding occurrences 143 | (sigbind name: (sigid) @interface.def) 144 | 145 | ;;; use occurrencess 146 | (sigid_sigexp (sigid) @interface) 147 | (include_spec (sigid) @interface) 148 | 149 | ;; ******************************************************************* 150 | ;; Functor Identifiers 151 | ;; ******************************************************************* 152 | 153 | ;; binding occurrences 154 | (fctbind name: (fctid) @module.def) 155 | 156 | ;; use occurrences 157 | (fctapp_strexp (fctid) @module.def) 158 | 159 | ;; ******************************************************************* 160 | ;; Types 161 | ;; ******************************************************************* 162 | 163 | (fn_ty "->" @type.use) 164 | (tuple_ty "*" @type.use) 165 | (paren_ty ["(" ")"] @type.use) 166 | (tyvar_ty (tyvar) @type.use) 167 | (record_ty 168 | ["{" "," "}"] @type.use 169 | (tyrow [(lab) ":"] @type.use)? 170 | (ellipsis_tyrow ["..." ":"] @type.use)?) 171 | (tycon_ty 172 | (tyseq ["(" "," ")"] @type.use)? 173 | (longtycon) @type.use) 174 | 175 | ;; ******************************************************************* 176 | ;; Labels 177 | ;; ******************************************************************* 178 | 179 | (recordsel_exp "#" @field) 180 | (lab) @field 181 | 182 | ;; ******************************************************************* 183 | ;; Punctuation 184 | ;; ******************************************************************* 185 | 186 | ["(" ")" "[" "]" "{" "}"] @punctuation.bracket 187 | ["," ":" ";" "|" "=>" ":>"] @punctuation.delimiter 188 | -------------------------------------------------------------------------------- /matches.scm: -------------------------------------------------------------------------------- 1 | (let_exp "let" @opener "in" @inner "end" @closer) 2 | (cond_exp "if" @opener "then" @inner "else" @inner) 3 | (iter_exp "while" @opener "do" @inner) 4 | (case_exp "case" @opener "of" @inner) 5 | (abstype_dec "abstype" @opener "with" @inner "end" @closer) 6 | (local_dec "local" @opener "in" @inner "end" @closer) 7 | (struct_strexp "struct" @opener "end" @closer) 8 | (let_strexp "let" @opener "in" @inner "end" @closer) 9 | (local_strdec "local" @opener "in" @inner "end" @closer) 10 | (sig_sigexp "sig" @opener "end" @closer) 11 | -------------------------------------------------------------------------------- /smelt-core.el: -------------------------------------------------------------------------------- 1 | ;;; smelt-core.el --- Core -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | ;;;; Customization 8 | 9 | (defgroup smelt nil 10 | "Support for Standard ML code." 11 | :group 'languages) 12 | 13 | ;;;; Constants 14 | 15 | (defconst smelt--dir 16 | (when load-file-name (file-name-directory load-file-name)) 17 | "Directory of the `smelt' library.") 18 | 19 | (defconst smelt--bin-dir 20 | (concat (file-name-as-directory smelt--dir) "bin/") 21 | "Directory of (platform-dependent) support binaries.") 22 | 23 | (defconst smelt--reserved-words-alpha 24 | '(;; Reserved Words Core 25 | "abstype" "and" "andalso" "as" "case" "datatype" "do" "else" "end" 26 | "exception" "fn" "fun" "handle" "if" "in" "infix" "infixr" "let" 27 | "local" "nonfix" "of" "op" "open" "orelse" "raise" "rec" "then" 28 | "type" "val" "with" "withtype" "while" 29 | ;; Reserved Words Modules 30 | "eqtype" "functor" "include" "sharing" "sig" "signature" "struct" 31 | "structure" "where")) 32 | (defconst smelt--reserved-words-sym 33 | '(;; Reserved Words Core 34 | "(" ")" "[" "]" "{" "}" "," ":" ";" "..." "_" "|" "=" "=>" "->" "#" 35 | ;; Reserved Words Modules 36 | ":>")) 37 | 38 | ;;;; Variables 39 | 40 | (defvar smelt-mode--setup-hook nil) 41 | 42 | ;;;; Keymaps 43 | 44 | (defvar smelt-mode-map 45 | (let ((map (make-sparse-keymap))) 46 | map)) 47 | 48 | ;;;;; Syntax Table 49 | 50 | (defvar smelt-mode-syntax-table 51 | (let ((st (make-syntax-table))) 52 | ;; Comments 53 | (modify-syntax-entry ?\( "()1" st) 54 | (modify-syntax-entry ?\) ")(4" st) 55 | (modify-syntax-entry ?\* ". 23n" st) 56 | ;; Punctuation 57 | (mapc (lambda (c) (modify-syntax-entry c "." st)) ".,;") 58 | ;; Identifiers 59 | ;;; Alphanumeric identifiers include ' and _ 60 | (mapc (lambda (c) (modify-syntax-entry c "_" st)) "'_") 61 | ;;; Symbolic identifiers 62 | (mapc (lambda (c) (modify-syntax-entry c "." st)) "!%&$#+-/:<=>?@\\~`^|") 63 | st) 64 | "The syntax table used in `smelt-mode'.") 65 | 66 | ;;;;; Abbrev Table 67 | 68 | (define-abbrev-table 'smelt-mode-abbrev-table nil 69 | "Abbrevs for `smelt-mode.'") 70 | 71 | ;;;; Mode 72 | 73 | ;;;###autoload 74 | (define-derived-mode smelt-mode prog-mode "smelt" 75 | "Major mode for Standard ML code. 76 | 77 | \\{smelt-mode-map}" 78 | :group 'smelt 79 | (run-hooks 'smelt-mode--setup-hook) 80 | ) 81 | 82 | ;;;###autoload 83 | (add-to-list 'auto-mode-alist '("\\(\\.s\\(ml\\|ig\\)\\|\\.fun\\)\\'" . smelt-mode)) 84 | 85 | ;;;; Features 86 | 87 | ;;;;; Comment 88 | 89 | (defun smelt-comment--setup () 90 | "Configure comments for `smelt-mode'." 91 | (setq-local parse-sexp-ignore-comments t) 92 | (setq-local comment-start "(* ") 93 | (setq-local comment-end " *)") 94 | (setq-local comment-start-skip "(\\*+\\s-*") 95 | (setq-local comment-end-skip "\\s-*\\*+)") 96 | (setq-local comment-quote-nested nil) 97 | ) 98 | (add-hook 'smelt-mode--setup-hook #'smelt-comment--setup 1) 99 | 100 | ;;;; Footer 101 | 102 | (provide 'smelt-core) 103 | 104 | ;;; smelt-core.el ends here 105 | -------------------------------------------------------------------------------- /smelt-fl.el: -------------------------------------------------------------------------------- 1 | ;;; smelt-fl.el --- Support for font-lock-mode -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | (require 'smelt-core) 8 | 9 | (require 'font-lock) 10 | 11 | (defconst smelt-fl--keywords 12 | `((,(regexp-opt smelt--reserved-words-alpha 'symbols) . font-lock-keyword-face))) 13 | 14 | (defconst smelt-fl--defaults 15 | '(smelt-fl--keywords nil nil ((?\\ . "\\")))) 16 | 17 | (defun smelt-fl--setup () 18 | "Configure `font-lock-mode' for `smelt-mode'." 19 | (setq-local font-lock-defaults smelt-fl--defaults) 20 | ) 21 | (add-hook 'smelt-mode--setup-hook #'smelt-fl--setup 1) 22 | 23 | (provide 'smelt-fl) 24 | 25 | ;;; smelt-fl.el ends here 26 | -------------------------------------------------------------------------------- /smelt-ts-hl.el: -------------------------------------------------------------------------------- 1 | ;;; smelt-ts-hl.el --- Support for tree-sitter-hl-mode -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | ;;;; Requirements 8 | 9 | (require 'tree-sitter-hl) 10 | 11 | (require 'smelt-core) 12 | (require 'smelt-ts) 13 | 14 | ;;;; Customization (Faces) 15 | 16 | ;;;;; Warning 17 | 18 | (defface tree-sitter-hl-face:warning 19 | '((default :inherit font-lock-warning-face)) 20 | "Face for warnings." 21 | :group 'tree-sitter-hl-faces) 22 | 23 | ;;;;; Variables 24 | 25 | (defface tree-sitter-hl-face:variable.use 26 | '((default :inherit default)) 27 | "Face for variable definitions." 28 | :group 'tree-sitter-hl-faces) 29 | 30 | (defface tree-sitter-hl-face:variable.def 31 | ;; `tree-sitter-hl-face:variable' is documented as binding occurrence 32 | '((default :inherit tree-sitter-hl-face:variable)) 33 | "Face for variable definitions (binding occurrences)." 34 | :group 'tree-sitter-hl-faces) 35 | 36 | ;;;;; Variants 37 | 38 | (defface tree-sitter-hl-face:variant.def 39 | '((default :inherit tree-sitter-hl-face:variable.def :weight thin :slant italic)) 40 | "Face for enum variant definitions (binding occurrences)." 41 | :group 'tree-sitter-hl-faces) 42 | 43 | (defface tree-sitter-hl-face:variant.use 44 | '((default :inherit tree-sitter-hl-face:variable.use :weight thin :slant italic)) 45 | "Face for enum variant uses." 46 | :group 'tree-sitter-hl-faces) 47 | 48 | (defface tree-sitter-hl-face:variant.builtin 49 | '((default :inherit tree-sitter-hl-face:constant.builtin :weight bold)) 50 | "Face for builtin enum variants." 51 | :group 'tree-sitter-hl-faces) 52 | 53 | ;;;;; Fields 54 | 55 | (defface tree-sitter-hl-face:field 56 | '((default :inherit default :underline t)) 57 | "Face for fields." 58 | :group 'tree-sitter-hl-faces) 59 | 60 | ;;;;; Types 61 | 62 | (defface tree-sitter-hl-face:type.use 63 | '((default :inherit tree-sitter-hl-face:type)) 64 | "Face for type uses." 65 | :group 'tree-sitter-hl-faces) 66 | 67 | (defface tree-sitter-hl-face:type.def 68 | '((default :inherit tree-sitter-hl-face:type :slant italic)) 69 | "Face for type definitions (binding occurrences)." 70 | :group 'tree-sitter-hl-faces) 71 | 72 | ;;;;; Modules 73 | 74 | (defface tree-sitter-hl-face:module.use 75 | '((default :inherit tree-sitter-hl-face:variable.use)) 76 | "Face for module uses." 77 | :group 'tree-sitter-hl-faces) 78 | 79 | (defface tree-sitter-hl-face:module.def 80 | '((default :inherit tree-sitter-hl-face:variable.def :weight bold)) 81 | "Face for module definitions (binding occurrences)." 82 | :group 'tree-sitter-hl-faces) 83 | 84 | ;;;;; Interfaces 85 | 86 | (defface tree-sitter-hl-face:interface.use 87 | '((default :inherit tree-sitter-hl-face:type :weight bold)) 88 | "Face for interface uses." 89 | :group 'tree-sitter-hl-faces) 90 | 91 | (defface tree-sitter-hl-face:interface.def 92 | '((default :inherit tree-sitter-hl-face:interface.use :slant italic)) 93 | "Face for interface definitions (binding occurrences)." 94 | :group 'tree-sitter-hl-faces) 95 | 96 | ;;;; Public 97 | 98 | (defconst smelt-ts-hl-patterns-file 99 | (concat (file-name-as-directory smelt--dir) "highlights.scm")) 100 | 101 | ;;;; Private 102 | 103 | (defconst smelt-ts-hl--default-patterns 104 | (condition-case nil 105 | (with-temp-buffer 106 | (insert-file-contents smelt-ts-hl-patterns-file) 107 | (buffer-string)) 108 | (file-missing nil))) 109 | 110 | (defun smelt-ts-hl--setup () 111 | "Configure and enable `tree-sitter-hl-mode' for `smelt-mode'." 112 | (if (null font-lock-defaults) 113 | (setq-local font-lock-defaults '(()))) 114 | (setq-local tree-sitter-hl-default-patterns smelt-ts-hl--default-patterns) 115 | (tree-sitter-hl-mode +1) 116 | ) 117 | (add-hook 'smelt-mode--setup-hook #'smelt-ts-hl--setup 1) 118 | 119 | ;;;; Footer 120 | 121 | (provide 'smelt-ts-hl) 122 | 123 | ;;; smelt-ts-hl.el ends here 124 | -------------------------------------------------------------------------------- /smelt-ts-match.el: -------------------------------------------------------------------------------- 1 | ;;; smelt-ts-match.el --- Support for showing matching begin/end pairs using tree-sitter-mode -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Use tree-sitter grammar and queries to show matching begin/end pairs. 6 | ;; Inspired by similar functionality provided by SMIE. 7 | 8 | ;;; Code: 9 | 10 | ;;;; Requirements 11 | 12 | (require 'cl-lib) 13 | 14 | (require 'tree-sitter) 15 | 16 | (require 'smelt-core) 17 | (require 'smelt-ts) 18 | 19 | ;;;; Public 20 | 21 | (defconst smelt-ts-match-patterns-file 22 | (concat (file-name-as-directory smelt--dir) "matches.scm")) 23 | 24 | ;;;; Private 25 | 26 | (defconst smelt-ts-match--default-patterns 27 | (condition-case nil 28 | (with-temp-buffer 29 | (insert-file-contents smelt-ts-match-patterns-file) 30 | (buffer-string)) 31 | (file-missing nil))) 32 | 33 | (defvar-local smelt-ts-match--query nil 34 | "Tree-sitter query used for showing matching begin/end pairs, compiled from patterns.") 35 | 36 | (defun smelt-ts-match--ensure-query () 37 | "Return the tree-sitter query to be used for showing matching begin/end pairs in this buffer." 38 | (unless smelt-ts-match--query 39 | (setq smelt-ts-match--query 40 | (when smelt-ts-match--default-patterns 41 | (tsc-make-query 42 | tree-sitter-language 43 | (tsc--stringify-patterns smelt-ts-match--default-patterns))))) 44 | smelt-ts-match--query) 45 | 46 | (defun smelt-ts-match--choose-match-data (fst snd) 47 | "Choose the \"better\" of FST and SND, which are results of functions suitable for `show-paren-data-function' (which see)." 48 | (pcase (cons fst snd) 49 | (`(nil . nil) nil) 50 | (`(nil . ,_) snd) 51 | (`(,_ . nil) fst) 52 | (`((,fst-here-beg ,fst-here-end ,fst-there-beg ,fst-there-end ,_) . 53 | (,snd-here-beg ,snd-here-end ,snd-there-beg ,snd-there-end ,_)) 54 | (let ((fst-left-beg (min fst-here-beg fst-there-beg)) 55 | (fst-left-end (min fst-here-end fst-there-end)) 56 | ;; (fst-right-beg (max fst-here-beg fst-there-beg)) 57 | (fst-right-end (max fst-here-end fst-there-end)) 58 | (snd-left-beg (min snd-here-beg snd-there-beg)) 59 | (snd-left-end (min snd-here-end snd-there-end)) 60 | ;;(snd-right-beg (max snd-here-beg snd-there-beg)) 61 | (snd-right-end (max snd-here-end snd-there-end))) 62 | (cond 63 | ((or 64 | ;; fst precedes snd 65 | (<= fst-right-end snd-left-beg) 66 | ;; fst is contained in snd 67 | (and (<= snd-left-end fst-left-beg) 68 | (<= fst-right-end snd-right-end))) 69 | fst) 70 | ((or 71 | ;; snd precedes fst 72 | (<= snd-right-end fst-left-beg) 73 | ;; snd is contained in fst 74 | (and (<= fst-left-end snd-left-beg) 75 | (<= snd-right-end fst-right-end))) 76 | snd) 77 | ;; impossible? 78 | (t nil)))))) 79 | 80 | (defun smelt-ts-match--match-data (when-point-inside) 81 | "Find an opener/inner/closer \"near\" point and its match. 82 | 83 | Returns either nil if there is no opener/inner/closer near point, 84 | or a list of the form (HERE-BEG HERE-END THERE-BEG THERE-END MISMATCH), 85 | where HERE-BEG..HERE-END is expected to be near point. 86 | \(See `show-paren-data-function'.) 87 | 88 | `smelt-ts-match--query' should hold a tree-sitter query with 89 | patterns that capture nodes with capture names of the form 90 | \"@opener\", \"@inner\", and \"@closer\". Each pattern should 91 | capture one \"@opener\", zero or more \"@inner\"s, and at most 92 | one \"@closer\", where the \"@opener\" precedes all \"@inner\"s 93 | and the \"@closer\" (if present) and all \"@inner\"s precede the 94 | \"@closer\" (if present). An \"@opener\" node behaves like an 95 | open parenthesis (i.e., is found if the point immediately 96 | precedes or is contained in the node) and matches with the 97 | corresponding \"@closer\" node (if present). An \"@inner\" or 98 | a \"@closer\" node behaves like a close parenthesis (i.e., is found 99 | if the point is contained in or immediately follows the node) and 100 | matches with the corresponding \"@opener\" node. 101 | 102 | If WHEN-POINT-INSIDE is non-nil, then an \"@opener\" is also 103 | found if the point immediately follows the node and an \"@inner\" 104 | or a \"@closer\" is also found if the point immediately precedes 105 | the node. 106 | 107 | Inspired by `smie--matching-block-data'." 108 | (let ((res nil)) 109 | (tsc--save-context 110 | (let* ((root-node (tsc-root-node tree-sitter-tree)) 111 | (query smelt-ts-match--query) 112 | (matches (tsc-query-matches query 113 | root-node 114 | #'tsc--buffer-substring-no-properties))) 115 | (seq-doseq (match matches) 116 | (let* ((captures (cdr match)) 117 | (opener (cdr (seq-find (lambda (capture) 118 | (equal 'opener (car capture))) 119 | captures 120 | '(opener . nil)))) 121 | (closer (cdr (seq-find (lambda (capture) 122 | (equal 'closer (car capture))) 123 | captures 124 | '(closer . nil)))) 125 | (inners (seq-mapcat (lambda (capture) 126 | (and (equal 'inner (car capture)) 127 | (list (cdr capture)))) 128 | captures))) 129 | (when opener 130 | (if (and closer 131 | (<= (tsc-node-start-position opener) (point)) 132 | (if when-point-inside 133 | (<= (point) (tsc-node-end-position opener)) 134 | (< (point) (tsc-node-end-position opener)))) 135 | (setq res 136 | (smelt-ts-match--choose-match-data 137 | res 138 | (list (tsc-node-start-position opener) 139 | (tsc-node-end-position opener) 140 | (tsc-node-start-position closer) 141 | (tsc-node-end-position closer) 142 | nil)))) 143 | (dolist (ender (append (ensure-list closer) inners)) 144 | (if (and (if when-point-inside 145 | (<= (tsc-node-start-position ender) (point)) 146 | (< (tsc-node-start-position ender) (point))) 147 | (<= (point) (tsc-node-end-position ender))) 148 | (setq res 149 | (smelt-ts-match--choose-match-data 150 | res 151 | (list (tsc-node-start-position ender) 152 | (tsc-node-end-position ender) 153 | (tsc-node-start-position opener) 154 | (tsc-node-end-position opener) 155 | nil)))))))))) 156 | res)) 157 | 158 | (defun smelt-ts-match--show-paren (orig) 159 | "Find an opener/inner/closer \"near\" point and its match. 160 | 161 | It is a function suitable for `show-paren-data-function' (which see). 162 | 163 | Inspired by `smie--matching-block-data'." 164 | (smelt-ts-match--choose-match-data 165 | (smelt-ts-match--match-data show-paren-when-point-inside-paren) 166 | orig)) 167 | 168 | (defun smelt-ts-match--setup () 169 | "Configure and enable `tree-sitter-mode' for `smelt-mode'." 170 | (when (smelt-ts-match--ensure-query) 171 | (add-function :filter-return (local 'show-paren-data-function) 172 | #'smelt-ts-match--show-paren))) 173 | (add-hook 'smelt-mode--setup-hook #'smelt-ts-match--setup 1) 174 | 175 | (provide 'smelt-ts-match) 176 | 177 | ;;; smelt-ts-match.el ends here 178 | -------------------------------------------------------------------------------- /smelt-ts.el: -------------------------------------------------------------------------------- 1 | ;;; smelt-ts.el --- Support for tree-sitter-mode -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | (require 'cl-lib) 8 | 9 | (require 'tree-sitter) 10 | (require 'tree-sitter-load) 11 | 12 | (require 'smelt-core) 13 | 14 | (defun smelt-ts--init-load-path () 15 | "Add the directory of the compiled grammar to `tree-sitter-load-path'." 16 | (cl-pushnew smelt--bin-dir tree-sitter-load-path 17 | :test #'string-equal)) 18 | (smelt-ts--init-load-path) 19 | 20 | (defun smelt-ts--init-major-mode-alist () 21 | "Link `smelt-mode' to `sml' grammar." 22 | (cl-pushnew '(smelt-mode . sml) tree-sitter-major-mode-language-alist 23 | :key #'car)) 24 | (smelt-ts--init-major-mode-alist) 25 | 26 | (defun smelt-ts--setup () 27 | "Configure and enable `tree-sitter-mode' for `smelt-mode'." 28 | (tree-sitter-mode +1) 29 | ) 30 | (add-hook 'smelt-mode--setup-hook #'smelt-ts--setup 1) 31 | 32 | (provide 'smelt-ts) 33 | 34 | ;;; smelt-ts.el ends here 35 | -------------------------------------------------------------------------------- /smelt.el: -------------------------------------------------------------------------------- 1 | ;;; smelt.el --- Forging Standard ML (SML) with emacs -*- lexical-binding: t; coding: utf-8 -*- 2 | 3 | ;; Copyright (C) 2022 Matthew Fluet. 4 | 5 | ;; Version: 0.1.0 6 | ;; Author: Matthew Fluet (https://github.com/MatthewFluet) 7 | ;; SPDX-License-Identifier: MIT 8 | ;; Keywords: sml languages 9 | ;; Homepage: https://github.com/MatthewFluet/smelt 10 | 11 | ;; Package-Requires: 12 | 13 | ;;; Commentary: 14 | 15 | ;; This package implements a major-mode for editing SML source code. 16 | 17 | ;;; Code: 18 | 19 | ;;;; Core 20 | 21 | (require 'smelt-core) 22 | 23 | ;;;; Features 24 | 25 | (require 'smelt-fl) 26 | (require 'smelt-ts) 27 | (require 'smelt-ts-hl) 28 | (require 'smelt-ts-match) 29 | 30 | ;;; _ 31 | 32 | (defun smelt-reload () 33 | "Reload smelt package." 34 | (interactive) 35 | (unload-feature 'smelt) 36 | (unload-feature 'smelt-ts-match) 37 | (unload-feature 'smelt-ts-hl) 38 | (unload-feature 'smelt-ts) 39 | (unload-feature 'smelt-fl) 40 | (unload-feature 'smelt-core) 41 | (require 'smelt) 42 | (smelt-mode)) 43 | 44 | ;;;; Footer 45 | 46 | (provide 'smelt) 47 | 48 | ;;; smelt.el ends here 49 | --------------------------------------------------------------------------------