Add strikeout support

Author: silby

src/Text/DocLayout.hs

@@ -59,6 +59,7 @@ module Text.DocLayout (
      , bold
      , italic
      , underlined
+     , strikeout
      , fg
      , bg
      , Color
@@ -787,6 +788,9 @@ italic = styled (RShape Italic)
 underlined :: HasChars a => Doc a -> Doc a
 underlined = styled (RUnderline ULSingle)
 
+strikeout :: HasChars a => Doc a -> Doc a
+strikeout = styled (RStrikeout Struck)
+
 -- The Color type is here as an opaque alias to Color8 for the public interface
 -- and there's trivial smart constructors for the individual colors to
 -- hopefully allow for easier extension to supporting indexed and rgb colors in

src/Text/DocLayout/ANSIFont.hs

@@ -8,6 +8,7 @@ module Text.DocLayout.ANSIFont
   , Shape(..)
   , Color8(..)
   , Underline(..)
+  , Strikeout(..)
   , Foreground(..)
   , Background(..)
   , (~>)
@@ -23,24 +24,31 @@ data Font = Font
   { ftWeight :: Weight,
     ftShape :: Shape,
     ftUnderline :: Underline,
+    ftStrikeout :: Strikeout,
     ftForeground :: Foreground,
     ftBackground :: Background,
     ftLink :: Maybe Text
   }
   deriving (Show, Eq, Read, Data, Ord)
 
 baseFont :: Font
-baseFont = Font Normal Roman ULNone FGDefault BGDefault Nothing
+baseFont = Font Normal Roman ULNone Unstruck FGDefault BGDefault Nothing
 
 data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord)
 data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord)
 data Color8 = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Show, Eq, Enum, Read, Data, Ord)
 data Underline = ULNone | ULSingle | ULDouble | ULCurly deriving (Show, Eq, Read, Data, Ord)
+data Strikeout = Unstruck | Struck deriving (Show, Eq, Read, Data, Ord)
 data Foreground = FGDefault | FG Color8 deriving (Show, Eq, Read, Data, Ord)
 data Background = BGDefault | BG Color8 deriving (Show, Eq, Read, Data, Ord)
 
-data StyleReq =
-  RWeight Weight | RShape Shape | RForeground Foreground | RBackground Background | RUnderline Underline
+data StyleReq
+  = RWeight Weight
+  | RShape Shape
+  | RForeground Foreground
+  | RBackground Background
+  | RUnderline Underline
+  | RStrikeout Strikeout
   deriving (Show, Eq, Read, Data, Ord)
 
 (~>) :: Font -> StyleReq -> Font
@@ -49,6 +57,7 @@ data StyleReq =
 (~>) f (RForeground c) = f{ftForeground = c}
 (~>) f (RBackground c) = f{ftBackground = c}
 (~>) f (RUnderline u) = f{ftUnderline = u}
+(~>) f (RStrikeout u) = f{ftStrikeout = u}
 
 rawSGR :: (Semigroup a, IsString a) => a -> a
 rawSGR n = "\ESC[" <> n <> "m"
@@ -78,6 +87,10 @@ instance SGR Underline where
   renderSGR ULDouble = rawSGR "21"
   renderSGR ULCurly = rawSGR "4:3"
 
+instance SGR Strikeout where
+  renderSGR Unstruck = rawSGR "29"
+  renderSGR Struck = rawSGR "9"
+
 renderFont :: (Semigroup a, IsString a) => Font -> a
 renderFont f
   | f == baseFont = rawSGR "0"
@@ -87,6 +100,7 @@ renderFont f
         <> renderSGR (ftForeground f)
         <> renderSGR (ftBackground f)
         <> renderSGR (ftUnderline f)
+        <> renderSGR (ftStrikeout f)
 
 renderOSC8 :: (Semigroup a, IsString a) => Maybe a -> a
 renderOSC8 Nothing = "\ESC]8;;\ESC\\"