@@ -1,44 +1,84 @@
11module Text.XML.DOM.Parser.Content
2− (
3− -- * Parsing element's content
4− parseContent
2+ ( -- * Content readers
3+ readBool
4+ , readChar
5+ -- ** Reader constructors
6+ , maybeReadContent
7+ , readContent
58 -- * Getting current element's properties
69 , getCurrentName
710 , getCurrentContent
11+ , getCurrentAttributes
12+ , getCurrentAttribute
813 , checkCurrentName
9− -- * Internal
10− , maybeReadContent
11− , readContent
12− , readBool
13− , readChar
14+ -- * Parsing element's content
15+ , parseContent
16+ -- * Parsing attributes
17+ , parseAttribute
18+ , parseAttributeMaybe
1419 ) where
1520
1621import Control.Lens
1722import Control.Monad
1823import Control.Monad.Except
1924import Data.List as L
25+import Data.Map.Strict as M
2026import Data.Monoid
2127import Data.Text as T
2228import Data.Typeable
23−import Prelude as P
2429import Text.Read
2530import Text.XML.DOM.Parser.Types
2631import Text.XML.Lens
2732
2833
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
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"
4146
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+
73+
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
4282
4383-- | Returns name of current element.
4484--
@@ -78,52 +118,67 @@ getCurrentContent = do
78118 | L.null conts -> Nothing
79119 | otherwise -> Just $ mconcat conts
80120
81−-- | If reader returns 'Nothing' then resulting function returns 'Left
82−-- "error message"'. 'Typeable' is used for generating usefull error
83−-- message.
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
84135--
85136-- @since 1.0.0
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)
98−
99−
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
137+getCurrentAttributes
138+ :: (Monad m)
139+ => DomParserT Identity m (M.Map Name Text)
140+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
108141
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
109152
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"
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
122167
123−-- | Expects text to be single character
168+-- | Parses attribute with given name. Returns Nothing if attribute is
169+-- not found.
124170--
125171-- @since 1.0.0
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"
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