-- |
-- Module      : Amazonka.Data.XML
-- Copyright   : (c) 2013-2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Amazonka.Data.XML where

import Amazonka.Data.ByteString
import Amazonka.Data.Text
import Amazonka.Prelude
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit as Conduit
import qualified Data.Conduit.Lazy as Conduit.Lazy
import qualified Data.Conduit.List as Conduit.List
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import Data.XML.Types (Event (..))
import System.IO.Unsafe (unsafePerformIO)
import Text.XML
import qualified Text.XML.Stream.Render as XML.Stream
import qualified Text.XML.Unresolved as XML.Unresolved

infixl 7 .@, .@?

(.@) :: FromXML a => [Node] -> Text -> Either String a
[Node]
ns .@ :: forall a. FromXML a => [Node] -> Text -> Either [Char] a
.@ Text
n = Text -> [Node] -> Either [Char] [Node]
findElement Text
n [Node]
ns Either [Char] [Node]
-> ([Node] -> Either [Char] a) -> Either [Char] a
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Node] -> Either [Char] a
forall a. FromXML a => [Node] -> Either [Char] a
parseXML

(.@?) :: FromXML a => [Node] -> Text -> Either String (Maybe a)
[Node]
ns .@? :: forall a. FromXML a => [Node] -> Text -> Either [Char] (Maybe a)
.@? Text
n =
  case Text -> [Node] -> Either [Char] [Node]
findElement Text
n [Node]
ns of
    Left [Char]
_ -> Maybe a -> Either [Char] (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    Right [Node]
xs -> [Node] -> Either [Char] (Maybe a)
forall a. FromXML a => [Node] -> Either [Char] a
parseXML [Node]
xs

infixr 7 @=, @@=

(@=) :: ToXML a => Name -> a -> XML
Name
n @= :: forall a. ToXML a => Name -> a -> XML
@= a
x =
  case a -> XML
forall a. ToXML a => a -> XML
toXML a
x of
    XML
XNull -> XML
XNull
    XML
xs -> Node -> XML
XOne (Node -> XML) -> (Element -> Node) -> Element -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement (Element -> XML) -> Element -> XML
forall a b. (a -> b) -> a -> b
$ Name -> XML -> Element
forall a. ToXML a => Name -> a -> Element
mkElement Name
n XML
xs

(@@=) :: ToText a => Name -> a -> XML
Name
n @@= :: forall a. ToText a => Name -> a -> XML
@@= a
x = Name -> Text -> XML
XAttr Name
n (a -> Text
forall a. ToText a => a -> Text
toText a
x)

decodeXML :: FromXML a => ByteStringLazy -> Either String a
decodeXML :: forall a. FromXML a => ByteStringLazy -> Either [Char] a
decodeXML ByteStringLazy
lbs =
  (SomeException -> [Char])
-> (Document -> Element)
-> Either SomeException Document
-> Either [Char] Element
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap SomeException -> [Char]
forall a. Show a => a -> [Char]
show Document -> Element
documentRoot (ParseSettings -> ByteStringLazy -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteStringLazy
lbs)
    Either [Char] Element
-> (Element -> Either [Char] a) -> Either [Char] a
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Node] -> Either [Char] a
forall a. FromXML a => [Node] -> Either [Char] a
parseXML ([Node] -> Either [Char] a)
-> (Element -> [Node]) -> Element -> Either [Char] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Node]
childrenOf

-- The following is taken from xml-conduit.Text.XML which uses
-- unsafePerformIO anyway, with the following caveat:
--   'not generally safe, but we know that runResourceT
--    will not deallocate any of the resources being used
--    by the process.'
encodeXML :: ToElement a => a -> ByteStringLazy
encodeXML :: forall a. ToElement a => a -> ByteStringLazy
encodeXML a
x =
  [ByteString] -> ByteStringLazy
LBS.fromChunks ([ByteString] -> ByteStringLazy)
-> (Source IO ByteString -> [ByteString])
-> Source IO ByteString
-> ByteStringLazy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [ByteString] -> [ByteString]
forall a. IO a -> a
unsafePerformIO (IO [ByteString] -> [ByteString])
-> (Source IO ByteString -> IO [ByteString])
-> Source IO ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Source IO ByteString -> IO [ByteString]
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
Conduit.Lazy.lazyConsume (Source IO ByteString -> ByteStringLazy)
-> Source IO ByteString -> ByteStringLazy
forall a b. (a -> b) -> a -> b
$
    [Event] -> ConduitT () Event IO ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
