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 :: forall (m :: * -> *) a.
Monad m =>
(Text -> Either Text a) -> DomParserT Identity m a
parseContent Text -> Either Text a
parse = DomParserT Identity m (Maybe Text)
forall (m :: * -> *). Monad m => DomParserT Identity m (Maybe Text)
getCurrentContent DomParserT Identity m (Maybe Text)
-> (Maybe Text
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall a b.
ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
-> (a -> ReaderT (ParserData Identity) (ExceptT ParserErrors m) b)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Text
Nothing -> (DomPath -> ParserError)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall (m :: * -> *) (f :: * -> *) a.
(MonadError ParserErrors m, MonadReader (ParserData f) m) =>
(DomPath -> ParserError) -> m a
throwParserError DomPath -> ParserError
PEContentNotFound
Just Text
c -> case Text -> Either Text a
parse Text
c of
Left Text
e -> (DomPath -> ParserError)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall (m :: * -> *) (f :: * -> *) a.
(MonadError ParserErrors m, MonadReader (ParserData f) m) =>
(DomPath -> ParserError) -> m a
throwParserError ((DomPath -> ParserError)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a)
-> (DomPath -> ParserError)
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall a b. (a -> b) -> a -> b
$ Text -> DomPath -> ParserError
PEContentWrongFormat Text
e
Right a
a -> a -> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall a.
a -> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
getCurrentName :: (Monad m) => DomParserT Identity m Name
getCurrentName :: forall (m :: * -> *). Monad m => DomParserT Identity m Name
getCurrentName = Getting Name (ParserData Identity) Name
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Name (ParserData Identity) Name
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) Name)
-> Getting Name (ParserData Identity) Name
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) Name
forall a b. (a -> b) -> a -> b
$ (Identity Element -> Const Name (Identity Element))
-> ParserData Identity -> Const Name (ParserData Identity)
forall (f1 :: * -> *) (f2 :: * -> *) (f3 :: * -> *).
Functor f3 =>
(f1 Element -> f3 (f2 Element))
-> ParserData f1 -> f3 (ParserData f2)
pdElements ((Identity Element -> Const Name (Identity Element))
-> ParserData Identity -> Const Name (ParserData Identity))
-> ((Name -> Const Name Name)
-> Identity Element -> Const Name (Identity Element))
-> Getting Name (ParserData Identity) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity Element -> Element)
-> (Element -> Const Name Element)
-> Identity Element
-> Const Name (Identity Element)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Identity Element -> Element
forall a. Identity a -> a
runIdentity ((Element -> Const Name Element)
-> Identity Element -> Const Name (Identity Element))
-> ((Name -> Const Name Name) -> Element -> Const Name Element)
-> (Name -> Const Name Name)
-> Identity Element
-> Const Name (Identity Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const Name Name) -> Element -> Const Name Element
Lens' Element Name
name
checkCurrentName
:: (Monad m)
=> NameMatcher
-> DomParserT Identity m ()
checkCurrentName :: forall (m :: * -> *).
Monad m =>
NameMatcher -> DomParserT Identity m ()
checkCurrentName NameMatcher
n = do
Name
cn <- DomParserT Identity m Name
forall (m :: * -> *). Monad m => DomParserT Identity m Name
getCurrentName
Bool -> DomParserT Identity m () -> DomParserT Identity m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((NameMatcher
n NameMatcher
-> Getting (Name -> Bool) NameMatcher (Name -> Bool)
-> Name
-> Bool
forall s a. s -> Getting a s a -> a
^. Getting (Name -> Bool) NameMatcher (Name -> Bool)
Lens' NameMatcher (Name -> Bool)
nmMatch) Name
cn) (DomParserT Identity m () -> DomParserT Identity m ())
-> DomParserT Identity m () -> DomParserT Identity m ()
forall a b. (a -> b) -> a -> b
$ do
DomPath
p <- Getting DomPath (ParserData Identity) DomPath
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) DomPath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DomPath (ParserData Identity) DomPath
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(DomPath -> f2 DomPath) -> ParserData f1 -> f2 (ParserData f1)
pdPath
let pinit :: [Text]
pinit = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null (DomPath -> [Text]
unDomPath DomPath
p) then [] else [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
L.init ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ DomPath -> [Text]
unDomPath DomPath
p
ParserErrors -> DomParserT Identity m ()
forall a.
ParserErrors
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParserErrors -> DomParserT Identity m ())
-> ParserErrors -> DomParserT Identity m ()
forall a b. (a -> b) -> a -> b
$ [ParserError] -> ParserErrors
ParserErrors [DomPath -> ParserError
PENotFound (DomPath -> ParserError) -> DomPath -> ParserError
forall a b. (a -> b) -> a -> b
$ [Text] -> DomPath
DomPath ([Text] -> DomPath) -> [Text] -> DomPath
forall a b. (a -> b) -> a -> b
$ [Text]
pinit [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [NameMatcher -> Text
_nmShow NameMatcher
n]]
() -> DomParserT Identity m ()
forall a.
a -> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
getCurrentContent :: forall (m :: * -> *). Monad m => DomParserT Identity m (Maybe Text)
getCurrentContent = do
[Node]
nds <- Getting [Node] (ParserData Identity) [Node]
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) [Node]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [Node] (ParserData Identity) [Node]
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) [Node])
-> Getting [Node] (ParserData Identity) [Node]
-> ReaderT (ParserData Identity) (ExceptT ParserErrors m) [Node]
forall a b. (a -> b) -> a -> b
$ (Identity Element -> Const [Node] (Identity Element))
-> ParserData Identity -> Const [Node] (ParserData Identity)
forall (f1 :: * -> *) (f2 :: * -> *) (f3 :: * -> *).
Functor f3 =>
(f1 Element -> f3 (f2 Element))
-> ParserData f1 -> f3 (ParserData f2)
pdElements ((Identity Element -> Const [Node] (Identity Element))
-> ParserData Identity -> Const [Node] (ParserData Identity))
-> (([Node] -> Const [Node] [Node])
-> Identity Element -> Const [Node] (Identity Element))
-> Getting [Node] (ParserData Identity) [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity Element -> Element)
-> (Element -> Const [Node] Element)
-> Identity Element
-> Const [Node] (Identity Element)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Identity Element -> Element
forall a. Identity a -> a
runIdentity ((Element -> Const [Node] Element)
-> Identity Element -> Const [Node] (Identity Element))
-> (([Node] -> Const [Node] [Node])
-> Element -> Const [Node] Element)
-> ([Node] -> Const [Node] [Node])
-> Identity Element
-> Const [Node] (Identity Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Node] -> Const [Node] [Node]) -> Element -> Const [Node] Element
Lens' Element [Node]
nodes
let
els :: [Element]
els :: [Element]
els = [Node]
nds [Node] -> Getting (Endo [Element]) [Node] Element -> [Element]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Node -> Const (Endo [Element]) Node)
-> [Node] -> Const (Endo [Element]) [Node]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [Node] Node
folded ((Node -> Const (Endo [Element]) Node)
-> [Node] -> Const (Endo [Element]) [Node])
-> ((Element -> Const (Endo [Element]) Element)
-> Node -> Const (Endo [Element]) Node)
-> Getting (Endo [Element]) [Node] Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Const (Endo [Element]) Element)
-> Node -> Const (Endo [Element]) Node
Prism' Node Element
_Element
conts :: [Text]
conts :: [Text]
conts = [Node]
nds [Node] -> Getting (Endo [Text]) [Node] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Node -> Const (Endo [Text]) Node)
-> [Node] -> Const (Endo [Text]) [Node]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [Node] Node
folded ((Node -> Const (Endo [Text]) Node)
-> [Node] -> Const (Endo [Text]) [Node])
-> ((Text -> Const (Endo [Text]) Text)
-> Node -> Const (Endo [Text]) Node)
-> Getting (Endo [Text]) [Node] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> Node -> Const (Endo [Text]) Node
Prism' Node Text
_Content
Maybe Text -> DomParserT Identity m (Maybe Text)
forall a.
a -> ReaderT (ParserData Identity) (ExceptT ParserErrors m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> DomParserT Identity m (Maybe Text))
-> Maybe Text -> DomParserT Identity m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Element] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Element]
els -> Maybe Text
forall a. Maybe a
Nothing
| [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Text]
conts -> Maybe Text
forall a. Maybe a
Nothing
| Bool
otherwise -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
conts
maybeReadContent
:: forall a
. (Typeable a)
=> (Text -> Maybe a)
-> Text
-> Either Text a
maybeReadContent :: forall a. Typeable a => (Text -> Maybe a) -> Text -> Either Text a
maybeReadContent Text -> Maybe a
f Text
t = Either Text a -> (a -> Either Text a) -> Maybe a -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text a
forall a b. a -> Either a b
Left Text
msg) a -> Either Text a
forall a b. b -> Either a b
Right (Maybe a -> Either Text a) -> Maybe a -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Maybe a
f Text
t
where
msg :: Text
msg = Text
"Not readable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
n :: Text
n = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
readContent
:: (Read a, Typeable a)
=> Text
-> Either Text a
readContent :: forall a. (Read a, Typeable a) => Text -> Either Text a
readContent = (Text -> Maybe a) -> Text -> Either Text a
forall a. Typeable a => (Text -> Maybe a) -> Text -> Either Text a
maybeReadContent ((Text -> Maybe a) -> Text -> Either Text a)
-> (Text -> Maybe a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
readBool :: Text -> Either Text Bool
readBool :: Text -> Either Text Bool
readBool Text
t =
let
lowt :: Text
lowt = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t
tvals :: [Text]
tvals = [Text
"y", Text
"yes", Text
"t", Text
"true", Text
"1"]
fvals :: [Text]
fvals = [Text
"n", Text
"no", Text
"f", Text
"false", Text
"0"]
in if
| Text
lowt Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
tvals -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
True
| Text
lowt Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
fvals -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
False
| Bool
otherwise ->
Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ Text
"Could not read " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as Bool"
readChar :: Text -> Either Text Char
readChar :: Text -> Either Text Char
readChar Text
t = case Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t of
[Char
c] -> Char -> Either Text Char
forall a b. b -> Either a b
Right Char
c
String
_ -> Text -> Either Text Char
forall a b. a -> Either a b
Left Text
"Should have exactly one non-blank character"