From 1d8a5140e3ce03d9fa6b9c63a6621ab3ab64eb4c Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Tue, 7 Nov 2017 21:37:54 +0300
Subject: Let Emacs to render subscripts, superscripts, strikethrough

That is, add `Styled` constructors for those.
---
 Pancake/Printing.hs  |  9 +++++++++
 Pancake/Rendering.hs | 15 ++++++++++++---
 2 files changed, 21 insertions(+), 3 deletions(-)

(limited to 'Pancake')

diff --git a/Pancake/Printing.hs b/Pancake/Printing.hs
index 66d2606..9bc6c81 100644
--- a/Pancake/Printing.hs
+++ b/Pancake/Printing.hs
@@ -30,6 +30,12 @@ propertize t (Bold s) =
   fromMaybe id (getCapability t withBold) $ propertize t s
 propertize t (Emph s) =
   fromMaybe id (getCapability t withStandout) $ propertize t s
+propertize t (Strikethrough s) =
+  mconcat [termText "-", propertize t s, termText "-"]
+propertize t (Subscript s) =
+  mconcat [termText "_{", propertize t s, termText "}"]
+propertize t (Superscript s) =
+  mconcat [termText "^{", propertize t s, termText "}"]
 propertize t (Underline s) =
   fromMaybe id (getCapability t withUnderline) $ propertize t s
 propertize t (Denote _ s) = propertize t s
@@ -78,6 +84,9 @@ 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 (Strikethrough s) = list ["style", "strikethrough", showSexp s]
+    showSexp (Subscript s) = list ["subscript", showSexp s]
+    showSexp (Superscript s) = list ["superscript", showSexp s]
     showSexp (Denote d s) = list [ "denotation"
                                  , showDenotation d
                                  , showSexp s]
diff --git a/Pancake/Rendering.hs b/Pancake/Rendering.hs
index 7b219b9..e88a9ad 100644
--- a/Pancake/Rendering.hs
+++ b/Pancake/Rendering.hs
@@ -44,6 +44,9 @@ data Styled = Plain String
             | Underline Styled
             | Bold Styled
             | Emph Styled
+            | Strikethrough Styled
+            | Subscript Styled
+            | Superscript Styled
             | Fg Color Styled
             | Denote Denotation Styled
             deriving (Show, Eq)
@@ -178,6 +181,9 @@ unstyled = concatMap unstyled'
     unstyled' (Underline s) = unstyled' s
     unstyled' (Bold s) = unstyled' s
     unstyled' (Emph s) = unstyled' s
+    unstyled' (Strikethrough s) = unstyled' s
+    unstyled' (Subscript s) = unstyled' s
+    unstyled' (Superscript s) = unstyled' s
     unstyled' (Fg _ s) = unstyled' s
     unstyled' (Denote _ s) = unstyled' s
 
@@ -199,6 +205,9 @@ fitLines maxLen inlineBits = concatMap (map reverse . fitWords [] 0) inlineBits
     splitStyled (Underline s) = map Underline $ splitStyled s
     splitStyled (Bold s) = map Bold $ splitStyled s
     splitStyled (Emph s) = map Emph $ splitStyled s
+    splitStyled (Strikethrough s) = map Strikethrough $ splitStyled s
+    splitStyled (Subscript s) = map Subscript $ splitStyled s
+    splitStyled (Superscript s) = map Superscript $ 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]
@@ -248,9 +257,9 @@ readInline (P.Str s)
   | otherwise = pure [fromString s]
 readInline (P.Emph s) = concatMap (map Emph) <$> mapM readInline s
 readInline (P.Strong s) = concatMap (map Bold) <$> mapM readInline s
-readInline (P.Strikeout s) = wrappedInlines "-" "-" s
-readInline (P.Superscript s) = wrappedInlines "^{" "}" s
-readInline (P.Subscript s) = wrappedInlines "_{" "}" s
+readInline (P.Strikeout s) = concatMap (map Strikethrough) <$> mapM readInline s
+readInline (P.Superscript s) = concatMap (map Superscript) <$> mapM readInline s
+readInline (P.Subscript s) = concatMap (map Subscript) <$> mapM readInline s
 readInline (P.SmallCaps s) = wrappedInlines "\\sc{" "}" s
 readInline (P.Quoted P.SingleQuote s) = wrappedInlines "‘" "’" s
 readInline (P.Quoted P.DoubleQuote s) = wrappedInlines "“" "”" s
-- 
cgit v1.2.3