Add support for ESC/POS text decoration

12 files changed, 150 insertions, 18 deletions

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