@@ -1,84 +1,44 @@
11module Text.XML.DOM.Parser.Content
2− ( -- * Content readers
3− readBool
4− , readChar
5− -- ** Reader constructors
6− , maybeReadContent
7− , readContent
2+ (
3+ -- * Parsing element's content
4+ parseContent
85 -- * Getting current element's properties
96 , getCurrentName
107 , getCurrentContent
11− , getCurrentAttributes
12− , getCurrentAttribute
138 , checkCurrentName
14− -- * Parsing element's content
15− , parseContent
16− -- * Parsing attributes
17− , parseAttribute
18− , parseAttributeMaybe
9+ -- * Internal
10+ , maybeReadContent
11+ , readContent
12+ , readBool
13+ , readChar
1914 ) where
2015
2116import Control.Lens
2217import Control.Monad
2318import Control.Monad.Except
2419import Data.List as L
25−import Data.Map.Strict as M
2620import Data.Monoid
2721import Data.Text as T
2822import Data.Typeable
23+import Prelude as P
2924import Text.Read
3025import Text.XML.DOM.Parser.Types
3126import Text.XML.Lens
3227
3328
34−-- | @since 1.0.0
35−readBool :: Text -> Either Text Bool
36−readBool t =
37− let
38− lowt = T.toLower $ T.strip t
39− tvals = ["y", "yes", "t", "true", "1"]
40− fvals = ["n", "no", "f", "false", "0"]
41− in if
42− | lowt `elem` tvals -> Right True
43− | lowt `elem` fvals -> Right False
44− | otherwise ->
45− Left $ "Could not read " <> t <> " as Bool"
46−
47−-- | Expects text to be single character
48−--
49−-- @since 1.0.0
50−readChar :: Text -> Either Text Char
51−readChar t = case T.unpack $ T.strip t of
52− [c] -> Right c
53− _ -> Left "Should have exactly one non-blank character"
54−
55−-- | If reader returns 'Nothing' then resulting function returns 'Left
56−-- "error message"'. 'Typeable' is used for generating usefull error
57−-- message.
58−--
59−-- @since 1.0.0
60−maybeReadContent
61− :: forall a
62− . (Typeable a)
63− => (Text -> Maybe a)
64− -- ^ Content or attribute reader
65− -> Text
66− -- ^ Content or attribute value
67− -> Either Text a
68−maybeReadContent f t = maybe (Left msg) Right $ f t
69− where
70− msg = "Not readable " <> n <> ": " <> t
71− n = T.pack $ show $ typeRep (Proxy :: Proxy a)
72−
29+-- | Parses content inside current tag. It expects current element set
30+-- consists of exactly ONE element.
31+parseContent
32+ :: (Monad m)
33+ => (Text -> Either Text a)
34+ -- ^ Content parser, return error msg if value is not parsed
35+ -> DomParserT Identity m a
36+parseContent parse = getCurrentContent >>= \case
37+ Nothing -> throwParserError PEContentNotFound
38+ Just c -> case parse c of
39+ Left e -> throwParserError $ PEContentWrongFormat e
40+ Right a -> return a
7341
74−-- | Tries to read given text to value using 'Read'. Useful to use
75−-- with 'parseContent' and 'parseAttribute'. Content is stripped
76−-- before reading.
77−readContent
78− :: (Read a, Typeable a)
79− => Text
80− -> Either Text a
81−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
8242
8343-- | Returns name of current element.
8444--
@@ -118,67 +78,52 @@ getCurrentContent = do
11878 | L.null conts -> Nothing
11979 | otherwise -> Just $ mconcat conts
12080
121−-- | Parses content inside current tag. It expects current element set
122−-- consists of exactly ONE element.
123−parseContent
124− :: (Monad m)
125− => (Text -> Either Text a)
126− -- ^ Content parser, return error msg if value is not parsed
127− -> DomParserT Identity m a
128−parseContent parse = getCurrentContent >>= \case
129− Nothing -> throwParserError PEContentNotFound
130− Just c -> case parse c of
131− Left e -> throwParserError $ PEWrongFormat e
132− Right a -> return a
133−
134−-- | Retuns map of attributes of current element
81+-- | If reader returns 'Nothing' then resulting function returns 'Left
82+-- "error message"'. 'Typeable' is used for generating usefull error
83+-- message.
13584--
13685-- @since 1.0.0
137−getCurrentAttributes
138− :: (Monad m)
139− => DomParserT Identity m (M.Map Name Text)
140−getCurrentAttributes = view $ pdElements . to runIdentity . attrs
86+maybeReadContent
87+ :: forall a
88+ . (Typeable a)
89+ => (Text -> Maybe a)
90+ -- ^ Content or attribute reader
91+ -> Text
92+ -- ^ Content or attribute value
93+ -> Either Text a
94+maybeReadContent f t = maybe (Left msg) Right $ f t
95+ where
96+ msg = "Not readable " <> n <> ": " <> t
97+ n = T.pack $ P.show $ typeRep (Proxy :: Proxy a)
14198
142−-- | Returns element with given name or 'Nothing'
143−--
144−-- @since 1.0.0
145−getCurrentAttribute
146− :: (Monad m)
147− => NameMatcher
148− -> DomParserT Identity m (Maybe Text)
149−getCurrentAttribute attrName
150− = preview $ pdElements . to runIdentity . attrs . to M.toList
151− . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2
15299
153−-- | Parses attribute with given name, throws error if attribute is not found.
154−--
155−-- @since 1.0.0
156−parseAttribute
157− :: (Monad m)
158− => NameMatcher
159− -- ^ Attribute name
160− -> (Text -> Either Text a)
161− -- ^ Attribute content parser
162− -> DomParserT Identity m a
163−parseAttribute attrName parser =
164− parseAttributeMaybe attrName parser >>= \case
165− Nothing -> throwParserError $ PEAttributeNotFound attrName
166− Just a -> return a
100+-- | Tries to read given text to value using 'Read'. Useful to use
101+-- with 'parseContent' and 'parseAttribute'. Content is stripped
102+-- before reading.
103+readContent
104+ :: (Read a, Typeable a)
105+ => Text
106+ -> Either Text a
107+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
167108
168−-- | Parses attribute with given name. Returns Nothing if attribute is
169−-- not found.
109+
110+-- | @since 1.0.0
111+readBool :: Text -> Either Text Bool
112+readBool t =
113+ let
114+ lowt = T.toLower $ T.strip t
115+ tvals = ["y", "yes", "t", "true", "1"]
116+ fvals = ["n", "no", "f", "false", "0"]
117+ in if
118+ | lowt `L.elem` tvals -> Right True
119+ | lowt `L.elem` fvals -> Right False
120+ | otherwise ->
121+ Left $ "Could not read " <> t <> " as Bool"
122+
123+-- | Expects text to be single character
170124--
171125-- @since 1.0.0
172−parseAttributeMaybe
173− :: (Monad m)
174− => NameMatcher
175− -- ^ Attribute name
176− -> (Text -> Either Text a)
177− -- ^ Attribute content parser
178− -> DomParserT Identity m (Maybe a)
179−parseAttributeMaybe attrName parser =
180− getCurrentAttribute attrName >>= \case
181− Nothing -> return Nothing
182− Just aval -> case parser aval of
183− Left err -> throwParserError $ PEAttributeWrongFormat attrName err
184− Right a -> return $ Just a
126+readChar :: Text -> Either Text Char
127+readChar t = case T.unpack $ T.strip t of
128+ [c] -> Right c
129+ _ -> Left "Should have exactly one non-blank character"