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 --- tp-bbcode/src/Thermoprint/Printout/BBCode.hs | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) (limited to 'tp-bbcode/src/Thermoprint') 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 -- cgit v1.2.3