Conduit.List.sourceList (Document -> [Event]
XML.Unresolved.toEvents Document
doc)
      ConduitT () Event IO ()
-> ConduitT Event ByteString IO () -> Source IO ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
Conduit..| (Event -> Event) -> ConduitT Event Event IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
Conduit.List.map Event -> Event
rename
      ConduitT Event Event IO ()
-> ConduitT Event ByteString IO ()
-> ConduitT Event ByteString IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
Conduit..| RenderSettings -> ConduitT Event ByteString IO ()
forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
XML.Stream.renderBytes RenderSettings
forall a. Default a => a
def
  where
    doc :: Document
doc =
      Document -> Document
toXMLDocument (Document -> Document) -> Document -> Document
forall a b. (a -> b) -> a -> b
$
        Document
          { documentRoot :: Element
documentRoot = Element
root,
            documentEpilogue :: [Miscellaneous]
documentEpilogue = [],
            documentPrologue :: Prologue
documentPrologue =
              Prologue
                { prologueBefore :: [Miscellaneous]
prologueBefore = [],
                  prologueDoctype :: Maybe Doctype
prologueDoctype = Maybe Doctype
forall a. Maybe a
Nothing,
                  prologueAfter :: [Miscellaneous]
prologueAfter = []
                }
          }

    rename :: Event -> Event
rename = \case
      EventBeginElement Name
n [(Name, [Content])]
xs -> Name -> [(Name, [Content])] -> Event
EventBeginElement (Name -> Name
f Name
n) (((Name, [Content]) -> (Name, [Content]))
-> [(Name, [Content])] -> [(Name, [Content])]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> (Name, [Content]) -> (Name, [Content])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> Name
f) [(Name, [Content])]
xs)
      EventEndElement Name
n -> Name -> Event
EventEndElement (Name -> Name
f Name
n)
      Event
evt -> Event
evt
      where
        f :: Name -> Name
f Name
n
          | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Name -> Maybe Text
nameNamespace Name
n) = Name
n {nameNamespace :: Maybe Text
nameNamespace = Maybe Text
ns}
          | Bool
otherwise = Name
n

    ns :: Maybe Text
ns = Name -> Maybe Text
nameNamespace (Element -> Name
elementName Element
root)
    root :: Element
root = a -> Element
forall a. ToElement a => a -> Element
toElement a
x

class FromXML a where
  parseXML :: [Node] -> Either String a

instance FromXML [Node] where
  parseXML :: [Node] -> Either [Char] [Node]
parseXML = [Node] -> Either [Char] [Node]
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromXML a => FromXML (Maybe a) where
  parseXML :: [Node] -> Either [Char] (Maybe a)
parseXML [] = Maybe a -> Either [Char] (Maybe a)
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  parseXML [Node]
ns = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either [Char] a -> Either [Char] (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node] -> Either [Char] a
forall a. FromXML a => [Node] -> Either [Char] a
parseXML [Node]
ns

instance FromXML Text where
  parseXML :: [Node] -> Either [Char] Text
parseXML = (Maybe Text -> Text)
-> Either [Char] (Maybe Text) -> Either [Char] Text
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty) (Either [Char] (Maybe Text) -> Either [Char] Text)
-> ([Node] -> Either [Char] (Maybe Text))
-> [Node]
-> Either [Char] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Node] -> Either [Char] (Maybe Text)
withContent [Char]
"Text"

instance FromXML Char where parseXML :: [Node] -> Either [Char] Char
parseXML = [Char] -> [Node] -> Either [Char] Char
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Char"

instance FromXML ByteString where parseXML :: [Node] -> Either [Char] ByteString
parseXML = [Char] -> [Node] -> Either [Char] ByteString
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"ByteString"

instance FromXML Int where parseXML :: [Node] -> Either [Char] Int
parseXML = [Char] -> [Node] -> Either [Char] Int
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Int"

instance FromXML Integer where parseXML :: [Node] -> Either [Char] Integer
parseXML = [Char] -> [Node] -> Either [Char] Integer
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Integer"

