Add feature-emacs-uni with its code and apply it for user config

2 files changed, 131 insertions, 0 deletions

diff --git a/src/jd/features/emacs-xyz.scm b/src/jd/features/emacs-xyz.scm
new file mode 100644
index 0000000..d79b920
--- /dev/null
+++ b/src/jd/features/emacs-xyz.scm
@@ -0,0 +1,127 @@
+(define-module (jd features emacs-xyz)
+  #:use-module (rde features)
+  #:use-module (rde features emacs)
+
+  #:export (feature-emacs-org-uni))
+
+(define* (feature-emacs-org-uni
+          #:key
+          (capture-key "u")
+          (org-uni-task-olp (list "Tasks"))
+          (org-uni-class-prop-name "UNI-CLASS")
+          (org-uni-course-prop-name "COURSE"))
+  (ensure-pred string? capture-key)
+  (ensure-pred list? org-uni-task-olp)
+  (ensure-pred string? org-uni-course-prop-name)
+
+  (ensure-pred string? org-uni-class-prop-name)
+
+  (define emacs-f-name 'org-uni)
+  (define f-name (symbol-append 'emacs- emacs-f-name))
+
+  (define (get-home-services config)
+    (list
+     (rde-elisp-configuration-service
+      emacs-f-name
+      config
+      `((defvar org-uni-class-prop-name ,org-uni-class-prop-name)
+        (defvar org-uni-task-olp (list ,@org-uni-task-olp)
+          "An outline path to task heading, that start from uni class heading.")
+        (defun org-uni-normalize (s)
+          (let ((replacements
+                 '(("ą" . "a") ("ć" . "c") ("ę" . "e") ("ł" . "l")
+                   ("ń" . "n") ("ó" . "o") ("ś" . "s") ("ź" . "z") ("ż" . "z")
+                   ("Ą" . "A") ("Ć" . "C") ("Ę" . "E") ("Ł" . "L")
+                   ("Ń" . "N") ("Ó" . "O") ("Ś" . "S") ("Ź" . "Z") ("Ż" . "Z"))))
+            (dolist (pair replacements s)
+                    (setq s (replace-regexp-in-string (car pair) (cdr pair) s)))))
+        (defun org-uni-select-class ()
+          (require 'dash)
+          (let* ((choices
+                  (-non-nil
+                   (org-map-entries
+                    (lambda ()
+                      (let* ((heading (nth 4 (org-heading-components)))
+                             (file (buffer-file-name))
+                             (heading-path (org-get-outline-path t))
+                             (heading-norm (replace-regexp-in-string
+                                            "[^a-z0-9]+" "_"
+                                            (org-uni-normalize (downcase heading)))))
+                        (when (org-entry-get (point) org-uni-class-prop-name)
+                          (cons (format "[%s] %s"
+                                        (file-name-nondirectory file)
+                                        heading)
+                                (list :file file
+                                      :heading-path heading-path
+                                      :heading heading
+                                      :heading-norm heading-norm)))))
+                    nil
+                    'agenda)))
+                 (selection (completing-read "Select class: "
+                                             (mapcar 'car choices) nil t)))
+            (cdr (assoc selection choices))))
+        (defun org-uni-goto-class ()
+          (interactive)
+          (let* ((sel (org-uni-select-class))
+                 (file (plist-get sel :file))
+                 (olp (plist-get sel :heading-path)))
+            (find-file file)
+            (let ((m (org-find-olp olp t)))
+              (when m
+                (widen)
+                (goto-char m)
+                (org-narrow-to-subtree)
+                (org-show-subtree)
+                (set-marker m nil)))))
+        (defun org-uni-open-course-link ()
+          (interactive)
+          (let* ((sel (org-uni-select-class))
+                 (file (plist-get sel :file))
+                 (olp (plist-get sel :heading-path)))
+            (with-temp-buffer
+             (insert-file-contents file)
+             (org-mode)
+             (let ((m (org-find-olp olp t)))
+               (when m
+                 (goto-char m)
+                 (let ((course-link (org-entry-get (point) ,org-uni-course-prop-name)))
+                   (when course-link
+                     (org-link-open-from-string course-link))))))))
+        (defun org-uni-capture-task-function ()
+          (let* ((sel (org-uni-select-class))
+                 (file (plist-get sel :file))
+                 (heading (plist-get sel :heading))
+                 (heading-path (plist-get sel :heading-path))
+                 (heading-norm (plist-get sel :heading-norm))
+                 (olp (append heading-path org-uni-task-olp))
+                 (path (org-capture-expand-file file))
+                 (m (org-find-olp (cons path olp))))
+            (org-capture-put :uni-class-tag heading-norm)
+            (set-buffer (marker-buffer m))
+            (org-capture-put-target-region-and-position)
+            (widen)
+            (goto-char m)
+            (set-marker m nil)))
+        (defvar org-uni-map (make-sparse-keymap)
+          "Keymap for org-uni commands.")
+        (define-key org-uni-map (kbd "u") 'org-uni-goto-class)
+        (define-key org-uni-map (kbd "c") 'org-uni-open-course-link)
+        (define-key rde-app-map (kbd "u") org-uni-map)
+        (with-eval-after-load
+            'org-capture
+          (add-to-list
+           'org-capture-templates
+           '(,capture-key
+             "University task" entry
+             (function org-uni-capture-task-function)
+             "* TODO %? :%(org-capture-get :uni-class-tag):\n:PROPERTIES:\n:CREATED: %U\n:END:\n"))))
+      #:summary "This Emacs Lisp script enhances =org-mode= with a feature for managing university tasks."
+      #:commentary "This Emacs Lisp script enhances =org-mode= with a feature for managing university tasks."
+      #:authors (list "Jakub Dlugosz <jakub@jdlugosz.com>")
+      #:url "https://jdlugosz.com/"
+      #:keywords '(convenience))))
+
+  (feature
+   (name f-name)
+   (values '())
+   (home-services-getter get-home-services)))
diff --git a/src/jd/user.scm b/src/jd/user.scm
index ba32c01..15857a0 100644
--- a/src/jd/user.scm
+++ b/src/jd/user.scm
@@ -22,6 +22,7 @@
   #:use-module (guix inferior)
   #:use-module (guix packages)
 
+  #:use-module (jd features emacs-xyz)
   #:use-module (jd features mail)
   #:use-module (jd features networking)
   #:use-module (jd features nextcloud)
@@ -311,6 +312,9 @@
    (feature-emacs-keycast      #:turn-on? #f)
    (feature-emacs-org-agenda   #:org-agenda-files '("/home/jakub/docs/notes/personal.org"
                                                     "/home/jakub/docs/notes/s22425.org"))
+   (feature-emacs-org-agenda   #:org-agenda-files '("/data/jakub/notes/personal.org"
+                                                    "/data/jakub/notes/s32526.org"))
+   (feature-emacs-org-uni)
    (feature-emacs-org-dailies  #:encrypted? #t)
    (feature-emacs-org          #:org-directory "/home/jakub/docs/notes"
                                #:org-indent? #t)