Merge branch 'feat-markup'

1 files changed, 23 insertions, 4 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