path: root/hmm.el

;; -*- lexical-binding: t; -*-

;; Copyright (C) 2022 Yuchen Pei.
;; 
;; This file is part of hmm.el.
;; 
;; hmm.el is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; 
;; hmm.el 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 Affero General
;; Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with hmm.el.  If not, see <https://www.gnu.org/licenses/>.

(defvar hmm-web-search-engines
  '((:name ddg
           :format "https://html.duckduckgo.com/html?q=%s")
    (:name fsd
           :format "https://directory.fsf.org/w/index.php?search=%s")
    (:name ml-emacs-devel
           :format
           "https://lists.gnu.org/archive/cgi-bin/namazu.cgi?query=%s&idxname=emacs-devel")
    (:name ml-help-gnu-emacs
           :format
           "https://lists.gnu.org/archive/cgi-bin/namazu.cgi?query=%s&idxname=help-gnu-emacs")
    (:name wikipedia
           :format "https://en.wikipedia.org/w/index.php?search=%s"))
  "hmm web search engines.")

(defvar hmm-web-browsers
  '((:name eww :command eww)
    (:name firefox :command browse-url-firefox))
  "hmm web browers.")

(defvar hmm-handlers
  '(:query
    ((:command locate)
     (:command project-or-external-find-regexp)
     (:command woman)
     (:command man))
    :url
    ((:schemes ("mailto") :command browse-url-mail))
    :file
    ((:command find-file)
     (:command dired :mimetypes ("inode/directory"))
     (:command byte-compile-file :mimetypes ("text/x-lisp"))
     (:command hmm-file-mime-type)))
  "hmm handlers.")

(defvar hmm-external-handlers
  '((:name mpv
           :external-command "mpv %U"
           :display-name "mpv player"
           :description "Play url with mpv"
           :schemes
           ("ftp" "http" "https" "mms" "rtmp" "rtsp" "sftp" "smb" "srt")
           :handling :url)
    (:name wget
           :external-command "wget %U"
           :display-name "GNU Wget"
           :description "The non-interactive network downloader"
           :schemes
           ("ftp" "http" "https")
           :handling :url)
    (:name torsocks-mpv
           :external-command "torsocks mpv %U"
           :display-name "mpv player torsocks"
           :description "Play url with mpv over torsocks"
           :schemes
           ("ftp" "http" "https" "mms" "rtmp" "rtsp" "sftp" "smb" "srt")
           :handling :url))
  "hmm external handlers.")

