From a39c0ae45bf3485fbcb080576f8089ead05a94af Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 15 Jan 2016 02:53:12 +0000
Subject: More framework for DomTree -> Printout

---
 spec/src/Thermoprint/Printout/BBCode.hs | 26 ++++++++++++++++++++++++--
 1 file changed, 24 insertions(+), 2 deletions(-)

(limited to 'spec/src')

diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs
index ca69efc..f80f780 100644
--- a/spec/src/Thermoprint/Printout/BBCode.hs
+++ b/spec/src/Thermoprint/Printout/BBCode.hs
@@ -9,7 +9,13 @@ module Thermoprint.Printout.BBCode
        ) where
 
 import Data.Text (Text)
-import qualified Data.Text as T ()
+import qualified Data.Text as T (unpack)
+
+import Data.Map (Map)
+import qualified Data.Map as Map (lookup)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 
 import GHC.Generics (Generic)
 import Control.Exception (Exception)
@@ -18,6 +24,10 @@ import Data.Typeable (Typeable)
 import Data.Bifunctor (bimap, first)
 import Control.Monad (join)
 
+import Text.Read (readMaybe)
+
+import Data.Maybe (fromMaybe)
+
 import Text.BBCode (DomTree(..), TreeError(..))
 import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
 
@@ -31,7 +41,8 @@ data BBCodeError = LexerError String -- ^ Error while parsing input to stream of
 
 instance Exception BBCodeError
 
-data SemanticError = Placeholder
+data SemanticError = BlockTagInLineContext Text
+                   | UnmappedTag Text
   deriving (Show, Eq, Generic, Typeable)
 
 instance Exception SemanticError
@@ -45,3 +56,14 @@ morph' (Raw.TreeError x) = TreeError x
 
 morph :: [DomTree] -> Either SemanticError Printout
 morph = undefined
+
+asBlock :: CI Text -> Map (CI Text) Text -> Either SemanticError Block
+asBlock "VSpace" = Right . VSpace . lookupAttr "size" 1
+asBlock t        = Left . const (UnmappedTag . CI.original $ t)
+
+asLine :: CI Text -> Map (CI Text) Text -> Either SemanticError Line
+asLine "HSpace"  = Right . HSpace . lookupAttr "size" 1
+asLine t         = Left . const (UnmappedTag . CI.original $ t)
+
+lookupAttr :: Read a => CI Text -> a -> Map (CI Text) Text -> a
+lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= (readMaybe . T.unpack)
-- 
cgit v1.2.3