From 2a2336312fff0afdfb4d6486cee83da780366021 Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 5 Nov 2017 21:41:27 +0300 Subject: 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. --- Pancake/Printing.hs | 35 +++++++++++++++++++++++++++++---- Pancake/Rendering.hs | 16 +++++++++++---- pancake.el | 55 +++++++++++++++++++++++++++++++++++++++------------- 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 "") 'pancake-yank-primary) + (define-key map (kbd "") 'pancake-go-backward) + (define-key map (kbd "") 'pancake-go-forward) + (define-key map (kbd "TAB") 'pancake-next-button) + (define-key map (kbd "") '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) -- cgit v1.2.3