(defvar hmm-matchers
  '(((thing-at-point-url-at-point) . hmm-url)
    ((thing-at-point-file-at-point) . hmm-file)
    ((and (derived-mode-p 'dired-mode) (dired-get-filename nil t))
     . hmm-file)
    ((and (derived-mode-p 'dired-mode) (expand-file-name default-directory))
     . hmm-file)
    ((and (derived-mode-p 'org-mode) (my-org-link-at-point)) . hmm-url)
    ((get-text-property (point) 'shr-url) . hmm-url)
    ((thing-at-point 'symbol) . hmm-query)
    ((buffer-file-name) . hmm-file)
    ((expand-file-name default-directory) . hmm-file))
  "Matchers for 'hmm-thing-at-point'.")

(defmacro hmm-define-web-search-engine (engine browser)
  (let* ((engine-name (plist-get engine :name))
         (browser-name (plist-get browser :name))
         (function-name (intern
                         (format "hmm-search-%s-%s" engine-name browser-name))))
    `(progn
       (defun ,function-name (query)
         ,(format "Search %s in %s." engine-name browser-name)
         (interactive ,(format "sSearch %s in %s for: " engine-name browser-name))
         (,(plist-get browser :command)
          (format ,(plist-get engine :format) query)))
       (hmm-add-handler '(:command ,function-name) :query))))

(defmacro hmm-define-external-handler (handler type)
  (let* ((name (plist-get handler :name))
         (display-name (or (plist-get handler :display-name)
                           (format "%s" name)))
         (description (format "%s - %s"
                              display-name
                              (plist-get handler :description)))
         (function-name (intern (format "hmm-external-%s" name)))
         (external-command
          (mapcar (lambda (token)
                    (if (string-match "^%[fFuU]$" token)
                        (if (eq type :file)
                            `(expand-file-name arg)
                          `arg)
                      token))
                  (split-string (plist-get handler :external-command))))
         (handler (plist-put handler :command function-name))
         (interactive-form
          (if (eq type :file)
              `(list
                (read-file-name ,(format "Run %s with file: " display-name)))
            (format "sRun %s with: " display-name))))
    `(progn
       (defun ,function-name (arg)
         ,description
         (interactive ,interactive-form)
         (apply 'start-process
                (append
                 (list (format ,(format "%s-%%s" function-name) arg)
                       (format ,(format "*%s-%%s*" function-name) arg))
                 ,(cons 'list external-command)))
         ,(when (plist-get handler :display-buffer)
            `(display-buffer
              (format ,(format "*%s-%%s*" function-name) arg))))
       (hmm-add-handler ',handler ,type))))

(defun hmm-add-handler (handler handling)
  (let ((handlers (plist-get hmm-handlers handling)))
    (cl-pushnew handler handlers)
    (plist-put hmm-handlers handling handlers)))

(defun hmm-thing-in-region (from to)
  (interactive "r")
  (unless (region-active-p) (error "Region not active."))
  (let* ((query (buffer-substring from to)))
    (hmm-query query)))

(defmacro hmm-define-hmm-thing-at-point ()
  `(defun hmm-thing-at-point ()
     "Prompt for what to do with thing at point."
     (interactive)
     (let ((thing))
       ,(cons 'cond
              (append
               (mapcar
                (lambda (pair)
                  `((setq thing ,(car pair))
                    (,(cdr pair) thing)))
                hmm-matchers)
               `((t (error "Cannot guess what to do with what."))))))))

(defun hmm ()
  (interactive)
  (cond ((region-active-p)
         (call-interactively 'hmm-thing-in-region))
        (t (call-interactively 'hmm-thing-at-point))))

(define-key global-map (kbd "C-M-<return>") 'hmm)

(defun hmm-query (query)
  (interactive "sQuery: ")
  (hmm-handle-internal query :query "Handle query %s using: "))

(defun hmm-url (url)
  (interactive (list (read-string "URL: " (thing-at-point-url-at-point))))
  (hmm-handle-internal url :url "Handle url %s using: "))

(defun hmm-file (file)
  (interactive (list (read-file-name "File: " default-directory
                                     (thing-at-point-file-at-point))))
  (hmm-handle-internal file :file "Handle file %s using: "))

(defun hmm-handle-internal (thing type prompt)
  (let ((selected
         (completing-read
          (format prompt thing)
          (mapcar
           (lambda (command)
             (format "%s (%s)" command
                     (if (documentation command)
                         (car
                          (split-string
                           (documentation command)
                           "\n"))
                       "Undocumented")))
           (hmm-filter-commands thing type)))))
    (funcall-interactively (intern (car (split-string selected " ("))) thing)))

(defun hmm-filter-commands (thing type)
  (let ((mimetype (hmm-file-mime-type thing)))
    (mapcar
     (lambda (handler)
       (plist-get handler :command))
     (seq-filter
      (lambda (handler)
        (and
         (hmm-thing-match thing type handler)
         (or (null (plist-get handler :mimetypes))
             (member mimetype 
                     (plist-get handler :mimetypes)))))
      (plist-get hmm-handlers type)))))

(defun hmm-thing-match (thing type handler)
  (let ((regex (plist-get handler :regex)))
    (cond ((eq type :url)
           (let ((schemes (plist-get handler :schemes))
                 (url-obj (url-generic-parse-url thing)))
             (and
              (or (null schemes)
                  (member (url-type url-obj) schemes))
              (or (not regex)
                  (string-match
                   regex
                   (hmm-url-no-scheme thing))))))
          (t (or (not regex)
                 (string-match regex thing))))))

(defun hmm-url-no-scheme (url)
  "Remove the scheme from a url."
  (let ((url-obj (url-generic-parse-url url)))
    (setf (url-type url-obj) nil
          (url-fullness url-obj) nil)
    (url-recreate-url url-obj)))

(defun hmm-update-handlers ()
  (interactive)
  (dolist (engine hmm-web-search-engines)
    (dolist (browser hmm-web-browsers)
      (eval `(hmm-define-web-search-engine ,engine ,browser))))
  (dolist (xdg-handler (hmm-get-xdg-handlers))
    (eval `(hmm-define-external-handler ,xdg-handler :file)))
  (dolist (handler hmm-external-handlers)
    (eval `(hmm-define-external-handler ,handler ,(plist-get handler :handling))))
  (dolist (browser hmm-web-browsers)
    (hmm-add-handler
     (list :command (plist-get browser :command)
           :schemes (list "http" "https"))
     :url)))

(defun hmm-update ()
  (interactive)
  (hmm-update-handlers)
  (hmm-define-hmm-thing-at-point)
  (message "Updated."))

(defun hmm-get-xdg-handlers ()
  (seq-filter
   (lambda (handler)
     (and handler (plist-get handler :mimetypes)))
   (mapcar
    (lambda (desktop-file)
      (condition-case nil
          (let ((parsed (xdg-desktop-read-file desktop-file)))
            (list
             :name (intern (concat "xdg-desktop-"
                                   (file-name-base desktop-file)))
             :display-name (gethash "Name" parsed)
             :description (gethash "Comment" parsed)
             :external-command (gethash "Exec" parsed)
             :mimetypes (seq-filter (lambda (s) (not (string-empty-p s)))
                                    (split-string (gethash "MimeType" parsed) ";"))))
        (error nil)))
    (hmm-get-all-desktop-files))))

(defun hmm-get-all-desktop-files ()
  (mapcan (lambda (dir)
            (let ((app-dir (expand-file-name "applications" dir)))
              (when (file-exists-p app-dir)
                (directory-files app-dir t "\\.desktop$"))))
          (cons (xdg-data-home) (xdg-data-dirs))))

(defun hmm-file-mime-type (file)
  "Returns (or print if called interactively) mimetype of FILE."
  (interactive)
  (let ((out))
    (when (file-exists-p file)
      (replace-regexp-in-string
       "^.*: \\(.*\\); .*$" "\\1"
       (with-temp-buffer
         (call-process "file" nil '(t t) nil "-Li" file)
         (setq out (string-trim (buffer-string)))
         (if (called-interactively-p 'interactive)
             (message out)
           out))))))

(provide 'hmm)