Introduce denotations, buttonize links in emacs

Styled elements now can be denoted, so that the emacs interface can
buttonize links, while it is still easy to ignore the semantics and
just render those elements.

The emacs interface is more mouse- and TAB-friendly now.

3 files changed, 84 insertions, 22 deletions

diff --git a/Pancake/Printing.hs b/Pancake/Printing.hs
index a385751..2e0aee5 100644
--- a/Pancake/Printing.hs
+++ b/Pancake/Printing.hs
@@ -25,12 +25,13 @@ propertize :: Terminal -> Styled -> TermOutput
 propertize _ (Plain s) = termText s
 propertize t (Fg clr s) = maybe id (\f -> f clr)
   (getCapability t withForegroundColor) $ propertize t s
-propertize t (Pancake.Rendering.Bold s) =
+propertize t (Bold s) =
   maybe id id (getCapability t withBold) $ propertize t s
-propertize t (Pancake.Rendering.Emph s) =
+propertize t (Emph s) =
   maybe id id (getCapability t withStandout) $ propertize t s
-propertize t (Pancake.Rendering.Underline s) =
+propertize t (Underline s) =
   maybe id id (getCapability t withUnderline) $ propertize t s
+propertize t (Denote _ s) = propertize t s
 
 -- | Prints rendered lines.
 showLines :: MonadIO m => [StyledLine] -> m ()
