diff options
| -rw-r--r-- | Pancake/Printing.hs | 35 | ||||
| -rw-r--r-- | Pancake/Rendering.hs | 16 | ||||
| -rw-r--r-- | 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 @@ -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) |