eww-hacks/eww-hacks.el

;;; eww-hacks.el --- Hacks of doubtful provenance for eww -*- lexical-binding: t; -*-
;;
;; Author: rahguzar <rahguzar@zohomail.eu>
;; Maintainer: rahguzar <rahguzar@zohomail.eu>
;; Created: October 16, 2023
;; Version: 0.0.1
;; Keywords: comm eww convenience multimedia
;; Homepage: https://codeberg.org/rahguzar/eww-hacks
;; Package-Requires: ((emacs "29.1"))
;;
;; This file is not part of GNU Emacs.
;;
;;; Commentary:
;; Hacks to make eww a better experience on some pages. For now these include
;; wikipedia especially its math pages, theurdudictionary.com and documentation
;; from dash docs.
;;
;; It requires shr and eww with the patches in
;; https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-10/msg01609.html
;; applied.
;;
;; To use these hacks require this package from your init file.
;;
;;; Code:
(require 'eww)
(require 'shr)
(require 'tex-mode)
(require 'tex-fold)

;;; Hacks to alter shr rendering
(defvar eww-hacks--d-outline-level 6)

(defun eww-hacks-tag-dl (dom)
  "DOM."
  (let ((eww-hacks--d-outline-level (1+ eww-hacks--d-outline-level))
        (fun (lambda (prefix) (concat prefix "  ")))
        (start (point)))
    (shr-tag-dl dom)
    (alter-text-property start (point) 'line-prefix fun)
    (alter-text-property start (point) 'wrap-prefix fun)))

(defun eww-hacks-tag-dt (dom)
  "DOM."
  (shr-ensure-newline)
  (let ((start (point)))
    (shr-generic dom)
    (put-text-property
     start (point) outline-level eww-hacks--d-outline-level)
    (put-text-property start (point)
                       'outline-level eww-hacks--d-outline-level)
    (add-face-text-property start (point) 'bold t))
  (shr-ensure-newline))

(push '(dl . eww-hacks-tag-dl) shr-external-rendering-functions)
(push '(dt . eww-hacks-tag-dt) shr-external-rendering-functions)

(defvar eww-hacks-class-face-alist
  '(("highlight" . org-block)
    ("mw-highlight" . org-block)
    ("warning" . font-lock-warning-face)
    ("admonition-title" . bold)
    ("gp" . comint-highlight-prompt)
    ("kn" . font-lock-keyword-face)
    ("kr" . font-lock-keyword-face)
    ("kt" . font-lock-type-face)
    ("nb" . font-lock-builtin-face)
    ("nn" . font-lock-function-name-face)
    ("nf" . font-lock-function-name-face)
    ("o" . font-lock-operator-face)
    ("ow" . font-lock-operator-face)
    ("p" . font-lock-punctuation-face)
    ("mi" . font-lock-number-face)
    ("c1" . font-lock-comment-face)
    ("s1" . font-lock-string-face)
    ("sig-prename descclassname" . font-lock-function-name-face)
    ("sig-name descname" . font-lock-type-face))
  "An alist of (CLASS . FACE).
If a div or span tag has class attribute, FACE is applied to its rendering.")

(defvar eww-hacks-class-function-alist
  '(("math" . eww-hacks-fold-math))
  "Alist of (CLASS . FUNCTION).
If a div or span tag has class attribute, FUNCTION is called with the rendered
string as its argument. It should return a string which is then inserted in
place of the original string.")

(defvar eww-hacks--tex-buffer nil)

(defun eww-hacks-string-match (needle haystack)
  "Return non-nil if NEEDLE is a word in string HAYSTACK."
  (string-match (rx (or bos " ") (literal needle) (or eos " "))
                haystack))

(defun eww-hacks-tag-span (dom)
  "DOM."
  (let ((start (point))
        (face (alist-get (or (dom-attr dom 'class) "")
                         eww-hacks-class-face-alist
                         nil t #'eww-hacks-string-match)))
    (shr-tag-span dom)
    (when-let ((fun (alist-get (or (dom-attr dom 'class) "")
                               eww-hacks-class-function-alist
                               nil t #'eww-hacks-string-match)))
      (insert (funcall fun (delete-and-extract-region start (point)))))
    (when face (add-face-text-property start (point) face))))

(defun eww-hacks-tag-div (dom)
  "DOM."
  (let ((start (point))
        (face (alist-get (or (dom-attr dom 'class) "")
                         eww-hacks-class-face-alist
                         nil t #'eww-hacks-string-match)))
    (shr-tag-div dom)
    (when-let ((fun (alist-get (or (dom-attr dom 'class) "")
                               eww-hacks-class-function-alist
                               nil t #'eww-hacks-string-match)))
      (insert (funcall fun (delete-and-extract-region start (point)))))
    (when face (add-face-text-property start (point) face))))

(push '(div . eww-hacks-tag-div) shr-external-rendering-functions)
(push '(span . eww-hacks-tag-span) shr-external-rendering-functions)

(defun eww-hacks-fold-math (str)
  "Get a nicer representation of math string STR.
Uses `tex-fold-mode' and `prettify-symbols-mode'."
  (unless (buffer-live-p " *eww-hacks-math*")
    (with-current-buffer (get-buffer-create " *eww-hacks-math*" t)
      (setq-local prettify-symbols-alist tex--prettify-symbols-alist)
      (push '("\\qquad" . ? ) prettify-symbols-alist)
      (push '("\\quad" . ? ) prettify-symbols-alist)
      (make-local-variable 'TeX-fold-math-spec-list)
      (push `(,(lambda (str) (propertize str 'face 'shr-text)) ("text"))
            TeX-fold-math-spec-list)
      (tex-fold-mode)
      (prettify-symbols-mode)))
  (with-current-buffer " *eww-hacks-math*"
    (erase-buffer)
    (insert (replace-regexp-in-string (rx "\\" (or ?\( ?\) ?\[ ?\])) "" str))
    (insert "\n")
    (TeX-fold-buffer)
    (font-lock-ensure)
    (TeX-fold-buffer-substring (point-min) (1- (point-max)))))

;;; Hacks to make some website better using shrface provided features
(require 'outline)

(defvar eww-hacks-url-prettify-list
  `((,(rx any) outline-minor-mode)
    (,(rx "wikipedia.org/wiki/")
     eww-hacks-cleanup-wikipedia
     outline-show-only-headings)
    (,(rx (or "https://doc.sagemath.org/html/"
              (and "file:///"
                   (eval (expand-file-name "~/.local/share/dashdocs/Sage")))))
     eww-hacks-delete-till-first-heading
     outline-show-only-headings)
    (,(rx "https://theurdudictionary.com/?q=")
     eww-hacks-delete-till-first-heading))
  "A list of (REGEX . FUNCTIONS).
REGEX is a regular expression and FUNCTIONS is a list of functions.
If the current url matches REGEX, FUNCTIONS are run after rendering.
More precisely the are run by a hook in `eww-after-render-hook'.

The FUNCTIONS are run with `inhibit-read-only' bound to t so the buffer
can be freely modified.")

(add-hook 'eww-after-render-hook #'eww-hacks-prettify)

(defun eww-hacks-prettify ()
  "Prettify using the rules in `eww-hacks-url-prettify-list'."
  (setq-local outline-minor-mode-highlight nil)
  (save-excursion
    (let ((url (eww-current-url))
          (inhibit-read-only t))
      (pcase-dolist (`(,rx . ,funs) eww-hacks-url-prettify-list)
        (when (string-match rx url)
          (dolist (fun funs)
            (funcall fun)))))))

(defun eww-hacks-delete-till-first-heading ()
  "Delete everything till first heading. Useful for e.g. wikipedia."
  (goto-char (point-min))
  (outline-next-heading)
  (while (and (> (funcall outline-level) 1) (not (eobp)))
    (outline-next-heading))
  (unless (eobp)
    (delete-region (point-min) (pos-bol))))

(defvar eww-hacks-wikipedia-history nil)
(defvar savehist-additional-variables)
(cl-pushnew 'eww-hacks-wikipedia-history savehist-additional-variables)

(defun eww-hacks-cleanup-wikipedia ()
  "Delete everything till first heading for a wikipedi page.
Also remove the table of contents."
  (eww-hacks-delete-till-first-heading)
  (let ((start (pos-eol))
        (url (eww-current-url)))
    (when (search-forward "From Wikipedia, the free encyclopedia" nil t)
      (delete-region start (pos-eol)))
    (when (string-match (rx "wikipedia.org/wiki/" (group (* any))) url)
      (add-to-history 'eww-hacks-wikipedia-history
                      (url-unhex-string (match-string 1 url))))))

;;; Functions to get some web pages

;;;###autoload
(defun eww-hacks-wikipedia-article (query)
  "Get Wikipedia article for QUERY."
  (interactive (list (completing-read "Wikipedia: " eww-hacks-wikipedia-history
                                      nil nil nil
                                      (if (region-active-p)
                                          (funcall region-extract-function)
                                        (word-at-point)))))
  (eww (format "https://en.wikipedia.org/wiki/%s" query)) )

;;;###autoload
(defun eww-hacks-urdu-lookup-word (word)
  "Look up WORD in theurdudictionary.com ."
  (interactive (list (if (or (eq (current-bidi-paragraph-direction) 'right-to-left)
                             current-prefix-arg)
                         (read-string "Word to translate to Urdu: ")
                       (if (region-active-p)
                           (funcall region-extract-function)
                         (word-at-point)))))
  (eww (format "https://theurdudictionary.com/?q=%s" word)))

(provide 'eww-hacks)
;;; eww-hacks.el ends here