;;; consfigurator.el --- Utilities for Consfigurator consfigs  -*- lexical-binding:t -*-

;; Copyright (C) 2021, 2023  Sean Whitton
;; Copyright (C) 2002-2023  Free Software Foundation, Inc.

;; Author: Sean Whitton <spwhitton@spwhitton.name>
;; Maintainer: Sean Whitton <spwhitton@spwhitton.name>
;; Version: 1.3.2
;; URL: https://git.spwhitton.name/consfigurator/tree/emacs/consfigurator.el.in
;; Keywords: languages, lisp, syntax, unix

;; This file 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 file 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Utilities for working with Consfigurator consfigs from Emacs.
;; Please see <https://spwhitton.name/tech/code/consfigurator/> for more
;; information about Consfigurator.

;;; Code:

(require 'lisp-mode)
(require 'perl-mode)

(defgroup consfigurator nil
  "Options for Consfigurator Emacs utilities."
  :group 'tools)

(defcustom consfigurator-auto-activate-indentation-hints t
  "Whether `consfigurator-lisp-mode' should call
`consfigurator-activate-indentation-hints'.
Activation of the indentation hints is not buffer-local."
  :type 'boolean
  :group 'consfigurator)

;;;###autoload
(defun activate-consfigurator-indentation-hints ()
  "Activate indentation hints for Consfigurator properties.

Note that these hints assume you're using the recommended consfig
defpackage, where the :consfigurator package is used unqualified,
and packages providing properties have local nicknames
corresponding to the final dot-delimited component of their names."
  (interactive)
  ;; Properties
  @putforms@

  ;; Other operators
  (put 'with-unapply 'common-lisp-indent-function '(&body))
  (put 'os:typecase 'common-lisp-indent-function '(&rest (&whole 2 &rest 1)))
  (put 'os:etypecase 'common-lisp-indent-function '(&rest (&whole 2 &rest 1))))

(defun consfigurator--finish-propertize-qq-heredoc (limit)
  (let ((state (syntax-ppss))
	ender)
    (cond ((and (nth 4 state)
		(setq ender
		      (cdr (get-text-property (nth 8 state) 'syntax-table))))
	   (when (search-forward ender limit t)
	     (let ((char (- (point) (length ender))))
	       (put-text-property (1- char) char 'syntax-table
				  (eval-when-compile
				    (string-to-syntax "!")))
	       (put-text-property (- (nth 8 state) (length ender) 3) (point)
				  'syntax-multiline t))))
	  ;; Based on `perl-syntax-propertize-special-constructs', which see.
	  ((and (nth 3 state)
		(or (not (characterp (nth 3 state)))
		    (get-text-property (nth 8 state) 'syntax-table)))
	   (let* ((startpos (point))
		  (twoargs
		   (save-excursion
		     (let (parse-sexp-lookup-properties)
		       (goto-char (nth 8 state))
		       (skip-syntax-backward "w ")
		       (member
			(buffer-substring (point)
					  (progn (forward-word-strictly 1)
						 (point)))
			'("tr" "s" "y")))))
		  (char (char-after (nth 8 state)))
		  middle
		  (close (cdr (assq char perl-quote-like-pairs)))
		  (st (perl-quote-syntax-table char)))
	     (when (with-syntax-table st
		     (if close
			 (condition-case nil
			     (progn (goto-char (1+ (nth 8 state)))
				    (up-list 1)
				    t)
			   (scan-error (goto-char startpos) nil))
		       (not (or (nth 8 (parse-partial-sexp
					(if twoargs (1+ (nth 8 state))
					  (point))
					limit nil nil state 'syntax-table))
				(and twoargs (not close)
				     (setq middle (point))
				     (nth 8 (parse-partial-sexp
					     (point) limit nil nil
					     state 'syntax-table)))))))
	       (if (and middle (eq char ?\"))
		   (put-text-property (1- middle) middle 'syntax-table
				      (eval-when-compile
					(string-to-syntax ".")))
		 (put-text-property (1- (point)) (point) 'syntax-table
				    (if close (eval-when-compile
						(string-to-syntax "|"))
				      (eval-when-compile
					(string-to-syntax "\"")))))
	       (put-text-property (nth 8 state) (point) 'syntax-multiline t)
	       (when (and twoargs close (< (point) limit))
		 (put-text-property (point) (1+ (point)) 'syntax-table
				    (if (assq (char-after)
					      perl-quote-like-pairs)
					(eval-when-compile
					  (string-to-syntax "|"))
				      (eval-when-compile
					(string-to-syntax "\""))))
		 (forward-char 1)
		 (consfigurator--finish-propertize-qq-heredoc limit))))))))

(defun consfigurator-syntax-propertize-function (start end)
  "`syntax-propertize-function' for Consfigurator's readtable.

Modes that use this should add `syntax-propertize-multiline' to
`syntax-propertize-extend-region-functions'."
  (goto-char start)
  (consfigurator--finish-propertize-qq-heredoc end)
  (cl-flet ((in-string-or-comment-p ()
	      (nth 8 (save-excursion (syntax-ppss (match-beginning 0))))))
    (let (case-fold-search)
      (funcall
       (syntax-propertize-rules
	("#\\(>>?\\)~?\\(.+?\\)\\1\\([^z-a]\\)"
	 (3 (ignore
	     (or (in-string-or-comment-p)
		 (let ((beg (match-beginning 3))
		       (ender (match-string 2)))
		   (put-text-property beg (1+ beg) 'syntax-table
				      (cons (eval-when-compile
					      (car (string-to-syntax "!")))
					    ender))
		   (consfigurator--finish-propertize-qq-heredoc end))))))
	((rx (| (: (group-n 1 "#?" (group-n 2 (opt (| "rx" ?r ?x))))
		   (group-n 3 (not (in alnum ?\\))))
		(: (group-n 1
		     ?# (0+ digit) (opt ?!) ?~ (group-n 2
						 (opt (| "tr" ?m ?s ?y))))
		   (group-n 3 nonl))))
	 (1 (and (not (in-string-or-comment-p))
		 (eval-when-compile (string-to-syntax "'"))))
	 ;; Based on code in one branch of `perl-syntax-propertize-function'.
	 (3 (ignore
	     (or (in-string-or-comment-p)
		 (let* ((beg (match-beginning 3))
			(char (char-after beg))
			(prop
			 (cond ((assq char perl-quote-like-pairs)
				(eval-when-compile (string-to-syntax "|")))
			       ((and (eq char ?\")
				     (not (member (match-string 2)
						  '("tr" "s" "y"))))
				nil)
			       (t
				(eval-when-compile
				  (string-to-syntax "\""))))))
		   (put-text-property beg (1+ beg) 'syntax-table prop)
		   (consfigurator--finish-propertize-qq-heredoc end)))))))
       (point) end))))

(defun consfigurator--lisp-indent-function (indent-point state)
  ;; Don't indent to below trailing modifiers like the 'g' in '#~/foo/g'.
  (or (save-excursion
	(goto-char (1+ (nth 1 state)))
	(and (looking-at "#[[:digit:]]*!?~") (current-column)))
      (common-lisp-indent-function indent-point state)))

;; `slime-lisp-mode-hook' runs the hooks for `slime-mode' and only then sets
;; `lisp-indent-function', so I can't see a cleaner way to override it.
(defun consfigurator--slime-lisp-mode-hook ()
  (when (derived-mode-p 'consfigurator-lisp-mode)
    (setq-local lisp-indent-function #'consfigurator--lisp-indent-function)))
(advice-add 'slime-lisp-mode-hook
	    :after #'consfigurator--slime-lisp-mode-hook)

;;;###autoload
(define-derived-mode consfigurator-lisp-mode lisp-mode "Lisp"
  "Derivative of `lisp-mode' for files using Consfigurator's readtable."
  (add-hook 'syntax-propertize-extend-region-functions
            #'syntax-propertize-multiline t t)
  (setq-local syntax-propertize-function
	      #'consfigurator-syntax-propertize-function
	      lisp-indent-function #'consfigurator--lisp-indent-function)
  (when consfigurator-auto-activate-indentation-hints
    (activate-consfigurator-indentation-hints)))

(provide 'consfigurator)

;;; consfigurator.el ends here