From 683bbbf4c3935851610969fd565fbe97598d294c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 18 Jan 2016 05:56:02 +0000
Subject: Better attribute parsing

---
 spec/src/Thermoprint/Printout/BBCode.hs           | 14 +++-------
 spec/src/Thermoprint/Printout/BBCode/Attribute.hs | 33 +++++++++++++++++++++++
 spec/thermoprint-spec.cabal                       |  2 +-
 3 files changed, 37 insertions(+), 12 deletions(-)
 create mode 100644 spec/src/Thermoprint/Printout/BBCode/Attribute.hs

diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs
index 1ca1e01..7f09623 100644
--- a/spec/src/Thermoprint/Printout/BBCode.hs
+++ b/spec/src/Thermoprint/Printout/BBCode.hs
@@ -11,14 +11,11 @@ module Thermoprint.Printout.BBCode
        ) where
 
 import Data.Text (Text)
-import qualified Data.Text as T (unpack)
+import Data.Map (Map)
 
 import qualified Data.Text.Lazy as Lazy (Text)
 import qualified Data.Text.Lazy as TL (fromStrict)
 
-import Data.Map (Map)
-import qualified Data.Map as Map (lookup)
-
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq (fromList, singleton)
 
@@ -32,15 +29,13 @@ import Data.Typeable (Typeable)
 import Data.Bifunctor (bimap, first)
 import Control.Monad (join)
 
-import Text.Read (readMaybe)
-
-import Data.Maybe (fromMaybe)
-
 import Text.BBCode (DomForest, DomTree(..), TreeError(..))
 import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
 
 import Thermoprint.Printout
 
+import Thermoprint.Printout.BBCode.Attribute
+
 -- ^ We replicate 'Raw.BBCodeError' but add a new failure mode documenting incompatibly of the parsed syntax tree with our document format
 data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens
                  | TreeError TreeError -- ^ Error while parsing stream of tokens to syntax tree
@@ -123,9 +118,6 @@ parse :: Monoid a => Context a -> [DomTree] -> Either SemanticError a
 -- @parse ctx = 'mergeResult' ctx . map 'parseDom'@
 parse ctx = mergeResult ctx . map parseDom
 
-lookupAttr :: Read a => CI Text -> a -> Map (CI Text) Text -> a
-lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= (readMaybe . T.unpack)
-
 asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block
 asBlock "VSpace" [] = Right . VSpace . lookupAttr "height" 1
 asBlock t        _  = const $ Left . UnmappedBlockElement . CI.original $ t
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
diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal
index eb9d6d3..ad861aa 100644
--- a/spec/thermoprint-spec.cabal
+++ b/spec/thermoprint-spec.cabal
@@ -22,7 +22,7 @@ library
                      , Thermoprint.Printout.BBCode
                      , Thermoprint.Identifiers
                      , Thermoprint.API
-  -- other-modules:       
+  other-modules:       Thermoprint.Printout.BBCode.Attribute
   -- other-extensions:    
   extensions:          DeriveGeneric
                      , DeriveAnyClass
-- 
cgit v1.2.3