Mercurial > core / emacs/lib/sk.el

 ;;; sk.el --- skel Emacs Mode -*- lexical-binding:t -*-
 
 ;; skel-mode, skel-minor-mode,skt-minor-mode, sk-classes
 
 ;; Copyright (C) 2023  The Compiler Company
 
 ;; Author: ellis <ellis@rwest.io>
 ;; Keywords: languages, lisp
 
 ;; 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 <https://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
 ;;
 
 ;;; Code:
 (eval-and-compile (require 'eieio)
 		  (require 'cl-lib)
 		  (require 'sxp (expand-file-name "sxp.el" (join-paths user-emacs-directory "lib/")))
                   (require 'skeleton)
                   (require 'org)
                   (require 'tempo)
                   (require 'autoinsert)
 		  (defvar skel-debug nil)
 		  (when skel-debug (require 'ede)))
 
 (defvar skel-version "0.1.0")
 
 (defgroup skel nil
   "skel customization group."
   :group 'local)
 
 (defcustom skel-minor-mode-map-prefix "C-c C-."
   "Prefix for `skel-minor-mode' keymap."
   :type 'string
   :group 'skel)
 
 (defcustom skel-triggers nil
   "Association of symbols to a specific condition which can be used
 to trigger `skel-actions' based on the `skel-behavior' value."
   :type '(list function)
   :group 'skel)
 
 (defcustom skel-actions nil
   "Array of actions which may be performed on skeletons."
   :type 'obarray
   :group 'skel)
 
 (defcustom skel-id-prefix "sk"
   "Default prefix for `make-id'."
   :type 'string
   :group 'skel)
 
 (defvar-keymap skel-minor-mode-map
   :doc "skel-minor-mode keymap."
   :repeat (:enter)
   :prefix 'skel-minor-mode-map)
 
 (define-minor-mode skel-minor-mode
   "skel-minor-mode"
   :global t
   :lighter " Sk"
   :group 'skel
   :keymap skel-minor-mode-map
   :version skel-version)
 
 ;; TODO 2023-09-06: 
 (define-derived-mode skel-mode lisp-mode "SKEL"
   :group 'skel
   (skel-minor-mode 1))
 
 (org-babel-make-language-alias "skel" "lisp")
 
 (defun maybe-skel-minor-mode ()
   "Check the current environment and determine if `skel-minor-mode' should
 be enabled. This function is added as a hook to
 `lisp-data-mode-hook'.")
 
 (defvar skel-hashtable (make-hash-table :test #'equal)
   "Internal table of available skeletons.")
 
 (defvar skel-stack nil "Internal stack of skeletons.")
 
 (defcustom skel-state 'passive
   "State toggle for the `skel' system. Base states are passive and
 active."
   :type 'symbol
   :group 'skel)
 
 (defvar skel-active-map nil
   "List of cons cells of the form (SYM . BODY...) where SYM is a member of
 `skel-triggers'.")
 
 (defvar skel-passive-map nil
   "list of cons cells of the form (SYM . BODY...) where SYM is a member of
 `skel-triggers'.")
 
 (defmacro make-id (&optional pre)
   `(let ((pre ,(if-let (pre) (concat skel-id-prefix "-" pre "-") (concat skel-id-prefix "-")))
 	 (current-time-list nil))
      (symb pre (prog1 gensym-counter (setq gensym-counter (1+ gensym-counter))) (format "%x" (car (current-time))))))
 
 (defmacro defcmd (name &rest body) `(defun ,name nil (interactive) ,@body))
 
 (defclass sk (sxp)
   ((id :initarg :id :initform (make-id)))
   :documentation "Base class for skeleton objects. Inherits from `sxp'."
   :abstract t)
 
 (defcmd sk-classes (eieio-class-children 'sk))
 
 (defmacro def-sk-class (name doc &optional slots superclasses)
   "Define a new class with superclass of `skel'+SUPERCLASSES, SLOTS,
 DOC, and NAME."
   (declare (indent 1))
   `(defclass ,(symb "sk-" name)
      ,(if superclasses `(sk ,@superclasses) '(sk))
      ,(if slots
 	  `(,@slots
 	    (:id :initarg :id :initform (make-id ,(symbol-name name)) :accessor id))
 	`((:id :initarg :id :initform (make-id ,(symbol-name name)) :accessor id)))
      :documentation ,doc))
 
 (def-sk-class target "Target skeleton class.")
 (def-sk-class source "Source skeleton class.")
 (def-sk-class rule
   "Config skeleton class."
   ((target :initarg :target :initform nil :type (or null sk-target))
    (rules :initarg :source :initform nil :type (or null sk-source))))
 
 (def-sk-class project
   "Project skeleton class."
   ((type :initarg :type :initform nil :accessor sk-project-type :type (or null symbol))
    (rules :initarg :rules :initform nil :accessor sk-project-rules :type list)))
 
 (defun skel-init ()
   "Initialize the skel library."
   (interactive)
   (add-to-list 'auto-mode-alist '("skelfile" . skel-mode))
   (add-to-list 'auto-mode-alist '("\\.sk" . skel-mode)))
 
 (defun project-skelfile-path (&optional project)
   "Find skelfile associated with PROJECT. Defaults to current
 directory and returns name of skelfile. When PROJECT is T uses
 `project-current'."
   (let* ((dir (unless (eql t project) (expand-file-name (or project default-directory))))
          (project-root (project-root (project-current nil dir))))
     (or
      (when dir
        (cl-find-if 
         (lambda (x)
           (when (string-match
                  (rx (or "skelfile" (and (* any) ".sk")))
                  (file-name-nondirectory x))
             x))
         (directory-files dir t)))
      (when project
        (cl-find-if (lambda (x)
                      (when (string-match (rx (or "skelfile" (and (* any) ".sk")))
                                          (file-name-nondirectory x))
                        x))
                    (directory-files project-root t))))))
 
 (defun read-skelfile-bind (&optional project)
   (let ((buffer (find-file-noselect (project-skelfile-path project))))
     (with-current-buffer buffer
       (goto-char (point-min))
       (goto-char (search-forward-regexp (rx bol ":bind" (* space))))
       (read buffer))))
 
 (defun project-skelfile-dir-locals (&optional project)
   "Return a list of dir-local bindings from a skelfile."
   (let ((form (read-skelfile-bind project)))
     (cl-loop for f in form
              do (cond
                  ((eql (car f) :dir-locals) (cl-return (cdr f)))
                  ;; when used as second element, the first is the name
                  ;; of the CL-local binding, here we discard it and
                  ;; just take the CDDR.
                  ((eql (cadr f) :dir-locals) (cl-return (cddr f)))))))
 
 (defun skel-dir-local--get-variables ()
   "Compute and return the list of :DIR-LOCAL bindings found in the current
 project's skelfile, if any. Typically added to
 `hack-dir-local--get-variables'."
   (let ((root (project-root (project-current))))
     (cons (expand-file-name root) (project-skelfile-dir-locals root))))
 
 (defun %skel-dir-local--get-variables ()
   (let ((root (expand-file-name (project-root (project-current)))))
     (unless (assoc-string root dir-locals-class-alist)
       (push (skel-dir-local--get-variables) dir-locals-class-alist))))
 
 (add-hook 'skel-minor-mode-hook '%skel-dir-local--get-variables)
 
 (provide 'skel)
 (provide 'sk)
 ;;; sk.el ends here