instance FromXML Natural where parseXML :: [Node] -> Either [Char] Natural
parseXML = [Char] -> [Node] -> Either [Char] Natural
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Natural"

instance FromXML Double where parseXML :: [Node] -> Either [Char] Double
parseXML = [Char] -> [Node] -> Either [Char] Double
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Double"

instance FromXML Bool where parseXML :: [Node] -> Either [Char] Bool
parseXML = [Char] -> [Node] -> Either [Char] Bool
forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
"Bool"

class ToElement a where
  toElement :: a -> Element

instance ToElement Element where
  toElement :: Element -> Element
toElement = Element -> Element
forall a. a -> a
id

-- | Convert to an 'Element', only if the resulting element contains @> 0@ nodes.
maybeElement :: ToElement a => a -> Maybe Element
maybeElement :: forall a. ToElement a => a -> Maybe Element
maybeElement a
x =
  case a -> Element
forall a. ToElement a => a -> Element
toElement a
x of
    e :: Element
e@(Element Name
_ Map Name Text
_ [Node]
ns)
      | [Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
ns -> Maybe Element
forall a. Maybe a
Nothing
      | Bool
otherwise -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
e

-- | Provides a way to make the operators for ToXML instance
-- declaration be consistent WRT to single nodes or lists of nodes.
data XML
  = XNull
  | XAttr Name Text
  | XOne Node
  | XMany [(Name, Text)] [Node]
  deriving stock (Int -> XML -> ShowS
[XML] -> ShowS
XML -> [Char]
(Int -> XML -> ShowS)
-> (XML -> [Char]) -> ([XML] -> ShowS) -> Show XML
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XML -> ShowS
showsPrec :: Int -> XML -> ShowS
$cshow :: XML -> [Char]
show :: XML -> [Char]
$cshowList :: [XML] -> ShowS
showList :: [XML] -> ShowS
Show)

instance Semigroup XML where
  XML
XNull <> :: XML -> XML -> XML
<> XML
XNull = XML
XNull
  XML
a <> XML
XNull = XML
a
  XML
XNull <> XML
b = XML
b
  XML
a <> XML
b =
    [(Name, Text)] -> [Node] -> XML
XMany
      (XML -> [(Name, Text)]
listXMLAttributes XML
a [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)]
forall a. Semigroup a => a -> a -> a
<> XML -> [(Name, Text)]
listXMLAttributes XML
b)
      (XML -> [Node]
listXMLNodes XML
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> XML -> [Node]
listXMLNodes XML
b)

instance Monoid XML where
  mempty :: XML
mempty = XML
XNull
  mappend :: XML -> XML -> XML
mappend = XML -> XML -> XML
forall a. Semigroup a => a -> a -> a
(<>)

listXMLNodes :: XML -> [Node]
listXMLNodes :: XML -> [Node]
listXMLNodes = \case
  XML
XNull -> []
  XAttr {} -> []
  XOne Node
n -> [Node
n]
  XMany [(Name, Text)]
_ [Node]
ns -> [Node]
ns

listXMLAttributes :: XML -> [(Name, Text)]
listXMLAttributes :: XML -> [(Name, Text)]
listXMLAttributes = \case
  XML
XNull -> []
  XAttr Name
n Text
t -> [(Name
n, Text
t)]
  XOne {} -> []
  XMany [(Name, Text)]
as [Node]
_ -> [(Name, Text)]
as

class ToXML a where
  toXML :: a -> XML

instance ToXML XML where
  toXML :: XML -> XML
toXML = XML -> XML
forall a. a -> a
id

instance ToXML a => ToXML (Maybe a) where
  toXML :: Maybe a -> XML
toXML (Just a
x) = a -> XML
forall a. ToXML a => a -> XML
toXML a
x
  toXML Maybe a
Nothing = XML
XNull

instance ToXML Text where toXML :: Text -> XML
toXML = Text -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML ByteString where toXML :: ByteString -> XML
toXML = ByteString -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML Int where toXML :: Int -> XML
toXML = Int -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML Integer where toXML :: Integer -> XML
toXML = Integer -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML Natural where toXML :: Natural -> XML
toXML = Natural -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML Double where toXML :: Double -> XML
toXML = Double -> XML
forall a. ToText a => a -> XML
toXMLText

