Add support for ESC/POS text decoration

3 files changed, 27 insertions, 6 deletions

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