From 64b6ead0d1e157701f8569743eda496bc71b8351 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 23 Jan 2017 16:09:05 +0100 Subject: Add support for ESC/POS text decoration --- server/src/Thermoprint/Server/Printer/Generic.hs | 30 +++++++++- .../test/Thermoprint/Server/Printer/GenericSpec.hs | 69 ++++++++++++++++++++++ server/thermoprint-server.cabal | 3 +- server/thermoprint-server.nix | 8 +-- 4 files changed, 103 insertions(+), 7 deletions(-) create mode 100644 server/test/Thermoprint/Server/Printer/GenericSpec.hs (limited to 'server') 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"; -- cgit v1.2.3