From f0ad3abb87d540c75a397a722ca5310d6d16cec9 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 18 Jan 2016 11:36:09 +0000
Subject: Made attributes more lenient yet

---
 spec/src/Thermoprint/Printout/BBCode.hs           |  4 ++--
 spec/src/Thermoprint/Printout/BBCode/Attribute.hs | 14 ++++++++++----
 2 files changed, 12 insertions(+), 6 deletions(-)

(limited to 'spec/src/Thermoprint/Printout')

diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs
index 33101e5..8825732 100644
--- a/spec/src/Thermoprint/Printout/BBCode.hs
+++ b/spec/src/Thermoprint/Printout/BBCode.hs
@@ -119,9 +119,9 @@ parse :: Monoid a => Context a -> [DomTree] -> Either SemanticError a
 parse ctx = mergeResult ctx . map parseDom
 
 asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block
-asBlock "VSpace" _  = Right . VSpace . lookupAttr "height" 1
+asBlock "VSpace" _  = Right . VSpace . lookupAttr "height" True 1
 asBlock t        _  = const $ Left . UnmappedBlockElement . CI.original $ t
 
 asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line
-asLine "HSpace"  _  = Right . HSpace . lookupAttr "width" 1
+asLine "HSpace"  _  = Right . HSpace . lookupAttr "width" True 1
 asLine t         _  = const $ Left . UnmappedLineElement . CI.original $ t
diff --git a/spec/src/Thermoprint/Printout/BBCode/Attribute.hs b/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
index 60815c8..538cca2 100644
--- a/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
+++ b/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
@@ -7,7 +7,7 @@ module Thermoprint.Printout.BBCode.Attribute
        ) where
 
 import Data.Text (Text)
-import qualified Data.Text as T (unpack)
+import qualified Data.Text as T (unpack, empty)
 
 import Data.Map (Map)
 import qualified Data.Map as Map (lookup)
@@ -18,6 +18,8 @@ import qualified Data.CaseInsensitive as CI
 import Text.Read (readMaybe)
 import Data.Maybe (fromMaybe)
 
+import Control.Applicative (Alternative(..))
+
 -- | We build our own version of 'Read' so we can override the presentation used
 --
 -- We provide a default implementation for 'Read a => Attribute a'
@@ -28,6 +30,10 @@ class Attribute a where
 
 instance Attribute Integer
 
-lookupAttr :: Attribute a => CI Text -> a -> Map (CI Text) Text -> a
--- ^ Extract an attribute by name 
-lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= attrRead
+lookupAttr :: Attribute a => CI Text -> Bool -> a -> Map (CI Text) Text -> a
+-- ^ Extract an attribute by name -- the 'Bool' attribute specifies whether we additionally accept the empty string as key
+lookupAttr t emptyOk def attrs = fromMaybe def $ (emptyOk' $ Map.lookup t attrs) >>= attrRead
+  where
+    emptyOk'
+      | emptyOk   = (<|> Map.lookup (CI.mk T.empty) attrs)
+      | otherwise = id
-- 
cgit v1.2.3