module Text.XML.DOM.Parser.Combinators
(
traverseElems
, inFilteredTrav
, inElemTrav
, inElem
, inElemAll
, inElemMay
, inElemNe
, divePath
, diveElem
, ignoreElem
, ignoreEmpty
, ignoreBlank
, checkCurrentName
, parseContent
, readContent
) where
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable
import Data.Typeable
import Text.Read
import Text.Shakespeare.Text (st)
import Text.XML
import Text.XML.DOM.Parser.Types
import Text.XML.Lens
traverseElems
:: (Monad m, Foldable g, Traversable f)
=> ([Element] -> DomParserT g m (f ([Text], Element)))
-> DomParserT Identity m a
-> DomParserT g m (f a)
traverseElems trav parser = do
pd <- ask
inner <- trav $ pd ^.. pdElements . folded
for inner $ \(subpath, e) -> do
let newpd = ParserData
{ _pdElements = Identity e
, _pdPath = pd ^. pdPath <> subpath }
magnify (to $ const newpd) parser
inFilteredTrav
:: (Monad m, Foldable g, DomTraversable f)
=> ([Element] -> ([Text], [Element]))
-> DomParserT Identity m a
-> DomParserT g m (f a)
inFilteredTrav deeper = traverseElems trav
where
trav e = do
let (path, elems) = deeper e
case buildDomTraversable elems of
Nothing -> throwParserError $ PENotFound . (<> path)
Just tr -> return $ fmap (path,) tr
inElemTrav
:: (Monad m, Foldable g, DomTraversable f)
=> Text
-> DomParserT Identity m a
-> DomParserT g m (f a)
inElemTrav n = inFilteredTrav deeper
where
deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
inElem
:: (Monad m, Foldable g)
=> Text
-> DomParserT Identity m a
-> DomParserT g m a
inElem n = fmap runIdentity . inElemTrav n
inElemAll
:: (Monad m, Foldable g)
=> Text
-> DomParserT Identity m a
-> DomParserT g m [a]
inElemAll = inElemTrav
inElemMay
:: (Monad m, Foldable g)
=> Text
-> DomParserT Identity m a
-> DomParserT g m (Maybe a)
inElemMay = inElemTrav
inElemNe
:: (Monad m, Foldable g)
=> Text
-> DomParserT Identity m a
-> DomParserT g m (NonEmpty a)
inElemNe = inElemTrav
divePath
:: forall m g a
. (Monad m, Foldable g)
=> [Text]
-> DomParserT [] m a
-> DomParserT g m a
divePath path = magnify $ to modElems
where
modElems
= over pdElements (toListOf $ folded . diver)
. over pdPath (<> path)
diver :: Fold Element Element
diver = foldr (.) id $ map toDive path
toDive n = nodes . folded . _Element . ell n
diveElem
:: (Monad m, Foldable g)
=> Text
-> DomParserT [] m a
-> DomParserT g m a
diveElem p = divePath [p]
ignoreElem
:: (Monad m)
=> (Element -> Bool)
-> DomParserT Identity m a
-> DomParserT Identity m (Maybe a)
ignoreElem test parser = do
ign <- view $ pdElements . to (test . runIdentity)
if ign then pure Nothing else Just <$> parser
ignoreEmpty
:: (Monad m)
=> DomParserT Identity m a
-> DomParserT Identity m (Maybe a)
ignoreEmpty = ignoreElem test
where
test e = null $ e ^. nodes
ignoreBlank
:: (Monad m)
=> DomParserT Identity m a
-> DomParserT Identity m (Maybe a)
ignoreBlank = ignoreElem test
where
test e =
let
elems = e ^.. nodes . folded . _Element
cont = mconcat $ e ^.. nodes . folded . _Content
in if | not $ null elems -> False
| T.null $ T.strip cont -> True
| otherwise -> False
checkCurrentName
:: (Monad m)
=> Text
-> DomParserT Identity m ()
checkCurrentName n = do
cn <- view $ pdElements . to runIdentity . localName
unless (cn == n) $ do
p <- view pdPath
let pinit = if null p then [] else init p
throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
return ()
parseContent
:: (Monad m)
=> (Text -> DomParserT Identity m a)
-> DomParserT Identity m a
parseContent parse = do
e <- view $ pdElements . to runIdentity
let
nds = e ^. nodes
els = nds ^.. folded . _Element
conts = nds ^.. folded . _Content
when (not $ null els) $ throwParserError PEContentNotFound
when (null conts) $ throwParserError PEContentNotFound
parse $ mconcat conts
readContent
:: forall m g a
. (Read a, Typeable a, Monad m)
=> Text
-> DomParserT g m a
readContent t = case readMaybe $ T.unpack t of
Nothing -> throwParserError $ PEWrongFormat [st|Not readable #{n}: #{t}|]
Just a -> pure a
where
n = show $ typeRep (Proxy :: Proxy a)