@@ -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,106 +15,116 @@ 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
4561 inner <- trav $ pd ^.. pdElements . folded
4662 for inner $ \(subpath, e) -> do
47− let
48− newpd = ParserData
49− { _pdElements = Identity e
50− , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
63+ let newpd = ParserData
64+ { _pdElements = Identity e
65+ , _pdPath = pd ^. pdPath <> subpath }
66+ magnify (to $ const newpd) parser -- type of reader is changed, so
67+ -- local does not work
5268
53−-- | Traverses elements located in same path using filtering function
69+-- | Takes function filtering
5470inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
71+ :: (Monad m, Foldable g, DomTraversable f)
5672 => ([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
73+ -- ^ Function returning some filtered elements with path suffixes which will
74+ -- be appended to parser's state
6075 -> DomParserT Identity m a
6176 -> DomParserT g m (f a)
6277inFilteredTrav deeper = traverseElems trav
6378 where
6479 trav e = do
6580 let (path, elems) = deeper e
66− case build elems of
81+ case buildDomTraversable elems of
6782 Nothing -> throwParserError $ PENotFound . (<> path)
6883 Just tr -> return $ fmap (path,) tr
6984
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.
7485inElemTrav
75− :: (Monad m, Foldable g, Buildable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
86+ :: (Monad m, Foldable g, DomTraversable f)
87+ => Text
7788 -> DomParserT Identity m a
7889 -> DomParserT g m (f a)
7990inElemTrav n = inFilteredTrav deeper
8091 where
81− elemsFold = folded . nodes . folded . _Element . elMatch n
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
92+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
8393
84−-- | Runs parser inside first children element matched by macher
94+-- | Runs parser inside first children element with given name
8595inElem
8696 :: (Monad m, Foldable g)
87− => ElemMatcher
97+ => Text
8898 -> DomParserT Identity m a
8999 -> DomParserT g m a
90100inElem n = fmap runIdentity . inElemTrav n
91101
92102inElemAll
93103 :: (Monad m, Foldable g)
94− => ElemMatcher
104+ => Text
95105 -> DomParserT Identity m a
96106 -> DomParserT g m [a]
97107inElemAll = inElemTrav
98108
99109inElemMay
100110 :: (Monad m, Foldable g)
101− => ElemMatcher
111+ => Text
102112 -> DomParserT Identity m a
103113 -> DomParserT g m (Maybe a)
104114inElemMay = inElemTrav
105115
106116inElemNe
107117 :: (Monad m, Foldable g)
108− => ElemMatcher
118+ => Text
109119 -> DomParserT Identity m a
110120 -> DomParserT g m (NonEmpty a)
111121inElemNe = inElemTrav
112122
113123{- | 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
124+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115125will not fail if occured tag "a" which does not contains tag "b". This
116126behaviour 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
127+to pull tags in some path. The other difference is in traversing inner
118128elements. Consider this code
119129
120130@
@@ -132,31 +142,26 @@ which translates like: @a > b > c > fromDom@
132142As you can see, inElem always takes first element and runs inner parser in this
133143single element, unlike 'divePath' which runs inner parser @in all@ descendants
134144in 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.
140145-}
141146
142147divePath
143148 :: forall m g a
144149 . (Monad m, Foldable g)
145− => [ElemMatcher]
150+ => [Text]
146151 -> DomParserT [] m a
147152 -> DomParserT g m a
148153divePath path = magnify $ to modElems
149154 where
150155 modElems
151156 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
157+ . over pdPath (<> path)
153158 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
159+ diver = foldr (.) id $ map toDive path
160+ toDive n = nodes . folded . _Element . ell n
156161
157162diveElem
158163 :: (Monad m, Foldable g)
159− => ElemMatcher
164+ => Text
160165 -> DomParserT [] m a
161166 -> DomParserT g m a
162167diveElem p = divePath [p]
@@ -183,7 +188,7 @@ ignoreEmpty
183188 -> DomParserT Identity m (Maybe a)
184189ignoreEmpty = ignoreElem test
185190 where
186− test e = L.null $ e ^. nodes
191+ test e = null $ e ^. nodes
187192
188193-- | If all current elements contains blank content, or contains nothing at all
189194-- , then returns Nothing, else runs parser.
@@ -197,6 +202,114 @@ ignoreBlank = ignoreElem test
197202 let
198203 elems = e ^.. nodes . folded . _Element
199204 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
205+ in if | not $ null elems -> False
201206 | T.null $ T.strip cont -> True
202207 | otherwise -> False
208+
209+-- | Returns name of current element.
210+--
211+-- @since 1.0.0
212+getCurrentName :: (Monad m) => DomParserT Identity m Text
213+getCurrentName = view $ pdElements . to runIdentity . localName
214+
215+-- | If name of current tag differs from first argument throws 'PENotFound' with
216+-- tag name replaced in last path's segment. Useful for checking root
217+-- document's element name.
218+checkCurrentName
219+ :: (Monad m)
220+ => Text
221+ -> DomParserT Identity m ()
222+checkCurrentName n = do
223+ cn <- getCurrentName
224+ unless (cn == n) $ do
225+ p <- view pdPath
226+ let pinit = if null p then [] else init p
227+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
228+ return ()
229+
230+-- | Get current content. If current element contains no content or
231+-- have inner elements then Nothing returned
232+--
233+-- @since 1.0.0
234+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
235+getCurrentContent = do
236+ nds <- view $ pdElements . to runIdentity . nodes
237+ let
238+ els :: [Element]
239+ els = nds ^.. folded . _Element
240+ conts :: [Text]
241+ conts = nds ^.. folded . _Content
242+ return $ if
243+ | not $ null els -> Nothing
244+ | null conts -> Nothing
245+ | otherwise -> Just $ mconcat conts
246+
247+-- | Parses content inside current tag. It expects current element set
248+-- consists of exactly ONE element. If current element does not
249+-- contains content or have other elements as childs then throws error
250+parseContent
251+ :: (Monad m)
252+ => (Text -> Either Text a)
253+ -- ^ Content parser, return error msg if value is not parsed
254+ -> DomParserT Identity m a
255+parseContent parse = getCurrentContent >>= \case
256+ Nothing -> throwParserError PEContentNotFound
257+ Just c -> case parse c of
258+ Left e -> throwParserError $ PEWrongFormat e
259+ Right a -> return a
260+
261+-- | If reader returns 'Nothing' then resulting function returns 'Left
262+-- "error message"'
263+--
264+-- @since 1.0.0
265+maybeReadContent
266+ :: forall a
267+ . (Typeable a)
268+ => (Text -> Maybe a)
269+ -- ^ Content or attribute reader
270+ -> Text
271+ -- ^ Content or attribute value
272+ -> Either Text a
273+maybeReadContent f t = maybe (Left msg) Right $ f t
274+ where
275+ msg = "Not readable " <> n <> ": " <> t
276+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
277+
278+-- | Tries to read given text to value using 'Read'. Useful to use
279+-- with 'parseContent' and 'parseAttribute'
280+readContent
281+ :: (Read a, Typeable a)
282+ => Text
283+ -> Either Text a
284+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
285+
286+-- | Retuns map of attributes of current element
287+--
288+-- @since 1.0.0
289+getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
290+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
291+
292+-- | Returns element with given name or 'Nothing'
293+--
294+-- @since 1.0.0
295+getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
296+getCurrentAttribute attrName'
297+ = preview $ pdElements . to runIdentity . attr attrName
298+ where
299+ attrName = Name attrName' Nothing Nothing
300+
301+-- | Parses attribute with given name, throws error if attribute is not found.
302+--
303+-- @since 1.0.0
304+parseAttribute
305+ :: (Monad m)
306+ => Text
307+ -- ^ Attribute name
308+ -> (Text -> Either Text a)
309+ -- ^ Attribute content parser
310+ -> DomParserT Identity m a
311+parseAttribute attrName parser = getCurrentAttribute attrName >>= \case
312+ Nothing -> throwParserError $ PEAttributeNotFound attrName
313+ Just aval -> case parser aval of
314+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
315+ Right a -> return a