module Text.XML.DOM.Parser.Content
(
parseContent
, getCurrentName
, getCurrentContent
, checkCurrentName
, maybeReadContent
, readContent
, readBool
, readChar
) where
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Data.List as L
import Data.Monoid
import Data.Text as T
import Data.Typeable
import Text.Read
import Text.XML.DOM.Parser.Types
import Text.XML.Lens
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 $ PEContentWrongFormat e
Right a -> return a
getCurrentName :: (Monad m) => DomParserT Identity m Name
getCurrentName = view $ pdElements . to runIdentity . name
checkCurrentName
:: (Monad m)
=> NameMatcher
-> DomParserT Identity m ()
checkCurrentName n = do
cn <- getCurrentName
unless ((n ^. nmMatch) cn) $ do
p <- view pdPath
let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p
throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow 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 $ L.null els -> Nothing
| L.null conts -> Nothing
| otherwise -> Just $ mconcat conts
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
readBool :: Text -> Either Text Bool
readBool t =
let
lowt = T.toLower $ T.strip t
tvals = ["y", "yes", "t", "true", "1"]
fvals = ["n", "no", "f", "false", "0"]
in if
| lowt `elem` tvals -> Right True
| lowt `elem` fvals -> Right False
| otherwise ->
Left $ "Could not read " <> t <> " as Bool"
readChar :: Text -> Either Text Char
readChar t = case T.unpack $ T.strip t of
[c] -> Right c
_ -> Left "Should have exactly one non-blank character"