-- |
-- A utility library providing automatic namespacing,
-- which is required in handling of custom value types by the OPC protocol.
module OpcXmlDaClient.XmlBuilder
  ( -- * ByteString
    elementXml,

    -- * Element
    Element,
    element,

    -- * Node
    Node,
    elementNode,
    contentNode,
    astNode,

    -- * Content
    Content,
    textContent,
    qNameContent,

    -- * QName
    QName,
    namespacedQName,
    unnamespacedQName,
  )
where

import qualified Data.ByteString.Lazy as Lbs
import qualified Data.Map.Strict as Map
import OpcXmlDaClient.Base.Prelude
import qualified OpcXmlDaClient.XmlBuilder.Identified as Identified
import qualified Text.XML as Xml

-- *

elementXml :: Element -> ByteString
elementXml :: Element -> ByteString
elementXml (Element Namespaced Element
namespacedElement) =
  case Namespaced Element -> (Element, [(Text, Text)])
forall a. Namespaced a -> (a, [(Text, Text)])
runNamespaced Namespaced Element
namespacedElement of
    (Element
element, [(Text, Text)]
namespaces) ->
      let document :: Document
document = Prologue -> Element -> [Miscellaneous] -> Document
Xml.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Xml.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
element []
          renderingSettings :: RenderSettings
renderingSettings = RenderSettings
forall a. Default a => a
def {rsNamespaces :: [(Text, Text)]
Xml.rsNamespaces = ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> (Text, Text)
forall a b. (a, b) -> (b, a)
swap [(Text, Text)]
namespaces}
       in ByteString -> ByteString
Lbs.toStrict (RenderSettings -> Document -> ByteString
Xml.renderLBS RenderSettings
renderingSettings Document
document)

-- *

newtype Element = Element (Namespaced Xml.Element)

element :: QName -> [(QName, Content)] -> [Node] -> Element
element :: QName -> [(QName, Content)] -> [Node] -> Element
element (QName Namespaced Name
qName) [(QName, Content)]
attrList [Node]
nodeList =
  Namespaced Element -> Element
Element (Namespaced Element -> Element) -> Namespaced Element -> Element
forall a b. (a -> b) -> a -> b
$
    Name -> Map Name Text -> [Node] -> Element
Xml.Element
      (Name -> Map Name Text -> [Node] -> Element)
-> Namespaced Name
-> Identified Text Text (Map Name Text -> [Node] -> Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaced Name
qName
      Identified Text Text (Map Name Text -> [Node] -> Element)
-> Identified Text Text (Map Name Text)
-> Identified Text Text ([Node] -> Element)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(Name, Text)] -> Map Name Text)
-> Identified Text Text [(Name, Text)]
-> Identified Text Text (Map Name Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((QName, Content) -> Identified Text Text (Name, Text))
-> [(QName, Content)] -> Identified Text Text [(Name, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (QName, Content) -> Identified Text Text (Name, Text)
attr [(QName, Content)]
attrList)
      Identified Text Text ([Node] -> Element)
-> Identified Text Text [Node] -> Namespaced Element
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Node -> Identified Text Text Node)
-> [Node] -> Identified Text Text [Node]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Node -> Identified Text Text Node
runNode [Node]
nodeList
  where
    attr :: (QName, Content) -> Identified Text Text (Name, Text)
attr (QName Namespaced Name
name, Content Namespaced Text
content) =
      (,) (Name -> Text -> (Name, Text))
-> Namespaced Name -> Identified Text Text (Text -> (Name, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaced Name
name Identified Text Text (Text -> (Name, Text))
-> Namespaced Text -> Identified Text Text (Name, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespaced Text
content

-- *

newtype Node = Node {Node -> Identified Text Text Node
runNode :: Namespaced Xml.Node}

elementNode :: Element -> Node
elementNode :: Element -> Node
elementNode (Element Namespaced Element
a) = Identified Text Text Node -> Node
Node ((Element -> Node)
-> Namespaced Element -> Identified Text Text Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Node
Xml.NodeElement Namespaced Element
a)

contentNode :: Content -> Node
contentNode :: Content -> Node
contentNode (Content Namespaced Text
a) = Identified Text Text Node -> Node
Node ((Text -> Node) -> Namespaced Text -> Identified Text Text Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Node
Xml.NodeContent Namespaced Text
a)

astNode :: Xml.Node -> Node
astNode :: Node -> Node
astNode = Identified Text Text Node -> Node
Node (Identified Text Text Node -> Node)
-> (Node -> Identified Text Text Node) -> Node -> Node
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Node -> Identified Text Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- *

newtype Content = Content (Namespaced Text)

instance IsString Content where
  fromString :: String -> Content
fromString = Text -> Content
textContent (Text -> Content) -> (String -> Text) -> String -> Content
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a. IsString a => String -> a
fromString

textContent :: Text -> Content
textContent :: Text -> Content
textContent Text
text =
  Namespaced Text -> Content
Content (Text -> Namespaced Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
text)

qNameContent :: QName -> Content
qNameContent :: QName -> Content
qNameContent (QName Namespaced Name
qName) =
  Namespaced Text -> Content
Content ((Name -> Text) -> Namespaced Name -> Namespaced Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
renderName Namespaced Name
qName)
  where
    renderName :: Name -> Text
renderName (Xml.Name Text
name Maybe Text
_ Maybe Text
prefix) =
      Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
name (\Text
prefix -> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Maybe Text
prefix

-- *

newtype QName = QName (Namespaced Xml.Name)

instance IsString QName where
  fromString :: String -> QName
fromString = Text -> QName
unnamespacedQName (Text -> QName) -> (String -> Text) -> String -> QName
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a. IsString a => String -> a
fromString

-- |
-- Namespaced QName.
namespacedQName ::
  -- | Namespace URI.
  Text ->
  -- | Name.
  Text ->
  QName
namespacedQName :: Text -> Text -> QName
namespacedQName Text
uri Text
name =
  Namespaced Name -> QName
QName (Text -> (Text -> Name) -> Namespaced Name
forall k v a. k -> (v -> a) -> Identified k v a
Identified.identifying Text
uri (\Text
prefix -> Text -> Maybe Text -> Maybe Text -> Name
Xml.Name Text
name (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uri) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
prefix)))

-- |
-- Unnamespaced QName.
unnamespacedQName :: Text -> QName
unnamespacedQName :: Text -> QName
unnamespacedQName Text
name =
  Namespaced Name -> QName
QName (Name -> Namespaced Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text -> Maybe Text -> Name
Xml.Name Text
name Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing))

-- *

type Namespaced = Identified.Identified Text Text

runNamespaced :: Namespaced a -> (a, [(Text, Text)])
runNamespaced :: Namespaced a -> (a, [(Text, Text)])
runNamespaced Namespaced a
identified =
  Namespaced a -> (Int -> Text) -> (a, [(Text, Text)])
forall k v a.
(Hashable k, Eq k) =>
Identified k v a -> (Int -> v) -> (a, [(k, v)])
Identified.run Namespaced a
identified Int -> Text
forall a a. (Semigroup a, IsString a, Show a, Enum a) => a -> a
alias
  where
    alias :: a -> a
alias a
x = a
"ns" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (a -> String
forall a. Show a => a -> String
show (a -> a
forall a. Enum a => a -> a
succ a
x))