instance ToXML Bool where toXML :: Bool -> XML
toXML = Bool -> XML
forall a. ToText a => a -> XML
toXMLText

parseXMLMap ::
  (Eq k, Hashable k, FromText k, FromXML v) =>
  Text ->
  Text ->
  Text ->
  [Node] ->
  Either String (HashMap k v)
parseXMLMap :: forall k v.
(Eq k, Hashable k, FromText k, FromXML v) =>
Text -> Text -> Text -> [Node] -> Either [Char] (HashMap k v)
parseXMLMap Text
e Text
k Text
v =
  ([(k, v)] -> HashMap k v)
-> Either [Char] [(k, v)] -> Either [Char] (HashMap k v)
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (Either [Char] [(k, v)] -> Either [Char] (HashMap k v))
-> ([Node] -> Either [Char] [(k, v)])
-> [Node]
-> Either [Char] (HashMap k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Node] -> Either [Char] (k, v))
-> [[Node]] -> Either [Char] [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Node] -> Either [Char] (k, v)
f ([[Node]] -> Either [Char] [(k, v)])
-> ([Node] -> [[Node]]) -> [Node] -> Either [Char] [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Maybe [Node]) -> [Node] -> [[Node]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Node -> Maybe [Node]
childNodesOf Text
e)
  where
    f :: [Node] -> Either [Char] (k, v)
f [Node]
ns =
      (,)
        (k -> v -> (k, v))
-> Either [Char] k -> Either [Char] (v -> (k, v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Node]
ns [Node] -> Text -> Either [Char] Text
forall a. FromXML a => [Node] -> Text -> Either [Char] a
.@ Text
k Either [Char] Text -> (Text -> Either [Char] k) -> Either [Char] k
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Either [Char] k
forall a. FromText a => Text -> Either [Char] a
fromText)
        Either [Char] (v -> (k, v))
-> Either [Char] v -> Either [Char] (k, v)
forall a b.
Either [Char] (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Node]
ns [Node] -> Text -> Either [Char] v
forall a. FromXML a => [Node] -> Text -> Either [Char] a
.@ Text
v

parseXMLList1 ::
  FromXML a =>
  Text ->
  [Node] ->
  Either String (NonEmpty a)
parseXMLList1 :: forall a. FromXML a => Text -> [Node] -> Either [Char] (NonEmpty a)
parseXMLList1 Text
n = Text -> [Node] -> Either [Char] [a]
forall a. FromXML a => Text -> [Node] -> Either [Char] [a]
parseXMLList Text
n ([Node] -> Either [Char] [a])
-> ([a] -> Either [Char] (NonEmpty a))
-> [Node]
-> Either [Char] (NonEmpty a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [a] -> Either [Char] (NonEmpty a)
parse
  where
    parse :: [a] -> Either [Char] (NonEmpty a)
parse [a]
xs =
      Either [Char] (NonEmpty a)
-> (NonEmpty a -> Either [Char] (NonEmpty a))
-> Maybe (NonEmpty a)
-> Either [Char] (NonEmpty a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ([Char] -> Either [Char] (NonEmpty a)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (NonEmpty a))
-> [Char] -> Either [Char] (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ [Char]
"Error parsing empty List1 when expecting at least one element: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
n)
        NonEmpty a -> Either [Char] (NonEmpty a)
forall a b. b -> Either a b
Right
        ([a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
xs)

parseXMLList ::
  FromXML a =>
  Text ->
  [Node] ->
  Either String [a]
parseXMLList :: forall a. FromXML a => Text -> [Node] -> Either [Char] [a]
parseXMLList Text
n = ([Node] -> Either [Char] a) -> [[Node]] -> Either [Char] [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Node] -> Either [Char] a
forall a. FromXML a => [Node] -> Either [Char] a
parseXML ([[Node]] -> Either [Char] [a])
-> ([Node] -> [[Node]]) -> [Node] -> Either [Char] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Maybe [Node]) -> [Node] -> [[Node]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Node -> Maybe [Node]
childNodesOf Text
n)

parseXMLText :: FromText a => String -> [Node] -> Either String a
parseXMLText :: forall a. FromText a => [Char] -> [Node] -> Either [Char] a
parseXMLText [Char]
n =
  [Char] -> [Node] -> Either [Char] (Maybe Text)
withContent [Char]
n
    ([Node] -> Either [Char] (Maybe Text))
-> (Maybe Text -> Either [Char] a) -> [Node] -> Either [Char] a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Either [Char] a
-> (Text -> Either [Char] a) -> Maybe Text -> Either [Char] a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      ([Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ [Char]
"empty node list, when expecting single node " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
n)
      Text -> Either [Char] a
forall a. FromText a => Text -> Either [Char] a
fromText

toXMLList :: (IsList a, ToXML (Item a)) => Name -> a -> XML
toXMLList :: forall a. (IsList a, ToXML (Item a)) => Name -> a -> XML
toXMLList Name
n = [(Name, Text)] -> [Node] -> XML
XMany [] ([Node] -> XML) -> (a -> [Node]) -> a -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item a -> Node) -> [Item a] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> Node
NodeElement (Element -> Node) -> (Item a -> Element) -> Item a -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Item a -> Element
forall a. ToXML a => Name -> a -> Element
mkElement Name
n) ([Item a] -> [Node]) -> (a -> [Item a]) -> a -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Item a]
forall l. IsList l => l -> [Item l]
toList

