@@ -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,47 @@ 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
31+ , parseAttributeMaybe
1832 ) where
1933
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
34+import Control.Lens
35+import Control.Monad.Except
36+import Control.Monad.Reader
37+import Data.List.NonEmpty (NonEmpty(..))
38+import qualified Data.Map.Strict as M
39+import Data.Monoid
40+import Data.Text (Text)
41+import qualified Data.Text as T
42+import Data.Traversable
43+import Data.Typeable
44+import Text.Read
45+import Text.XML
46+import Text.XML.DOM.Parser.Types
47+import Text.XML.Lens
3148
3249
33−-- | Generic function to traverse arbitrary inner elements.
50+-- | Generic function to traverse arbitrary inner cursors.
3451traverseElems
3552 :: (Monad m, Foldable g, Traversable f)
3653 => ([Element] -> DomParserT g m (f (DomPath, Element)))
3754 -- ^ Takes list of current elements and returns container with
38− -- pairs of subpath (relatively to current elements) and element
55+ -- pairs of subpath (relatively to current element) and element
3956 -- to run parser in
4057 -> DomParserT Identity m a
41− -- ^ Parser to run for each element found in traversable 'f'
58+ -- ^ Parser will be runned for each element found in traversable
4259 -> DomParserT g m (f a)
4360traverseElems trav parser = do
4461 pd <- ask
@@ -48,73 +65,68 @@ traverseElems trav parser = do
4865 newpd = ParserData
4966 { _pdElements = Identity e
5067 , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
68+ -- type of reader has been changed, local won't work here
69+ magnify (to $ const newpd) parser
5270
53−-- | Traverses elements located in same path using filtering function
71+-- | Takes function filtering
5472inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
73+ :: (Monad m, Foldable g, DomTraversable f)
5674 => ([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
75+ -- ^ Function returning some filtered elements with path suffixes which will
76+ -- be appended to parser's state
6077 -> DomParserT Identity m a
6178 -> DomParserT g m (f a)
6279inFilteredTrav deeper = traverseElems trav
6380 where
6481 trav e = do
6582 let (path, elems) = deeper e
66− case build elems of
83+ case buildDomTraversable elems of
6784 Nothing -> throwParserError $ PENotFound . (<> path)
6885 Just tr -> return $ fmap (path,) tr
6986
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.
7487inElemTrav
75− :: (Monad m, Foldable g, Buildable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
88+ :: (Monad m, Foldable g, DomTraversable f)
89+ => Text
7790 -> DomParserT Identity m a
7891 -> DomParserT g m (f a)
7992inElemTrav n = inFilteredTrav deeper
8093 where
81− elemsFold = folded . nodes . folded . _Element . elMatch n
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
94+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
8395
84−-- | Runs parser inside first children element matched by macher
96+-- | Runs parser inside first children element with given name
8597inElem
8698 :: (Monad m, Foldable g)
87− => ElemMatcher
99+ => Text
88100 -> DomParserT Identity m a
89101 -> DomParserT g m a
90102inElem n = fmap runIdentity . inElemTrav n
91103
92104inElemAll
93105 :: (Monad m, Foldable g)
94− => ElemMatcher
106+ => Text
95107 -> DomParserT Identity m a
96108 -> DomParserT g m [a]
97109inElemAll = inElemTrav
98110
99111inElemMay
100112 :: (Monad m, Foldable g)
101− => ElemMatcher
113+ => Text
102114 -> DomParserT Identity m a
103115 -> DomParserT g m (Maybe a)
104116inElemMay = inElemTrav
105117
106118inElemNe
107119 :: (Monad m, Foldable g)
108− => ElemMatcher
120+ => Text
109121 -> DomParserT Identity m a
110122 -> DomParserT g m (NonEmpty a)
111123inElemNe = inElemTrav
112124
113125{- | 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
126+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115127will not fail if occured tag "a" which does not contains tag "b". This
116128behaviour 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
129+to pull tags in some path. The other difference is in traversing inner
118130elements. Consider this code
119131
120132@
@@ -132,31 +144,26 @@ which translates like: @a > b > c > fromDom@
132144As you can see, inElem always takes first element and runs inner parser in this
133145single element, unlike 'divePath' which runs inner parser @in all@ descendants
134146in 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.
140147-}
141148
142149divePath
143150 :: forall m g a
144151 . (Monad m, Foldable g)
145− => [ElemMatcher]
152+ => [Text]
146153 -> DomParserT [] m a
147154 -> DomParserT g m a
148155divePath path = magnify $ to modElems
149156 where
150157 modElems
151158 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
159+ . over pdPath (<> path)
153160 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
161+ diver = foldr (.) id $ map toDive path
162+ toDive n = nodes . folded . _Element . ell n
156163
157164diveElem
158165 :: (Monad m, Foldable g)
159− => ElemMatcher
166+ => Text
160167 -> DomParserT [] m a
161168 -> DomParserT g m a
162169diveElem p = divePath [p]
@@ -183,7 +190,7 @@ ignoreEmpty
183190 -> DomParserT Identity m (Maybe a)
184191ignoreEmpty = ignoreElem test
185192 where
186− test e = L.null $ e ^. nodes
193+ test e = null $ e ^. nodes
187194
188195-- | If all current elements contains blank content, or contains nothing at all
189196-- , then returns Nothing, else runs parser.
@@ -197,6 +204,130 @@ ignoreBlank = ignoreElem test
197204 let
198205 elems = e ^.. nodes . folded . _Element
199206 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
207+ in if | not $ null elems -> False
201208 | T.null $ T.strip cont -> True
202209 | otherwise -> False
210+
211+-- | Returns name of current element.
212+--
213+-- @since 1.0.0
214+getCurrentName :: (Monad m) => DomParserT Identity m Text
215+getCurrentName = view $ pdElements . to runIdentity . localName
216+
217+-- | If name of current tag differs from first argument throws 'PENotFound' with
218+-- tag name replaced in last path's segment. Useful for checking root
219+-- document's element name.
220+checkCurrentName
221+ :: (Monad m)
222+ => Text
223+ -> DomParserT Identity m ()
224+checkCurrentName n = do
225+ cn <- getCurrentName
226+ unless (cn == n) $ do
227+ p <- view pdPath
228+ let pinit = if null p then [] else init p
229+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
230+ return ()
231+
232+-- | Get current content. If current element contains no content or
233+-- have inner elements then Nothing returned
234+--
235+-- @since 1.0.0
236+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
237+getCurrentContent = do
238+ nds <- view $ pdElements . to runIdentity . nodes
239+ let
240+ els :: [Element]
241+ els = nds ^.. folded . _Element
242+ conts :: [Text]
243+ conts = nds ^.. folded . _Content
244+ return $ if
245+ | not $ null els -> Nothing
246+ | null conts -> Nothing
247+ | otherwise -> Just $ mconcat conts
248+
249+-- | Parses content inside current tag. It expects current element set
250+-- consists of exactly ONE element. If current element does not
251+-- contains content or have other elements as childs then throws error
252+parseContent
253+ :: (Monad m)
254+ => (Text -> Either Text a)
255+ -- ^ Content parser, return error msg if value is not parsed
256+ -> DomParserT Identity m a
257+parseContent parse = getCurrentContent >>= \case
258+ Nothing -> throwParserError PEContentNotFound
259+ Just c -> case parse c of
260+ Left e -> throwParserError $ PEWrongFormat e
261+ Right a -> return a
262+
263+-- | If reader returns 'Nothing' then resulting function returns 'Left
264+-- "error message"'
265+--
266+-- @since 1.0.0
267+maybeReadContent
268+ :: forall a
269+ . (Typeable a)
270+ => (Text -> Maybe a)
271+ -- ^ Content or attribute reader
272+ -> Text
273+ -- ^ Content or attribute value
274+ -> Either Text a
275+maybeReadContent f t = maybe (Left msg) Right $ f t
276+ where
277+ msg = "Not readable " <> n <> ": " <> t
278+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
279+
280+-- | Tries to read given text to value using 'Read'. Useful to use
281+-- with 'parseContent' and 'parseAttribute'
282+readContent
283+ :: (Read a, Typeable a)
284+ => Text
285+ -> Either Text a
286+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
287+
288+-- | Retuns map of attributes of current element
289+--
290+-- @since 1.0.0
291+getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
292+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
293+
294+-- | Returns element with given name or 'Nothing'
295+--
296+-- @since 1.0.0
297+getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
298+getCurrentAttribute attrName'
299+ = preview $ pdElements . to runIdentity . attr attrName
300+ where
301+ attrName = Name attrName' Nothing Nothing
302+
303+-- | Parses attribute with given name, throws error if attribute is not found.
304+--
305+-- @since 1.0.0
306+parseAttribute
307+ :: (Monad m)
308+ => Text
309+ -- ^ Attribute name
310+ -> (Text -> Either Text a)
311+ -- ^ Attribute content parser
312+ -> DomParserT Identity m a
313+parseAttribute attrName parser =
314+ parseAttributeMaybe attrName parser >>= \case
315+ Nothing -> throwParserError $ PEAttributeNotFound attrName
316+ Just a -> return a
317+
318+-- | Parses attribute with given name.
319+--
320+-- @since 1.0.0
321+parseAttributeMaybe
322+ :: (Monad m)
323+ => Text
324+ -- ^ Attribute name
325+ -> (Text -> Either Text a)
326+ -- ^ Attribute content parser
327+ -> DomParserT Identity m (Maybe a)
328+parseAttributeMaybe attrName parser =
329+ getCurrentAttribute attrName >>= \case
330+ Nothing -> return Nothing
331+ Just aval -> case parser aval of
332+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
333+ Right a -> return $ Just a