Moved Printout.BBCode to own module

1 files changed, 39 insertions, 0 deletions

diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs
new file mode 100644
index 0000000..538cca2
--- /dev/null
+++ b/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+-- | Parsing attributes
+module Thermoprint.Printout.BBCode.Attribute
+       ( Attribute(..)
+       , lookupAttr
+       ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unpack, empty)
+
+import Data.Map (Map)
+import qualified Data.Map as Map (lookup)
+
+import Data.CaseInsensitive (CI)
+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'
+class Attribute a where
+  attrRead :: Text -> Maybe a
+  default attrRead :: Read a => Text -> Maybe a
+  attrRead = readMaybe . T.unpack
+
+instance Attribute Integer
+
+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