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 ++++++++++++++++++++++++--
 spec/thermoprint-spec.cabal             |  1 +
 spec/thermoprint-spec.nix               |  9 +++++----
 3 files changed, 30 insertions(+), 6 deletions(-)

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)
diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal
index 40978c3..eb9d6d3 100644
--- a/spec/thermoprint-spec.cabal
+++ b/spec/thermoprint-spec.cabal
@@ -41,6 +41,7 @@ library
                      , aeson >=0.9.0 && <1
                      , base64-bytestring >=1.0.0 && <2
                      , encoding >=0.8 && <1
+                     , case-insensitive >=1.2 && <2
   -- hs-source-dirs:      
   default-language:    Haskell2010
 
diff --git a/spec/thermoprint-spec.nix b/spec/thermoprint-spec.nix
index 368f3a9..d20a8e6 100644
--- a/spec/thermoprint-spec.nix
+++ b/spec/thermoprint-spec.nix
@@ -1,6 +1,7 @@
 { mkDerivation, aeson, base, base64-bytestring, bbcode, bytestring
-, Cabal, cabal-test-quickcheck, containers, deepseq, encoding
-, hspec, QuickCheck, quickcheck-instances, servant, stdenv, text
+, Cabal, cabal-test-quickcheck, case-insensitive, containers
+, deepseq, encoding, hspec, QuickCheck, quickcheck-instances
+, servant, stdenv, text
 }:
 mkDerivation {
   pname = "thermoprint-spec";
@@ -8,8 +9,8 @@ mkDerivation {
   src = ./.;
   libraryHaskellDepends = [
     aeson base base64-bytestring bbcode bytestring Cabal
-    cabal-test-quickcheck containers deepseq encoding QuickCheck
-    quickcheck-instances servant text
+    cabal-test-quickcheck case-insensitive containers deepseq encoding
+    QuickCheck quickcheck-instances servant text
   ];
   testHaskellDepends = [
     aeson base hspec QuickCheck quickcheck-instances
-- 
cgit v1.2.3