toXMLText :: ToText a => a -> XML
toXMLText :: forall a. ToText a => a -> XML
toXMLText = Node -> XML
XOne (Node -> XML) -> (a -> Node) -> a -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
NodeContent (Text -> Node) -> (a -> Text) -> a -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ToText a => a -> Text
toText

mkElement :: ToXML a => Name -> a -> Element
mkElement :: forall a. ToXML a => Name -> a -> Element
mkElement Name
n (a -> XML
forall a. ToXML a => a -> XML
toXML -> XML
x) =
  Name -> Map Name Text -> [Node] -> Element
Element Name
n ([Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList (XML -> [(Name, Text)]
listXMLAttributes XML
x)) (XML -> [Node]
listXMLNodes XML
x)

withContent :: String -> [Node] -> Either String (Maybe Text)
withContent :: [Char] -> [Node] -> Either [Char] (Maybe Text)
withContent [Char]
k = \case
  [] -> Maybe Text -> Either [Char] (Maybe Text)
forall a b. b -> Either a b
Right Maybe Text
forall a. Maybe a
Nothing
  [NodeContent Text
x] -> Maybe Text -> Either [Char] (Maybe Text)
forall a b. b -> Either a b
Right (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x)
  [Node]
_ -> [Char] -> Either [Char] (Maybe Text)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Maybe Text))
-> [Char] -> Either [Char] (Maybe Text)
forall a b. (a -> b) -> a -> b
$ [Char]
"encountered many nodes, when expecting text: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
k

-- | Find a specific named NodeElement, at the current depth in the node tree.
--
-- Fails if absent.
findElement :: Text -> [Node] -> Either String [Node]
findElement :: Text -> [Node] -> Either [Char] [Node]
findElement Text
n [Node]
ns =
  Text -> [Node] -> Maybe [Node] -> Either [Char] [Node]
forall a. Text -> [Node] -> Maybe a -> Either [Char] a
missingElement Text
n [Node]
ns
    (Maybe [Node] -> Either [Char] [Node])
-> ([[Node]] -> Maybe [Node]) -> [[Node]] -> Either [Char] [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Node]] -> Maybe [Node]
forall a. [a] -> Maybe a
listToMaybe
    ([[Node]] -> Either [Char] [Node])
-> [[Node]] -> Either [Char] [Node]
forall a b. (a -> b) -> a -> b
$ (Node -> Maybe [Node]) -> [Node] -> [[Node]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Node -> Maybe [Node]
childNodesOf Text
n) [Node]
ns

-- | Find the first specific named NodeElement, at any depth in the node tree.
--
-- Fails if absent.
firstElement :: Text -> [Node] -> Either String [Node]
firstElement :: Text -> [Node] -> Either [Char] [Node]
firstElement Text
n [Node]
ns =
  Text -> [Node] -> Maybe [Node] -> Either [Char] [Node]
forall a. Text -> [Node] -> Maybe a -> Either [Char] a
missingElement Text
n [Node]
ns
    (Maybe [Node] -> Either [Char] [Node])
