@@ -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,105 @@ module Text.XML.DOM.Parser.Combinators
1515 , ignoreElem
1616 , ignoreEmpty
1717 , ignoreBlank
18+ -- * Checking current element properties
19+ , checkCurrentName
20+ -- * Parsing arbitrary content
21+ , parseContent
22+ , readContent
1823 ) where
1924
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
31−
32−
33−-- | Generic function to traverse arbitrary inner elements.
25+import Control.Lens
26+import Control.Monad.Except
27+import Control.Monad.Reader
28+import Data.List.NonEmpty (NonEmpty(..))
29+import Data.Monoid
30+import Data.Text (Text)
31+import qualified Data.Text as T
32+import Data.Traversable
33+import Data.Typeable
34+import Text.Read
35+import Text.Shakespeare.Text (st)
36+import Text.XML
37+import Text.XML.DOM.Parser.Types
38+import Text.XML.Lens
39+
40+
41+-- | Generic function to traverse arbitrary inner cursors.
3442traverseElems
3543 :: (Monad m, Foldable g, Traversable f)
36− => ([Element] -> DomParserT g m (f (DomPath, Element)))
37− -- ^ Takes list of current elements and returns container with
38− -- pairs of subpath (relatively to current elements) and element
39− -- to run parser in
44+ => ([Element] -> DomParserT g m (f ([Text], Element)))
45+ -- ^ Takes set of current elements and
4046 -> DomParserT Identity m a
41− -- ^ Parser to run for each element found in traversable 'f'
47+ -- ^ Parser will be runned for each element found in traversable
4248 -> DomParserT g m (f a)
4349traverseElems trav parser = do
4450 pd <- ask
4551 inner <- trav $ pd ^.. pdElements . folded
4652 for inner $ \(subpath, e) -> do
47− let
48− newpd = ParserData
49− { _pdElements = Identity e
50− , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
53+ let newpd = ParserData
54+ { _pdElements = Identity e
55+ , _pdPath = pd ^. pdPath <> subpath }
56+ magnify (to $ const newpd) parser
5257
53−-- | Traverses elements located in same path using filtering function
58+-- | Takes function filtering
5459inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
56− => ([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
60+ :: (Monad m, Foldable g, DomTraversable f)
61+ => ([Element] -> ([Text], [Element]))
62+ -- ^ Function returning some filtered elements with path suffixes which will
63+ -- be appended to parser's state
6064 -> DomParserT Identity m a
6165 -> DomParserT g m (f a)
6266inFilteredTrav deeper = traverseElems trav
6367 where
6468 trav e = do
6569 let (path, elems) = deeper e
66− case build elems of
70+ case buildDomTraversable elems of
6771 Nothing -> throwParserError $ PENotFound . (<> path)
6872 Just tr -> return $ fmap (path,) tr
6973
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.
7474inElemTrav
75− :: (Monad m, Foldable g, Buildable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
75+ :: (Monad m, Foldable g, DomTraversable f)
76+ => Text
7777 -> DomParserT Identity m a
7878 -> DomParserT g m (f a)
7979inElemTrav n = inFilteredTrav deeper
8080 where
81− elemsFold = folded . nodes . folded . _Element . elMatch n
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
81+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
8382
84−-- | Runs parser inside first children element matched by macher
83+-- | Runs parser inside first children element with given name
8584inElem
8685 :: (Monad m, Foldable g)
87− => ElemMatcher
86+ => Text
8887 -> DomParserT Identity m a
8988 -> DomParserT g m a
9089inElem n = fmap runIdentity . inElemTrav n
9190
9291inElemAll
9392 :: (Monad m, Foldable g)
94− => ElemMatcher
93+ => Text
9594 -> DomParserT Identity m a
9695 -> DomParserT g m [a]
9796inElemAll = inElemTrav
9897
9998inElemMay
10099 :: (Monad m, Foldable g)
101− => ElemMatcher
100+ => Text
102101 -> DomParserT Identity m a
103102 -> DomParserT g m (Maybe a)
104103inElemMay = inElemTrav
105104
106105inElemNe
107106 :: (Monad m, Foldable g)
108− => ElemMatcher
107+ => Text
109108 -> DomParserT Identity m a
110109 -> DomParserT g m (NonEmpty a)
111110inElemNe = inElemTrav
112111
113112{- | 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
113+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115114will not fail if occured tag "a" which does not contains tag "b". This
116115behaviour 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
116+to pull tags in some path. The other difference is in traversing inner
118117elements. Consider this code
119118
120119@
@@ -132,31 +131,26 @@ which translates like: @a > b > c > fromDom@
132131As you can see, inElem always takes first element and runs inner parser in this
133132single element, unlike 'divePath' which runs inner parser @in all@ descendants
134133in 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.
140134-}
141135
142136divePath
143137 :: forall m g a
144138 . (Monad m, Foldable g)
145− => [ElemMatcher]
139+ => [Text]
146140 -> DomParserT [] m a
147141 -> DomParserT g m a
148142divePath path = magnify $ to modElems
149143 where
150144 modElems
151145 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
146+ . over pdPath (<> path)
153147 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
148+ diver = foldr (.) id $ map toDive path
149+ toDive n = nodes . folded . _Element . ell n
156150
157151diveElem
158152 :: (Monad m, Foldable g)
159− => ElemMatcher
153+ => Text
160154 -> DomParserT [] m a
161155 -> DomParserT g m a
162156diveElem p = divePath [p]
@@ -166,7 +160,7 @@ ignoreElem
166160 :: (Monad m)
167161 => (Element -> Bool)
168162 -- ^ Predicate checking that we must ignore some current tag. If returns
169− -- 'True' then parser will not be runned and combinator just returns Nothing.
163+ -- true then parser will not be runned and combinator just returns Nothing.
170164 -> DomParserT Identity m a
171165 -> DomParserT Identity m (Maybe a)
172166ignoreElem test parser = do
@@ -174,7 +168,7 @@ ignoreElem test parser = do
174168 if ign then pure Nothing else Just <$> parser
175169
176170-- | If current element has no children nodes does not run parser and returns
177−-- Nothing. Otherwise runs parser inside current element. Useful when you got
171+-- Nothing. Otherwise runs parser inside current element. Usefull when you got
178172-- XML with strange empty elements which must be just ignored, but `inElem` runs
179173-- parser inside of this elements which causes to parser error.
180174ignoreEmpty
@@ -183,7 +177,7 @@ ignoreEmpty
183177 -> DomParserT Identity m (Maybe a)
184178ignoreEmpty = ignoreElem test
185179 where
186− test e = L.null $ e ^. nodes
180+ test e = null $ e ^. nodes
187181
188182-- | If all current elements contains blank content, or contains nothing at all
189183-- , then returns Nothing, else runs parser.
@@ -197,6 +191,49 @@ ignoreBlank = ignoreElem test
197191 let
198192 elems = e ^.. nodes . folded . _Element
199193 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
194+ in if | not $ null elems -> False
201195 | T.null $ T.strip cont -> True
202196 | otherwise -> False
197+
198+-- | If name of current tag differs from first argument throws 'PENotFound' with
199+-- tag name replaced in last path's segment. Usefull for checking root
200+-- document's element name.
201+checkCurrentName
202+ :: (Monad m)
203+ => Text
204+ -> DomParserT Identity m ()
205+checkCurrentName n = do
206+ cn <- view $ pdElements . to runIdentity . localName
207+ unless (cn == n) $ do
208+ p <- view pdPath
209+ let pinit = if null p then [] else init p
210+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
211+ return ()
212+
213+-- | Parses content inside current tag. It expects current element set consists
214+-- of exactly ONE element. Throws error if current elements set contains
215+-- multiple of them.
216+parseContent
217+ :: (Monad m)
218+ => (Text -> DomParserT Identity m a)
219+ -> DomParserT Identity m a
220+parseContent parse = do
221+ e <- view $ pdElements . to runIdentity
222+ let
223+ nds = e ^. nodes
224+ els = nds ^.. folded . _Element
225+ conts = nds ^.. folded . _Content
226+ when (not $ null els) $ throwParserError PEContentNotFound
227+ when (null conts) $ throwParserError PEContentNotFound
228+ parse $ mconcat conts
229+
230+readContent
231+ :: forall m g a
232+ . (Read a, Typeable a, Monad m)
233+ => Text
234+ -> DomParserT g m a
235+readContent t = case readMaybe $ T.unpack t of
236+ Nothing -> throwParserError $ PEWrongFormat [st|Not readable #{n}: #{t}|]
237+ Just a -> pure a
238+ where
239+ n = show $ typeRep (Proxy :: Proxy a)