Add support for ESC/POS text decoration

4 files changed, 103 insertions, 7 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
-
diff --git a/server/test/Thermoprint/Server/Printer/GenericSpec.hs b/server/test/Thermoprint/Server/Printer/GenericSpec.hs
new file mode 100644
index 0000000..80096b0
--- /dev/null
+++ b/server/test/Thermoprint/Server/Printer/GenericSpec.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedStrings, OverloadedLists #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Thermoprint.Server.Printer.GenericSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck (Property, Discard(..), property)
+import Test.QuickCheck.Instances
+
+import Thermoprint.Server.Printer.Generic
+import Thermoprint.Printout
+
+import Data.Text (Text)
+import qualified Data.Text.Lazy as TL (pack)
+
+import qualified Data.ByteString.Lazy as L (ByteString)
+import qualified Data.ByteString.Lazy as L.BS
+
+import Data.String (IsString(..))
+
+import Control.Monad (zipWithM_, join)
+import Data.Monoid ((<>))
+import Data.Function (on)
+
+import Data.Word
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Debug.Trace
+
+instance IsString Line where
+  fromString = (\(Right l) -> l) . text . TL.pack
+
+spec :: Spec
+spec = do
+  describe "example printouts" $
+    zipWithM_ example [1..] examples
+  where
+    example n (s, ts) = let str = show s
+                        in specify str $ traceDump (mkPrintout . Printout . fmap (Paragraph . Seq.singleton) . fmap Cooked $ s) == ts
+
+final, initial :: L.ByteString
+initial  = esc [64] <> esc [64]
+final = "\n\n\n \n"
+
+esc :: [Word8] -> L.ByteString
+esc = L.BS.pack . (27:)
+
+p :: L.ByteString -> L.ByteString
+p = (<> final) . (initial <>)
+
+traceDump :: L.ByteString -> L.ByteString
+traceDump bs = traceShow (map (\b -> (b, (toEnum $ fromEnum b) :: Char)) $ L.BS.unpack bs) bs
+
+examples :: [(Seq Block, L.ByteString)]
+examples = [ ( [Line (JuxtaPos ["Hello", HSpace 1, "World!"])]
+             , p "Hello World!")
+           , ( [Line (JuxtaPos ["Hello", HSpace 4, "World!"])]
+             , p "Hello    World!")
+           , ( [Line ("Par1"), Line ("Par2"), Line (JuxtaPos ["Par3", HSpace 1, "Word2"])]
+             , p "Par1\n\nPar2\n\nPar3 Word2")
+           , ( [Line (JuxtaPos ["Par1", HSpace 4]), NewlSep [VSpace 2, Line ("Par2")], Line (JuxtaPos ["Par3", HSpace 1, "Word2"])]
+             , p "Par1    \n\n\n\n\nPar2\n\nPar3 Word2")
+           , ( [Line (JuxtaPos [Markup [Bold] (JuxtaPos ["B",HSpace 1,Markup [Underline] "BM"]),HSpace 1,Markup [Bold,Underline] "BM"])]
+             , p $ esc [33, 8] <> "B " <> esc [33, 128 + 8] <> "BM" <> esc [33, 8] <> esc [33, 0] <> " " <> esc [33, 128 + 8] <> "BM" <> esc [33, 0])
+           ]
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 259abf3..c80351b 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -50,7 +50,7 @@ library
                      , servant-server >=0.4.4 && <1
                      , stm >=2.4.4 && <3
                      , text >=1.2.1 && <2
-                     , thermoprint-spec ==4.0.*
+                     , thermoprint-spec ==5.0.*
                      , time >=1.5.0 && <2
                      , wai >=3.0.4 && <4
                      , warp >=3.1.9 && <4
@@ -94,6 +94,7 @@ Test-Suite tests
                      , containers >=0.5.6 && <1
                      , async >=2.1.0 && <3
                      , http-types >=0.9.1 && <1
+                     , bytestring >=0.10.6 && <1
 
 executable thermoprint-server
   main-is:             Main.hs
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index a40dddb..71a4211 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -25,10 +25,10 @@ mkDerivation {
     base monad-logger mtl persistent-sqlite resourcet
   ];
   testHaskellDepends = [
-    async base containers exceptions hspec http-types monad-logger mtl
-    persistent-sqlite QuickCheck quickcheck-instances resourcet stm
-    temporary text thermoprint-client thermoprint-spec transformers
-    warp
+    async base bytestring containers exceptions hspec http-types
+    monad-logger mtl persistent-sqlite QuickCheck quickcheck-instances
+    resourcet stm temporary text thermoprint-client thermoprint-spec
+    transformers warp
   ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "Server for thermoprint-spec";