module Text.XML.DOM.Parser.Content
  (
    -- * Parsing element's content
    parseContent
    -- * Getting current element's properties
  , getCurrentName
  , getCurrentContent
  , checkCurrentName
    -- * Internal
  , 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


-- | Parses content inside current tag. It expects current element set
-- consists of exactly ONE element.
parseContent
  :: (Monad m)
  => (Text -> Either Text a)
     -- ^ Content parser, return error msg if value is not parsed
  -> 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


-- | Returns name of current element.
--
-- @since 1.0.0
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

-- | If name of current tag differs from first argument throws 'PENotFound' with
-- tag name replaced in last path's segment. Useful for checking root
-- document's element 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 ()

-- | Get current content. If current element contains no content or
-- have inner elements then Nothing returned
--
-- @since 1.0.0
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

-- | If reader returns 'Nothing' then resulting function returns 'Left
-- "error message"'. 'Typeable' is used for generating usefull error
-- message.
--
-- @since 1.0.0
maybeReadContent
  :: forall a
   . (Typeable a)
  => (Text -> Maybe a)
   -- ^ Content or attribute reader
  -> Text
   -- ^ Content or attribute value
  -> 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)


-- | Tries to read given text to value using 'Read'. Useful to use
-- with 'parseContent' and 'parseAttribute'. Content is stripped
-- before reading.
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


-- | @since 1.0.0
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"

-- | Expects text to be single character
--
-- @since 1.0.0
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"