@@ -2,7 +2,7 @@ module Text.XML.DOM.Parser.Combinators
22 ( -- * Generic combinators to traverse descendants
33 traverseElems
44 , inFilteredTrav
5− -- * Using 'Buildable'
5+ -- * Using 'DomTraversable'
66 , inElemTrav
77 , inElem
88 , inElemAll
@@ -15,30 +15,46 @@ module Text.XML.DOM.Parser.Combinators
1515 , ignoreElem
1616 , ignoreEmpty
1717 , ignoreBlank
18+ -- * Getting current element's properties
19+ , getCurrentName
20+ , getCurrentContent
21+ , getCurrentAttributes
22+ , getCurrentAttribute
23+ -- * Current element's checks
24+ , checkCurrentName
25+ -- * Parsing element's content
26+ , parseContent
27+ , readContent
28+ , maybeReadContent
29+ -- * Parsing attributes
30+ , parseAttribute
1831 ) where
1932
20−import Control.Lens
21−import Control.Monad.Reader
22−import Data.Foldable as F
23−import Data.List as L
24−import Data.List.NonEmpty (NonEmpty(..))
25−import Data.Text as T
26−import Data.Traversable
27−import Text.XML
28−import Text.XML.DOM.Parser.Buildable
29−import Text.XML.DOM.Parser.Types
30−import Text.XML.Lens
33+import Control.Lens
34+import Control.Monad.Except
35+import Control.Monad.Reader
36+import Data.List.NonEmpty (NonEmpty(..))
37+import qualified Data.Map.Strict as M
38+import Data.Monoid
39+import Data.Text (Text)
40+import qualified Data.Text as T
41+import Data.Traversable
42+import Data.Typeable
43+import Text.Read
44+import Text.XML
45+import Text.XML.DOM.Parser.Types
46+import Text.XML.Lens
3147
3248
33−-- | Generic function to traverse arbitrary inner elements.
49+-- | Generic function to traverse arbitrary inner cursors.
3450traverseElems
3551 :: (Monad m, Foldable g, Traversable f)
3652 => ([Element] -> DomParserT g m (f (DomPath, Element)))
3753 -- ^ Takes list of current elements and returns container with
38− -- pairs of subpath (relatively to current elements) and element
54+ -- pairs of subpath (relatively to current element) and element
3955 -- to run parser in
4056 -> DomParserT Identity m a
41− -- ^ Parser to run for each element found in traversable 'f'
57+ -- ^ Parser will be runned for each element found in traversable
4258 -> DomParserT g m (f a)
4359traverseElems trav parser = do
4460 pd <- ask
@@ -48,73 +64,68 @@ traverseElems trav parser = do
4864 newpd = ParserData
4965 { _pdElements = Identity e
5066 , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
67+ -- type of reader has been changed, local won't work here
68+ magnify (to $ const newpd) parser
5269
53−-- | Traverses elements located in same path using filtering function
70+-- | Takes function filtering
5471inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
72+ :: (Monad m, Foldable g, DomTraversable f)
5673 => ([Element] -> (DomPath, [Element]))
57− -- ^ Takes list of current elements and returns some descendants
58− -- subset and path this descendants located at. Path is should be
59− -- same for all descendants and required for error message
74+ -- ^ Function returning some filtered elements with path suffixes which will
75+ -- be appended to parser's state
6076 -> DomParserT Identity m a
6177 -> DomParserT g m (f a)
6278inFilteredTrav deeper = traverseElems trav
6379 where
6480 trav e = do
6581 let (path, elems) = deeper e
66− case build elems of
82+ case buildDomTraversable elems of
6783 Nothing -> throwParserError $ PENotFound . (<> path)
6884 Just tr -> return $ fmap (path,) tr
6985
70−-- | Runs parser arbitrary times, depending on 'Buildable' instance of
71−-- 'f'. For example if 'f' becomes 'NonEmpty' then 'inElemTrav' finds
72−-- @one or more@ elements matched by given 'ElemMatcher' and run
73−-- parser in each found element, then returns @NonEmpty a@ of results.
7486inElemTrav
75− :: (Monad m, Foldable g, Buildable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
87+ :: (Monad m, Foldable g, DomTraversable f)
88+ => Text
7789 -> DomParserT Identity m a
7890 -> DomParserT g m (f a)
7991inElemTrav n = inFilteredTrav deeper
8092 where
81− elemsFold = folded . nodes . folded . _Element . elMatch n
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
93+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
8394
84−-- | Runs parser inside first children element matched by macher
95+-- | Runs parser inside first children element with given name
8596inElem
8697 :: (Monad m, Foldable g)
87− => ElemMatcher
98+ => Text
8899 -> DomParserT Identity m a
89100 -> DomParserT g m a
90101inElem n = fmap runIdentity . inElemTrav n
91102
92103inElemAll
93104 :: (Monad m, Foldable g)
94− => ElemMatcher
105+ => Text
95106 -> DomParserT Identity m a
96107 -> DomParserT g m [a]
97108inElemAll = inElemTrav
98109
99110inElemMay
100111 :: (Monad m, Foldable g)
101− => ElemMatcher
112+ => Text
102113 -> DomParserT Identity m a
103114 -> DomParserT g m (Maybe a)
104115inElemMay = inElemTrav
105116
106117inElemNe
107118 :: (Monad m, Foldable g)
108− => ElemMatcher
119+ => Text
109120 -> DomParserT Identity m a
110121 -> DomParserT g m (NonEmpty a)
111122inElemNe = inElemTrav
112123
113124{- | Dive given parser's current tags set into the given path. The @divePath
114−["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant
125+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115126will not fail if occured tag "a" which does not contains tag "b". This
116127behaviour is desireable when you dont want to parse whole XML and just want
117−to pull tags located in some path. The other difference is in traversing inner
128+to pull tags in some path. The other difference is in traversing inner
118129elements. Consider this code
119130
120131@
@@ -132,31 +143,26 @@ which translates like: @a > b > c > fromDom@
132143As you can see, inElem always takes first element and runs inner parser in this
133144single element, unlike 'divePath' which runs inner parser @in all@ descendants
134145in given path.
135−
136−Note also that 'divePath' takes parser parameterized by @[]@ not by
137−'Identity'. This because when you dive using some path you will get a
138−list of found elements and all these elements will be @current@ for
139−parser.
140146-}
141147
142148divePath
143149 :: forall m g a
144150 . (Monad m, Foldable g)
145− => [ElemMatcher]
151+ => [Text]
146152 -> DomParserT [] m a
147153 -> DomParserT g m a
148154divePath path = magnify $ to modElems
149155 where
150156 modElems
151157 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
158+ . over pdPath (<> path)
153159 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
160+ diver = foldr (.) id $ map toDive path
161+ toDive n = nodes . folded . _Element . ell n
156162
157163diveElem
158164 :: (Monad m, Foldable g)
159− => ElemMatcher
165+ => Text
160166 -> DomParserT [] m a
161167 -> DomParserT g m a
162168diveElem p = divePath [p]
@@ -183,7 +189,7 @@ ignoreEmpty
183189 -> DomParserT Identity m (Maybe a)
184190ignoreEmpty = ignoreElem test
185191 where
186− test e = L.null $ e ^. nodes
192+ test e = null $ e ^. nodes
187193
188194-- | If all current elements contains blank content, or contains nothing at all
189195-- , then returns Nothing, else runs parser.
@@ -197,6 +203,114 @@ ignoreBlank = ignoreElem test
197203 let
198204 elems = e ^.. nodes . folded . _Element
199205 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
206+ in if | not $ null elems -> False
201207 | T.null $ T.strip cont -> True
202208 | otherwise -> False
209+
210+-- | Returns name of current element.
211+--
212+-- @since 1.0.0
213+getCurrentName :: (Monad m) => DomParserT Identity m Text
214+getCurrentName = view $ pdElements . to runIdentity . localName
215+
216+-- | If name of current tag differs from first argument throws 'PENotFound' with
217+-- tag name replaced in last path's segment. Useful for checking root
218+-- document's element name.
219+checkCurrentName
220+ :: (Monad m)
221+ => Text
222+ -> DomParserT Identity m ()
223+checkCurrentName n = do
224+ cn <- getCurrentName
225+ unless (cn == n) $ do
226+ p <- view pdPath
227+ let pinit = if null p then [] else init p
228+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
229+ return ()
230+
231+-- | Get current content. If current element contains no content or
232+-- have inner elements then Nothing returned
233+--
234+-- @since 1.0.0
235+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
236+getCurrentContent = do
237+ nds <- view $ pdElements . to runIdentity . nodes
238+ let
239+ els :: [Element]
240+ els = nds ^.. folded . _Element
241+ conts :: [Text]
242+ conts = nds ^.. folded . _Content
243+ return $ if
244+ | not $ null els -> Nothing
245+ | null conts -> Nothing
246+ | otherwise -> Just $ mconcat conts
247+
248+-- | Parses content inside current tag. It expects current element set
249+-- consists of exactly ONE element. If current element does not
250+-- contains content or have other elements as childs then throws error
251+parseContent
252+ :: (Monad m)
253+ => (Text -> Either Text a)
254+ -- ^ Content parser, return error msg if value is not parsed
255+ -> DomParserT Identity m a
256+parseContent parse = getCurrentContent >>= \case
257+ Nothing -> throwParserError PEContentNotFound
258+ Just c -> case parse c of
259+ Left e -> throwParserError $ PEWrongFormat e
260+ Right a -> return a
261+
262+-- | If reader returns 'Nothing' then resulting function returns 'Left
263+-- "error message"'
264+--
265+-- @since 1.0.0
266+maybeReadContent
267+ :: forall a
268+ . (Typeable a)
269+ => (Text -> Maybe a)
270+ -- ^ Content or attribute reader
271+ -> Text
272+ -- ^ Content or attribute value
273+ -> Either Text a
274+maybeReadContent f t = maybe (Left msg) Right $ f t
275+ where
276+ msg = "Not readable " <> n <> ": " <> t
277+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
278+
279+-- | Tries to read given text to value using 'Read'. Useful to use
280+-- with 'parseContent' and 'parseAttribute'
281+readContent
282+ :: (Read a, Typeable a)
283+ => Text
284+ -> Either Text a
285+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
286+
287+-- | Retuns map of attributes of current element
288+--
289+-- @since 1.0.0
290+getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
291+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
292+
293+-- | Returns element with given name or 'Nothing'
294+--
295+-- @since 1.0.0
296+getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
297+getCurrentAttribute attrName'
298+ = preview $ pdElements . to runIdentity . attr attrName
299+ where
300+ attrName = Name attrName' Nothing Nothing
301+
302+-- | Parses attribute with given name, throws error if attribute is not found.
303+--
304+-- @since 1.0.0
305+parseAttribute
306+ :: (Monad m)
307+ => Text
308+ -- ^ Attribute name
309+ -> (Text -> Either Text a)
310+ -- ^ Attribute content parser
311+ -> DomParserT Identity m a
312+parseAttribute attrName parser = getCurrentAttribute attrName >>= \case
313+ Nothing -> throwParserError $ PEAttributeNotFound attrName
314+ Just aval -> case parser aval of
315+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
316+ Right a -> return a