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 --- client/thermoprint-client.cabal | 4 +- client/thermoprint-client.nix | 2 +- 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 +-- spec/src/Thermoprint/Printout.hs | 15 +++++ spec/thermoprint-spec.cabal | 2 +- spec/thermoprint-spec.nix | 2 +- tp-bbcode/src/Thermoprint/Printout/BBCode.hs | 27 +++++++-- tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs | 2 + tp-bbcode/thermoprint-bbcode.cabal | 4 +- 12 files changed, 150 insertions(+), 18 deletions(-) create mode 100644 server/test/Thermoprint/Server/Printer/GenericSpec.hs diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 9c481e3..0920773 100644 --- a/client/thermoprint-client.cabal +++ b/client/thermoprint-client.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-client -version: 1.0.0 +version: 1.0.1 synopsis: Client for thermoprint-spec -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -21,7 +21,7 @@ library -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 - , thermoprint-spec ==4.0.* + , thermoprint-spec ==5.0.* , servant >=0.4.4 && <1 , servant-client >=0.4.4 && <1 , servant-server >=0.4.4 && <1 diff --git a/client/thermoprint-client.nix b/client/thermoprint-client.nix index 8e608cf..8aadafb 100644 --- a/client/thermoprint-client.nix +++ b/client/thermoprint-client.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "thermoprint-client"; - version = "1.0.0"; + version = "1.0.1"; src = ./.; libraryHaskellDepends = [ base containers either exceptions http-client mtl servant 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"; diff --git a/spec/src/Thermoprint/Printout.hs b/spec/src/Thermoprint/Printout.hs index 8c33e07..752ccb5 100644 --- a/spec/src/Thermoprint/Printout.hs +++ b/spec/src/Thermoprint/Printout.hs @@ -11,7 +11,9 @@ module Thermoprint.Printout , Block(..) , Line( HSpace , JuxtaPos + , Markup ) + , MarkupMode(..) , text, cotext , prop_text ) where @@ -48,6 +50,9 @@ import Data.Monoid (Monoid(..), (<>)) import Data.List (dropWhile, dropWhileEnd, groupBy, genericLength, genericReplicate) +import Data.Set (Set) +import qualified Data.Set as Set + import Data.Sequence as Seq (fromList, null, singleton) import Data.Sequence (ViewL(..), viewl) @@ -143,6 +148,7 @@ We don't export all constructors and instead encourage the use of 'text'. -} data Line = Word Text | HSpace Integer + | Markup (Set MarkupMode) Line | JuxtaPos (Seq Line) deriving (Generic, NFData, Show, CoArbitrary, FromJSON, ToJSON) @@ -215,6 +221,7 @@ cotext (Line x) = cotext' x where cotext' (Word x) = x cotext' (HSpace n) = TL.pack . genericReplicate n $ ' ' + cotext' (Markup _ l) = cotext' l cotext' (JuxtaPos xs) = mconcat . map cotext' . toList $ xs prop_text :: Text -> Bool @@ -231,6 +238,14 @@ prop_text x = (cotext . either id Line . text $ x') == x' | otherwise = c keep = [' ', '\n'] :: [Char] +data MarkupMode = Bold + | Underline + | DoubleHeight + | DoubleWidth + deriving (Generic, NFData, Show, Arbitrary, CoArbitrary, FromJSON, ToJSON + , Eq, Ord, Enum + ) + -- | We don't test 'Raw' 'Chunk's instance Arbitrary Chunk where shrink = genericShrink diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal index 28680fb..d4ecda6 100644 --- a/spec/thermoprint-spec.cabal +++ b/spec/thermoprint-spec.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-spec -version: 4.0.0 +version: 5.0.0 synopsis: A specification of the API and the payload datatypes and associated utilities -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html diff --git a/spec/thermoprint-spec.nix b/spec/thermoprint-spec.nix index 3480782..1a1611c 100644 --- a/spec/thermoprint-spec.nix +++ b/spec/thermoprint-spec.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "thermoprint-spec"; - version = "4.0.0"; + version = "5.0.0"; src = ./.; libraryHaskellDepends = [ aeson base base64-bytestring bytestring Cabal cabal-test-quickcheck diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs index dd5edb0..1770b6d 100644 --- a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs +++ b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} @@ -13,6 +14,9 @@ module Thermoprint.Printout.BBCode import Data.Text (Text) import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text.Lazy as TL (fromStrict) @@ -31,6 +35,7 @@ import Data.Bifunctor (bimap, first) import Control.Monad (join) import Data.List (groupBy) +import Data.Maybe (mapMaybe) import Text.BBCode (DomForest, DomTree(..), TreeError(..)) import qualified Text.BBCode as Raw (bbcode, BBCodeError(..)) @@ -140,9 +145,23 @@ parse BlockCtx = fmap mconcat . mapM mergeResult' . groupBy sameCtx . map parseD parse ctx = mergeResult ctx . map parseDom asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block -asBlock "VSpace" _ = Right . VSpace . lookupAttr "height" True 1 -asBlock t _ = const $ Left . UnmappedBlockElement . CI.original $ t +asBlock "VSpace" _ attrs = Right . VSpace $ lookupAttr "height" True 1 attrs +asBlock t _ _ = Left . UnmappedBlockElement . CI.original $ t asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line -asLine "HSpace" _ = Right . HSpace . lookupAttr "width" True 1 -asLine t _ = const $ Left . UnmappedLineElement . CI.original $ t +asLine "HSpace" _ attrs = Right . HSpace $ lookupAttr "width" True 1 attrs +asLine c t attrs + | (Just m) <- lookup c $ map (\(c, _, m) -> (CI.mk [c], m)) mTable + = Markup [m] <$> parse LineCtx t + | (Just m) <- lookup c $ map (\(_, a, m) -> (a, m)) mTable + = Markup [m] <$> parse LineCtx t + | "markup" <- c + , ms <- Set.fromList $ mapMaybe (\(_, a, m) -> m <$ Map.lookup a attrs) mTable + = Markup ms <$> parse LineCtx t + where + mTable = [ ('b', "bold", Bold) + , ('u', "underline", Underline) + , ('h', "doubleHeight", DoubleHeight) + , ('w', "doubleWidth", DoubleWidth) + ] +asLine t _ _ = Left . UnmappedLineElement . CI.original $ t diff --git a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs index 7909360..2f70ddc 100644 --- a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs +++ b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs @@ -64,4 +64,6 @@ examples = [ ("Hello World!" , Right [Line ("Par1"), Line ("Par2"), Line (JuxtaPos ["Par3", HSpace 1, "Word2"])]) , ("Par1 [hspace=3/]\n\n[vspace=2/]Par2\n\nPar3 Word2" , Right [Line (JuxtaPos ["Par1", HSpace 4]), NewlSep [VSpace 2, Line ("Par2")], Line (JuxtaPos ["Par3", HSpace 1, "Word2"])]) + , ("[b]B [u]BM[/u][/b] [markup bold=1 underline=1]BM[/markup]" + , Right [Line (JuxtaPos [Markup [Bold] (JuxtaPos ["B",HSpace 1,Markup [Underline] "BM"]),HSpace 1,Markup [Bold,Underline] "BM"])]) ] diff --git a/tp-bbcode/thermoprint-bbcode.cabal b/tp-bbcode/thermoprint-bbcode.cabal index 29855e2..b476753 100644 --- a/tp-bbcode/thermoprint-bbcode.cabal +++ b/tp-bbcode/thermoprint-bbcode.cabal @@ -24,7 +24,7 @@ library , OverloadedLists -- other-extensions: build-depends: base >=4.8.1 && <5 - , thermoprint-spec ==4.0.* + , thermoprint-spec ==5.0.* , bbcode >=3.1.1 && <4 , containers -any , text -any @@ -44,7 +44,7 @@ Test-Suite tests , OverloadedLists build-depends: base >=4.8.1 && <5 , thermoprint-bbcode -any - , thermoprint-spec ==4.0.* + , thermoprint-spec ==5.0.* , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <4 -- cgit v1.2.3