tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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