;; -*- 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 .
(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-transformers
nil
"hmm transformers.
Transforms from one type to another type.")
(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)
"Defines a simple transformer from a search engine.
A search engine is basically a format string with one single %s
to be substitutes by the search query."
(let* ((engine-name (plist-get engine :name))
(function-name (intern
(format "hmm-%s-format-url" engine-name))))
`(progn
(defun ,function-name (query)
,(format "Format %s url from QUERY." engine-name)
(format ,(plist-get engine :format) query))
(hmm-add-transformer
'( :function ,function-name :name ,engine-name
:from :query :to :url)))))
;; TODO: Validate the output type of the transformer agrees with the
;; input type of the handler.
(defmacro hmm-define-compound-handler (transformer handler)
"Define a compound handler that feeds the output of TRANSFORMER into HANDLER.
Say transformer is ddg (query->url) and handler is firefox (url),
then the resulting function is hmm-ddg-firefox, which takes a
input and open the ddg search url in firefox."
(when-let* ((trans-name (or (plist-get transformer :name)
(plist-get transformer :function)))
(handler-name (plist-get handler :name))
(function-name (intern
(format "hmm-%s-%s" trans-name handler-name)))
(from (plist-get transformer :from)))
`(progn
(defun ,function-name (input)
,(format "Handle the output of %s with %s."
trans-name handler-name)
(interactive ,(format "sHandle %s with %s for: " trans-name handler-name))
(,(plist-get handler :command)
(,(plist-get transformer :function) input)))
(hmm-add-handler '(:command ,function-name) ,from))))
(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)
(setq hmm-handlers (plist-put hmm-handlers handling handlers))))
(defun hmm-add-transformer (transformer)
(let* ((sig (intern (format "%s->%s"
(plist-get transformer :from)
(plist-get transformer :to))))
(transformers (plist-get hmm-transformers sig)))
(cl-pushnew transformer transformers)
(setq hmm-transformers (plist-put hmm-transformers sig transformers))))
(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-") '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)
(eval `(hmm-define-web-search-engine ,engine)))
(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)
:name (plist-get browser :name)
:schemes (list "http" "https"))
:url))
(print (length (plist-get hmm-transformers :query->:url)))
(print (length (plist-get hmm-handlers :url)))
(let ((pairs))
(dolist (transformer (plist-get hmm-transformers :query->:url))
(dolist (handler (plist-get hmm-handlers :url))
(pushnew (cons transformer handler) pairs)))
(dolist (pair pairs)
(eval `(hmm-define-compound-handler ,(car pair) ,(cdr pair)))))
)
(defun hmm-update ()
(interactive)
(hmm-update-handlers)
(hmm-define-hmm-thing-at-point)
(message "hmm: 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)