Add support for ESC/POS text decoration

1 files changed, 28 insertions, 2 deletions

diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index f431e4f..ce818ee 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -6,6 +6,7 @@
 
 module Thermoprint.Server.Printer.Generic
        ( genericPrint
+       , mkPrintout
        ) where
 
 import Thermoprint.Printout
@@ -31,6 +32,7 @@ import Data.Encoding
 import Data.Encoding.CP437
 import Data.Binary.Put
 import Data.Word
+import Data.Bits
 
 import Control.Monad
 import Control.Monad.Reader
@@ -47,6 +49,8 @@ import Control.Monad.Catch
 import Data.Foldable
 
 import Data.List (genericReplicate, genericLength, intercalate)
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 import Data.Monoid
 
@@ -69,7 +73,10 @@ genericPrint' path = flip catches handlers . withFile path . print
                ]
     print printout handle = $(logDebug) (T.pack $ show printout') >> liftIO (slowPut handle printout' >> return Nothing)
       where
-        printout' = runPut $ initialize >> render printout >> finalize
+        printout' = mkPrintout printout
+
+mkPrintout :: Printout -> Lazy.ByteString
+mkPrintout printout = runPut $ initialize >> render printout >> finalize
 
 slowPut :: Handle -> Lazy.ByteString -> IO ()
 slowPut h = slowPut' . LBS.split (LBS.last newl)
@@ -128,6 +135,7 @@ data Doc = Doc
   , space :: Integer
   , remainingSpace :: Integer
   , overflows :: Integer
+  , currentMarkup :: Set MarkupMode
   }
 
 initDoc :: Integer -> Doc
@@ -136,6 +144,7 @@ initDoc space = Doc { lines          = Seq.empty
                     , space          = space
                     , remainingSpace = space
                     , overflows      = 0
+                    , currentMarkup  = Set.empty
                     }
 
 breakLine :: Doc -> Doc
@@ -151,6 +160,19 @@ renderDoc Doc{..} = intersperse' (newls' 1) id lines'
       | remainingSpace == space = lines
       | otherwise               = lines |> currentLine
 
+escSequence' :: [Word8] -> State Doc ()
+escSequence' s = modify (\(doc@(Doc{..})) -> doc { currentLine = currentLine >> escSequence s })
+
+setMarkup :: Set MarkupMode -> State Doc ()
+setMarkup m = escSequence' [33, byte m] >> modify (\doc -> doc { currentMarkup = m })
+  where
+    byte = foldr (.|.) zeroBits . Set.map bitMask
+    bitMask Bold = 8
+    bitMask DoubleHeight = 16
+    bitMask DoubleWidth  = 32
+    bitMask Underline    = 128
+    bitMask _            = zeroBits
+ 
 renderBlock :: Block -> State Doc ()
 renderBlock (VSpace n)   = sequence_ . genericReplicate n $ modify' breakLine
 renderBlock (NewlSep xs) = intersperse' (modify' breakLine) renderBlock xs
@@ -165,6 +187,11 @@ renderLine (HSpace n)    = modify' insertSpace
                                  }
       | remainingSpace == n = breakLine doc
       | otherwise = breakLine $ doc { overflows = overflows + 1 }
+renderLine (Markup ms l)
+  | Set.null ms = renderLine l
+  | otherwise = do
+      prevMarkup <- gets currentMarkup
+      setMarkup (prevMarkup <> ms) >> renderLine l >> setMarkup prevMarkup
 renderLine (JuxtaPos xs) = mapM_ renderLine xs
 renderLine (cotext . Line -> word) = modify' $ insertWord
   where
@@ -192,4 +219,3 @@ renderLine (cotext . Line -> word) = modify' $ insertWord
                                       }
           | otherwise = doc
     encode'' = encode' . TL.unpack
-