-> ([[Node]] -> Maybe [Node]) -> [[Node]] -> Either [Char] [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Node]] -> Maybe [Node]
forall a. [a] -> Maybe a
listToMaybe
    ([[Node]] -> Either [Char] [Node])
-> [[Node]] -> Either [Char] [Node]
forall a b. (a -> b) -> a -> b
$ (Node -> Maybe [Node]) -> [Node] -> [[Node]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe [Node]
go [Node]
ns
  where
    go :: Node -> Maybe [Node]
go Node
x = case Node
x of
      NodeElement Element
e
        | Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Node -> Maybe Text
localName Node
x -> [Node] -> Maybe [Node]
forall a. a -> Maybe a
Just (Element -> [Node]
childrenOf Element
e)
        | Bool
otherwise -> [[Node]] -> Maybe [Node]
forall a. [a] -> Maybe a
listToMaybe ((Node -> Maybe [Node]) -> [Node] -> [[Node]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe [Node]
go (Element -> [Node]
elementNodes Element
e))
      Node
_ -> Maybe [Node]
forall a. Maybe a
Nothing

childNodesOf :: Text -> Node -> Maybe [Node]
childNodesOf :: Text -> Node -> Maybe [Node]
childNodesOf Text
n Node
x = case Node
x of
  NodeElement Element
e
    | Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Node -> Maybe Text
localName Node
x ->
        [Node] -> Maybe [Node]
forall a. a -> Maybe a
Just (Element -> [Node]
childrenOf Element
e)
  Node
_ -> Maybe [Node]
forall a. Maybe a
Nothing

childrenOf :: Element -> [Node]
childrenOf :: Element -> [Node]
childrenOf Element
e = Element -> [Node]
elementNodes Element
e [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> ((Name, Text) -> Node) -> [(Name, Text)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Text) -> Node
node (Map Name Text -> [Item (Map Name Text)]
forall l. IsList l => l -> [Item l]
toList (Element -> Map Name Text
elementAttributes Element
e))
  where
    node :: (Name, Text) -> Node
node (Name
k, Text
v) = Element -> Node
NodeElement (Name -> Map Name Text -> [Node] -> Element
Element (Name -> Name
name Name
k) Map Name Text
forall a. Monoid a => a
mempty [Text -> Node
NodeContent Text
v])

    name :: Name -> Name
name Name
k =
      Name
        { nameLocalName :: Text
nameLocalName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Name -> Maybe Text
namePrefix Name
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
nameLocalName Name
k,
          nameNamespace :: Maybe Text
nameNamespace = Maybe Text
forall a. Monoid a => a
mempty,
          namePrefix :: Maybe Text
namePrefix = Maybe Text
forall a. Monoid a => a
mempty
        }

localName :: Node -> Maybe Text
localName :: Node -> Maybe Text
localName = \case
  NodeElement Element
e -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Name -> Text
nameLocalName (Element -> Name
elementName Element
e))
  Node
_ -> Maybe Text
forall a. Maybe a
Nothing

-- | An inefficient mechanism for retreiving the root
-- element name of an XML document.
rootElementName :: ByteStringLazy -> Maybe Text
rootElementName :: ByteStringLazy -> Maybe Text
rootElementName ByteStringLazy
bs =
  (SomeException -> Maybe Text)
-> (Document -> Maybe Text)
-> Either SomeException Document
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (Maybe Text -> SomeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)
    (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (Document -> Text) -> Document -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameLocalName (Name -> Text) -> (Document -> Name) -> Document -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName (Element -> Name) -> (Document -> Element) -> Document -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Element
documentRoot)
    (ParseSettings -> ByteStringLazy -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteStringLazy
bs)

missingElement :: Text -> [Node] -> Maybe a -> Either String a
missingElement :: forall a. Text -> [Node] -> Maybe a -> Either [Char] a
missingElement Text
n [Node]
ns = Either [Char] a
-> (a -> Either [Char] a) -> Maybe a -> Either [Char] a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
err) a -> Either [Char] a
forall a b. b -> Either a b
Right
  where
    err :: [Char]
err =
      [Char]
"unable to find element "
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
n
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in nodes "
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show ((Node -> Maybe Text) -> [Node] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe Text
localName [Node]
ns)