From 2a2336312fff0afdfb4d6486cee83da780366021 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
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 +++++++++++++++++++++++++++++++----
 1 file changed, 31 insertions(+), 4 deletions(-)

(limited to 'Pancake/Printing.hs')

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
-- 
cgit v1.2.3