diff options
| -rw-r--r-- | spec/src/Thermoprint/Printout/BBCode.hs | 4 | ||||
| -rw-r--r-- | spec/src/Thermoprint/Printout/BBCode/Attribute.hs | 14 |
2 files changed, 12 insertions, 6 deletions
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 | |||
| 119 | parse ctx = mergeResult ctx . map parseDom | 119 | parse ctx = mergeResult ctx . map parseDom |
| 120 | 120 | ||
| 121 | asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block | 121 | asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block |
| 122 | asBlock "VSpace" _ = Right . VSpace . lookupAttr "height" 1 | 122 | asBlock "VSpace" _ = Right . VSpace . lookupAttr "height" True 1 |
| 123 | asBlock t _ = const $ Left . UnmappedBlockElement . CI.original $ t | 123 | asBlock t _ = const $ Left . UnmappedBlockElement . CI.original $ t |
| 124 | 124 | ||
| 125 | asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line | 125 | asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line |
| 126 | asLine "HSpace" _ = Right . HSpace . lookupAttr "width" 1 | 126 | asLine "HSpace" _ = Right . HSpace . lookupAttr "width" True 1 |
| 127 | asLine t _ = const $ Left . UnmappedLineElement . CI.original $ t | 127 | 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 | |||
| 7 | ) where | 7 | ) where |
| 8 | 8 | ||
| 9 | import Data.Text (Text) | 9 | import Data.Text (Text) |
| 10 | import qualified Data.Text as T (unpack) | 10 | import qualified Data.Text as T (unpack, empty) |
| 11 | 11 | ||
| 12 | import Data.Map (Map) | 12 | import Data.Map (Map) |
| 13 | import qualified Data.Map as Map (lookup) | 13 | import qualified Data.Map as Map (lookup) |
| @@ -18,6 +18,8 @@ import qualified Data.CaseInsensitive as CI | |||
| 18 | import Text.Read (readMaybe) | 18 | import Text.Read (readMaybe) |
| 19 | import Data.Maybe (fromMaybe) | 19 | import Data.Maybe (fromMaybe) |
| 20 | 20 | ||
| 21 | import Control.Applicative (Alternative(..)) | ||
| 22 | |||
| 21 | -- | We build our own version of 'Read' so we can override the presentation used | 23 | -- | We build our own version of 'Read' so we can override the presentation used |
| 22 | -- | 24 | -- |
| 23 | -- We provide a default implementation for 'Read a => Attribute a' | 25 | -- We provide a default implementation for 'Read a => Attribute a' |
| @@ -28,6 +30,10 @@ class Attribute a where | |||
| 28 | 30 | ||
| 29 | instance Attribute Integer | 31 | instance Attribute Integer |
| 30 | 32 | ||
| 31 | lookupAttr :: Attribute a => CI Text -> a -> Map (CI Text) Text -> a | 33 | lookupAttr :: Attribute a => CI Text -> Bool -> a -> Map (CI Text) Text -> a |
| 32 | -- ^ Extract an attribute by name | 34 | -- ^ Extract an attribute by name -- the 'Bool' attribute specifies whether we additionally accept the empty string as key |
| 33 | lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= attrRead | 35 | lookupAttr t emptyOk def attrs = fromMaybe def $ (emptyOk' $ Map.lookup t attrs) >>= attrRead |
| 36 | where | ||
| 37 | emptyOk' | ||
| 38 | | emptyOk = (<|> Map.lookup (CI.mk T.empty) attrs) | ||
| 39 | | otherwise = id | ||
