diff options
author | defanor <defanor@uberspace.net> | 2017-11-05 21:41:27 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2017-11-05 21:59:12 +0300 |
commit | 2a2336312fff0afdfb4d6486cee83da780366021 (patch) | |
tree | 95c5feee5d41e66fc173f3a7db6d73eacacfc7e7 /Pancake | |
parent | 37d710540002c27149b3511d895b73dc30480267 (diff) |
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.
Diffstat (limited to 'Pancake')
-rw-r--r-- | Pancake/Printing.hs | 35 | ||||
-rw-r--r-- | Pancake/Rendering.hs | 16 |
2 files changed, 43 insertions, 8 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 |