module Cloud.AWS.Lib.Parser.Unordered
( SimpleXML
, ParseError (..)
, xmlParser
, xmlParserM
, xmlParserConduit
, getT, (.<)
, getElementM
, getElement
, getElements
, content
) where
import Cloud.AWS.Lib.FromText (FromText (..))
import Control.Applicative ((<$>))
import Control.Exception (Exception)
import Control.Monad (liftM)
import Control.Monad.Trans (lift)
import Data.Char (isSpace)
import Data.Conduit (ConduitM, Conduit, yield, MonadThrow (..))
import qualified Data.Conduit.List as CL
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HM
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.XML.Types (Event (..), Name (..), Content (..))
import Text.XML.Stream.Parse (XmlException (..))
data SimpleXML = Map (HashMap Text [SimpleXML])
| Content Text
deriving (Show, Eq)
data ParseError = ParseError
{ parseErrorMessage :: Text
} deriving (Show, Typeable)
instance Exception ParseError
xmlParser :: MonadThrow m
=> (SimpleXML -> m a)
-> ConduitM Event o m a
xmlParser parse = xmlParserM parse >>=
maybe (lift $ monadThrow $ ParseError "xmlParser: invalid xml") return
xmlParserM :: MonadThrow m
=> (SimpleXML -> m a)
-> ConduitM Event o m (Maybe a)
xmlParserM parse = do
xmlm <- getMultiXML
case xmlm of
Just xml -> lift $ liftM Just $ parse xml
Nothing -> return Nothing
xmlParserConduit :: MonadThrow m
=> Text
-> (SimpleXML -> m a)
-> Conduit Event m a
xmlParserConduit set parse = do
e <- dropWS
case e of
Just (EventBeginElement name _) | nameLocalName name == set -> do
CL.drop 1
innerParser parse
_ -> monadThrow $ ParseError $ "xmlParserConduit: no element '" <> set <> "'"
where
innerParser :: MonadThrow m => (SimpleXML -> m a) -> Conduit Event m a
innerParser parse' = do
xmlm <- getSingleXML
case xmlm of
Just xml -> do
a <- lift $ parse' xml
yield a
innerParser parse'
Nothing -> return ()
getSingleXML :: MonadThrow m
=> ConduitM Event o m (Maybe SimpleXML)
getSingleXML = do
e <- dropWS
case e of
Just (EventBeginElement name _) -> do
CL.drop 1
xmls <- getXMLList
let xml = Map $ HM.singleton (nameLocalName name) $ foldXML xmls
e' <- dropWS
case e' of
Just (EventEndElement name')
| name == name' -> CL.drop 1 >> return (Just xml)
_ -> lift $ monadThrow $ XmlException ("getSingleXML: Expected end tag for: " ++ show name) e'
Just (EventContent (ContentText t)) -> CL.drop 1 >> return (Just $ Content t)
_ -> return Nothing
foldXML :: [SimpleXML] -> [SimpleXML]
foldXML [] = []
foldXML xmls@(Content _ : _) = [Content $ T.concat . map toContent $ xmls]
where
toContent (Map _) = error $ "getSingleXML: Unexpected structure. Please report. " ++ show xmls
toContent (Content t) = t
foldXML xmls@(Map _ : _) = case [Map $ foldr (HM.unionWith (++) . toHMap) HM.empty xmls] of
[Map hmap] | hmap == HM.fromList [] -> []
xmls' -> xmls'
where
toHMap (Map hmap) = hmap
toHMap _ = error $ "getSingleXML: Unexpected structure. Please report. " ++ show xmls
getMultiXML :: MonadThrow m
=> ConduitM Event o m (Maybe SimpleXML)
getMultiXML = do
xmls <- getXMLList
return $ listToMaybe $ foldXML xmls
getXMLList :: MonadThrow m
=> ConduitM Event o m [SimpleXML]
getXMLList = do
e <- dropWS
case e of
Just EventEndElement{} -> return []
Nothing -> return []
_ -> do
xml <- getSingleXML
case xml of
Just xml' -> (xml' :) <$> getXMLList
Nothing -> return []
dropWS :: Monad m => ConduitM Event o m (Maybe Event)
dropWS = do
e <- CL.peek
if isWS e then CL.drop 1 >> dropWS else return e
where
isWS e = case e of
Just EventBeginDocument -> True
Just EventEndDocument -> True
Just EventBeginDoctype{} -> True
Just EventEndDoctype -> True
Just EventInstruction{} -> True
Just EventBeginElement{} -> False
Just EventEndElement{} -> False
Just (EventContent (ContentText t))
| T.all isSpace t -> True
| otherwise -> False
Just (EventContent ContentEntity{}) -> False
Just EventComment{} -> True
Just EventCDATA{} -> False
Nothing -> False
fromMaybeM :: Monad m => m a -> Maybe a -> m a
fromMaybeM a Nothing = a
fromMaybeM _ (Just a) = return a
getContentText :: SimpleXML -> Maybe Text
getContentText (Map _) = Nothing
getContentText (Content c) = return c
getSubXMLs :: SimpleXML -> Text -> [SimpleXML]
getSubXMLs (Map hmap) name = cat $ HM.lookup name hmap
where
cat (Just xs) = xs
cat Nothing = []
getSubXMLs (Content _) _ = []
getSubXMLM :: SimpleXML -> Text -> Maybe SimpleXML
getSubXMLM xml name = listToMaybe $ getSubXMLs xml name
getT :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a
getT xml name = fromNamedText name $
getSubXMLM xml name >>= getContentText
(.<) :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a
(.<) = getT
getElementM :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m (Maybe a)
getElementM xml name parse = case getSubXMLM xml name of
Just xml' -> liftM Just $ parse xml'
Nothing -> return Nothing
getElement :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m a
getElement xml name parse = getElementM xml name parse >>=
fromMaybeM (monadThrow $ ParseError $ "getElement: element '" <> name <> "' not found")
getElements :: MonadThrow m => SimpleXML -> Text -> Text -> (SimpleXML -> m a) -> m [a]
getElements xml set item parse = case getSubXMLM xml set of
Just xml' -> mapM parse $ getSubXMLs xml' item
Nothing -> return []
content :: MonadThrow m => SimpleXML -> m Text
content (Content t) = return t
content _ = fail "This is not a content."