diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-18 12:09:36 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-18 12:09:36 +0000 |
commit | 57c56564d15cd5c83a4f1d1bab5490e6b75e8656 (patch) | |
tree | 55ea741665155b46b9e599b149dee3323fe479c0 /tp-bbcode/src/Thermoprint/Printout/BBCode | |
parent | 9435083465a487553b21c599c1340aa5e5ed8a1c (diff) | |
download | thermoprint-57c56564d15cd5c83a4f1d1bab5490e6b75e8656.tar thermoprint-57c56564d15cd5c83a4f1d1bab5490e6b75e8656.tar.gz thermoprint-57c56564d15cd5c83a4f1d1bab5490e6b75e8656.tar.bz2 thermoprint-57c56564d15cd5c83a4f1d1bab5490e6b75e8656.tar.xz thermoprint-57c56564d15cd5c83a4f1d1bab5490e6b75e8656.zip |
Moved Printout.BBCode to own module
Diffstat (limited to 'tp-bbcode/src/Thermoprint/Printout/BBCode')
-rw-r--r-- | tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs | 39 |
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 @@ | |||
1 | {-# LANGUAGE DefaultSignatures #-} | ||
2 | |||
3 | -- | Parsing attributes | ||
4 | module Thermoprint.Printout.BBCode.Attribute | ||
5 | ( Attribute(..) | ||
6 | , lookupAttr | ||
7 | ) where | ||
8 | |||
9 | import Data.Text (Text) | ||
10 | import qualified Data.Text as T (unpack, empty) | ||
11 | |||
12 | import Data.Map (Map) | ||
13 | import qualified Data.Map as Map (lookup) | ||
14 | |||
15 | import Data.CaseInsensitive (CI) | ||
16 | import qualified Data.CaseInsensitive as CI | ||
17 | |||
18 | import Text.Read (readMaybe) | ||
19 | import Data.Maybe (fromMaybe) | ||
20 | |||
21 | import Control.Applicative (Alternative(..)) | ||
22 | |||
23 | -- | We build our own version of 'Read' so we can override the presentation used | ||
24 | -- | ||
25 | -- We provide a default implementation for 'Read a => Attribute a' | ||
26 | class Attribute a where | ||
27 | attrRead :: Text -> Maybe a | ||
28 | default attrRead :: Read a => Text -> Maybe a | ||
29 | attrRead = readMaybe . T.unpack | ||
30 | |||
31 | instance Attribute Integer | ||
32 | |||
33 | lookupAttr :: Attribute a => CI Text -> Bool -> a -> Map (CI Text) Text -> a | ||
34 | -- ^ Extract an attribute by name -- the 'Bool' attribute specifies whether we additionally accept the empty string as key | ||
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 | ||