Better attribute parsing

1 files changed, 33 insertions, 0 deletions

diff --git a/spec/src/Thermoprint/Printout/BBCode/Attribute.hs b/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
new file mode 100644
index 0000000..60815c8
--- /dev/null
+++ b/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+-- | Parsing attributes
+module Thermoprint.Printout.BBCode.Attribute
+       ( Attribute(..)
+       , lookupAttr
+       ) where
+
+import Data.Text (Text)
+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 Text.Read (readMaybe)
+import Data.Maybe (fromMaybe)
+
+-- | 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 -> a -> Map (CI Text) Text -> a
+-- ^ Extract an attribute by name 
+lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= attrRead