@@ -57,7 +58,7 @@ showSexps uri ro =
   -- abandoned, and the task is simple enough to do it here
   putSexpLn [ "render"
             , list $ "lines" :
-              map (list . pure . concat . intersperse " " . map showSexp)
+              map (list . pure . concat . intersperse " " . map showSexp . mergeStyled)
               (rLines ro)
             , list $ "identifiers"
               : map (\(i, l) -> list [encodeStr i, show l]) (rIdentifiers ro)
@@ -76,3 +77,29 @@ showSexps uri ro =
     showSexp (Bold s) = list ["style", "bold", showSexp s]
     showSexp (Underline s) = list ["style", "underline", showSexp s]
     showSexp (Emph s) = list ["style", "italic", showSexp s]
+    showSexp (Denote d s) = list [ "denotation"
+                                 , showDenotation d
+                                 , showSexp s]
+    showDenotation :: Denotation -> String
+    showDenotation (Link u) = list ["link", ".", encodeStr $ show u]
+    showDenotation (Math m) = list ["math", ".", encodeStr m]
+
+mergeStyled :: [Styled] -> [Styled]
+mergeStyled = foldr mergeStyled' []
+  where
+    mergeStyled' :: Styled -> [Styled] -> [Styled]
+    mergeStyled' s [] = [s]
+    mergeStyled' s (s':rest) = maybe (s:s':rest) (: rest) (tryMerge s s')
+
+tryMerge :: Styled -> Styled -> Maybe Styled
+tryMerge (Plain s) (Plain s') = pure $ Plain $ s ++ s'
+tryMerge (Fg clr s) (Fg clr' s')
+  | clr == clr' = Fg clr <$> tryMerge s s'
+  | otherwise = mzero
+tryMerge (Bold s) (Bold s') = Bold <$> tryMerge s s'
+tryMerge (Underline s) (Underline s') = Underline <$> tryMerge s s'
+tryMerge (Emph s) (Emph s') = Emph <$> tryMerge s s'
+tryMerge (Denote d s) (Denote d' s')
+  | d == d' = Denote d <$> tryMerge s s'
+  | otherwise = mzero
+tryMerge _ _ = mzero
diff --git a/Pancake/Rendering.hs b/Pancake/Rendering.hs
index 76a9769..2af0ec4 100644
--- a/Pancake/Rendering.hs
+++ b/Pancake/Rendering.hs
@@ -9,7 +9,8 @@ Document rendering: conversion from 'Pandoc' to 'RendererOutput'.
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Pancake.Rendering ( Styled(..)
+module Pancake.Rendering ( Denotation(..)
+                         , Styled(..)
                          , StyledLine
                          , RendererOutput(..)
                          , rLinks
@@ -34,12 +35,17 @@ data Listing = Bulleted
              | Ordered Int
              deriving (Show, Eq)
 
+data Denotation = Link URI
+                | Math String
+                deriving (Show, Eq)
+
 -- | A styled string.
 data Styled = Plain String
             | Underline Styled
             | Bold Styled
             | Emph Styled
             | Fg Color Styled
+            | Denote Denotation Styled
             deriving (Show, Eq)
 
 -- | Just for convenience.
@@ -173,6 +179,7 @@ unstyled = concatMap unstyled'
     unstyled' (Bold s) = unstyled' s
     unstyled' (Emph s) = unstyled' s
     unstyled' (Fg _ s) = unstyled' s
+    unstyled' (Denote _ s) = unstyled' s
 
 -- | Fits words into terminal lines of a given width.
 fitLines :: Int
@@ -193,6 +200,7 @@ fitLines maxLen inlineBits = concatMap (map reverse . fitWords [] 0) inlineBits
     splitStyled (Bold s) = map Bold $ splitStyled s
     splitStyled (Emph s) = map Emph $ splitStyled s
     splitStyled (Fg c s) = map (Fg c) $ splitStyled s
+    splitStyled (Denote d s) = map (Denote d) $ splitStyled s
     fitWords :: [Styled] -> Int -> [Styled] -> [StyledLine]
     fitWords curLine curLen (w:ws)
       -- handle newline characters
@@ -253,7 +261,7 @@ readInline (P.Code attr s) = do
 readInline P.Space = pure [" "]
 readInline P.SoftBreak = pure [" "]
 readInline P.LineBreak = pure ["\n"]
-readInline (P.Math _ s) = pure [fromString s]
+readInline (P.Math _ s) = pure [Denote (Math s) $ fromString s]
 readInline (P.RawInline _ s) = pure [fromString s]
 readInline (P.Link attr alt (url, title)) = do
   storeAttr attr
@@ -269,7 +277,7 @@ readInline (P.Link attr alt (url, title)) = do
       let color = case uri of
             (URI "" Nothing "" "" ('#':_)) -> Magenta
             _ -> Cyan
-      pure $ (map $ Fg color) t ++
+      pure $ (map $ Denote (Link uri) . Fg color) t ++
         [Fg Blue $ fromString (concat ["[", show cnt, "]"])]
     Nothing -> pure [fromString title]
 readInline (P.Image attr alt (url, title)) = do
@@ -284,7 +292,7 @@ readInline (P.Image attr alt (url, title)) = do
             (title', []) -> [fromString title']
             (_, alt') -> alt'
       cnt <- storeLink uri
-      pure $ (map $ Fg Cyan) t ++
+      pure $ (map $ Denote (Link uri) . Fg Cyan) t ++
         [Fg Blue $ fromString (concat ["[", show cnt, "]"])]
 readInline (P.Note _) = pure . pure $ "(note: todo)"
 readInline (P.Span attr i) = do
diff --git a/pancake.el b/pancake.el
index 61cb7c5..2fe1e1a 100644
--- a/pancake.el
+++ b/pancake.el
@@ -164,26 +164,35 @@
                   "-"
                   (symbol-name attr))))
 
+(defun pancake-button-action (button)
+  "An action to be invoked on button activation."
+  (funcall 'browse-url (button-get button 'uri)))
+
 (defun pancake-print-elem (element)
   "Translate ELEMENT into a string."
   (if (stringp element)
-      element
-    (pcase element
-      (`(fg ,color . ,rest)
-       (let ((inner (pancake-print-line rest)))
+      (insert element)
+    (let ((start (point)))
+      (pcase element
+        (`(fg ,color . ,rest)
+         (pancake-print-line rest)
          (add-face-text-property
-          0 (length inner) (pancake-translate-color color 'foreground) t inner)
-         inner))
-      (`(style ,face . ,rest)
-       (let ((inner (pancake-print-line rest)))
-         (add-face-text-property 0 (length inner) face t inner)
-         inner))
-      (_ (format "Unexpected element: %S" element)))))
-
+          start (point) (pancake-translate-color color 'foreground) t))
+        (`(style ,face . ,rest)
+         (pancake-print-line rest)
+         (add-face-text-property start (point) face t))
+        (`(denotation (math . ,formula) . ,rest)
+         (pancake-print-line rest))
+        (`(denotation (link . ,uri) . ,rest)
+         (pancake-print-line rest)
+         (make-text-button start (point)
+                           'uri uri
+                           'action #'pancake-button-action))
+        (_ (format "Unexpected element: %S" element))))))
 
 (defun pancake-print-line (line)
   "Translate LINE (a list of elements) into a string"
-  (apply 'concat (mapcar 'pancake-print-elem line)))
+  (mapc 'pancake-print-elem line))
 
 (defun pancake-line-p (string)
   "Return t if STRING ends with a newline character."
@@ -207,7 +216,7 @@
                  ;; further manipulation
                  (setq pancake-current-uri (alist-get 'uri alist))
                  (dolist (line (alist-get 'lines alist))
-                   (insert (pancake-print-line line))
+                   (pancake-print-line line)
                    (newline))
                  (read-only-mode 1)
                  (goto-char (point-min)))
@@ -283,6 +292,20 @@
     (message "%s" pancake-current-uri)
     (kill-new pancake-current-uri)))
 
+(defun pancake-next-button ()
+  "Moves cursor to the next button."
+  (interactive)
+  (let ((next (next-button (point))))
+    (when next
+      (goto-char next))))
+
+(defun pancake-previous-button ()
+  "Moves cursor to the previous button."
+  (interactive)
+  (let ((prev (previous-button (point))))
+    (when prev
+      (goto-char prev))))
+
 (defun pancake-input (string)
   "Pancake input handler: opens minibuffer for input.
 Sets the initial contents to STRING, reads the rest, and passes
@@ -301,6 +324,10 @@ it to `pancake-process' as input."
         (define-key map (kbd str) (pancake-input str))))
     (define-key map (kbd "C-y") 'pancake-yank)
     (define-key map (kbd "<mouse-2>") 'pancake-yank-primary)
+    (define-key map (kbd "<mouse-8>") 'pancake-go-backward)
+    (define-key map (kbd "<mouse-9>") 'pancake-go-forward)
+    (define-key map (kbd "TAB") 'pancake-next-button)
+    (define-key map (kbd "<backtab>") 'pancake-previous-button)
     (define-key map (kbd "C-c C-c") 'pancake-interrupt)
     (define-key map (kbd "C-c C-u") 'pancake-display-current-uri)
     (define-key map (kbd "B") 'pancake-go-backward)