module Text.XML.DOM.Parser.Combinators
(
traverseElems
, inFilteredTrav
, inElemTrav
, inElem
, inElemAll
, inElemMay
, inElemNe
, divePath
, diveElem
, ignoreElem
, ignoreEmpty
, ignoreBlank
, getCurrentName
, getCurrentContent
, getCurrentAttributes
, getCurrentAttribute
, checkCurrentName
, parseContent
, readContent
, maybeReadContent
, parseAttribute
) where
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as M
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable
import Data.Typeable
import Text.Read
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 (DomPath, 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] -> (DomPath, [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
getCurrentName :: (Monad m) => DomParserT Identity m Text
getCurrentName = view $ pdElements . to runIdentity . localName
checkCurrentName
:: (Monad m)
=> Text
-> DomParserT Identity m ()
checkCurrentName n = do
cn <- getCurrentName
unless (cn == n) $ do
p <- view pdPath
let pinit = if null p then [] else init p
throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
return ()
getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
getCurrentContent = do
nds <- view $ pdElements . to runIdentity . nodes
let
els :: [Element]
els = nds ^.. folded . _Element
conts :: [Text]
conts = nds ^.. folded . _Content
return $ if
| not $ null els -> Nothing
| null conts -> Nothing
| otherwise -> Just $ mconcat conts
parseContent
:: (Monad m)
=> (Text -> Either Text a)
-> DomParserT Identity m a
parseContent parse = getCurrentContent >>= \case
Nothing -> throwParserError PEContentNotFound
Just c -> case parse c of
Left e -> throwParserError $ PEWrongFormat e
Right a -> return a
maybeReadContent
:: forall a
. (Typeable a)
=> (Text -> Maybe a)
-> Text
-> Either Text a
maybeReadContent f t = maybe (Left msg) Right $ f t
where
msg = "Not readable " <> n <> ": " <> t
n = T.pack $ show $ typeRep (Proxy :: Proxy a)
readContent
:: (Read a, Typeable a)
=> Text
-> Either Text a
readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
getCurrentAttributes = view $ pdElements . to runIdentity . attrs
getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
getCurrentAttribute attrName'
= preview $ pdElements . to runIdentity . attr attrName
where
attrName = Name attrName' Nothing Nothing
parseAttribute
:: (Monad m)
=> Text
-> (Text -> Either Text a)
-> DomParserT Identity m a
parseAttribute attrName parser = getCurrentAttribute attrName >>= \case
Nothing -> throwParserError $ PEAttributeNotFound attrName
Just aval -> case parser aval of
Left err -> throwParserError $ PEAttributeWrongFormat attrName err
Right a -> return a