    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE StandaloneDeriving #-}
    {-# LANGUAGE TypeFamilies #-}

    module DBus.Introspection.Render
        ( formatXML
        ) where

    import Conduit
    import Control.Monad.ST
    import Control.Monad.Trans.Maybe
    import Data.List (isPrefixOf)
    import Data.XML.Types (Event)
    import qualified Data.Text as T
    import qualified Data.Text.Lazy as TL
    import qualified Text.XML.Stream.Render as R

    import DBus.Internal.Types
    import DBus.Introspection.Types

    newtype Render s a = Render { forall s a. Render s a -> MaybeT (ST s) a
    runRender :: MaybeT (ST s) a }

    deriving instance Functor (Render s)
    deriving instance Applicative (Render s)
    deriving instance Monad (Render s)

    instance MonadThrow (Render s) where
        throwM :: forall e a. (HasCallStack, Exception e) => e -> Render s a
    throwM e
    _ = MaybeT (ST s) a -> Render s a
    forall s a. MaybeT (ST s) a -> Render s a
    Render (MaybeT (ST s) a -> Render s a) -> MaybeT (ST s) a -> Render s a
    forall a b. (a -> b) -> a -> b
    $ ST s (Maybe a) -> MaybeT (ST s) a
    forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
    MaybeT (ST s (Maybe a) -> MaybeT (ST s) a)
    -> ST s (Maybe a) -> MaybeT (ST s) a
    forall a b. (a -> b) -> a -> b
    $ Maybe a -> ST s (Maybe a)
    forall a. a -> ST s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe a
    forall a. Maybe a
    Nothing

    instance PrimMonad (Render s) where
        type PrimState (Render s) = s
        primitive :: forall a.
    (State# (PrimState (Render s))
     -> (# State# (PrimState (Render s)), a #))
    -> Render s a
    primitive State# (PrimState (Render s))
    -> (# State# (PrimState (Render s)), a #)
    f = MaybeT (ST s) a -> Render s a
    forall s a. MaybeT (ST s) a -> Render s a
    Render (MaybeT (ST s) a -> Render s a) -> MaybeT (ST s) a -> Render s a
    forall a b. (a -> b) -> a -> b
    $ ST s a -> MaybeT (ST s) a
    forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (ST s a -> MaybeT (ST s) a) -> ST s a -> MaybeT (ST s) a
    forall a b. (a -> b) -> a -> b
    $ (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
    -> ST s a
    forall a.
    (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
    -> ST s a
    forall (m :: * -> *) a.
    PrimMonad m =>
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
    primitive State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
    State# (PrimState (Render s))
    -> (# State# (PrimState (Render s)), a #)
    f

    formatXML :: Object -> Maybe String
    formatXML :: Object -> Maybe String
    formatXML Object
    obj = do
        xml <- (forall s. ST s (Maybe Text)) -> Maybe Text
    forall a. (forall s. ST s a) -> a
    runST ((forall s. ST s (Maybe Text)) -> Maybe Text)
    -> (forall s. ST s (Maybe Text)) -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ MaybeT (ST s) Text -> ST s (Maybe Text)
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
    runMaybeT (MaybeT (ST s) Text -> ST s (Maybe Text))
    -> MaybeT (ST s) Text -> ST s (Maybe Text)
    forall a b. (a -> b) -> a -> b
    $ Render s Text -> MaybeT (ST s) Text
    forall s a. Render s a -> MaybeT (ST s) a
    runRender (Render s Text -> MaybeT (ST s) Text)
    -> Render s Text -> MaybeT (ST s) Text
    forall a b. (a -> b) -> a -> b
    $ ConduitT () Void (Render s) Text -> Render s Text
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
    runConduit (ConduitT () Void (Render s) Text -> Render s Text)
    -> ConduitT () Void (Render s) Text -> Render s Text
    forall a b. (a -> b) -> a -> b
    $
            Object -> ConduitT () Event (Render s) ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    Object -> ConduitT i Event m ()
    renderRoot Object
    obj ConduitT () Event (Render s) ()
    -> ConduitT Event Void (Render s) Text
    -> ConduitT () Void (Render s) Text
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .| RenderSettings -> ConduitT Event Text (Render s) ()
    forall (m :: * -> *).
    (PrimMonad m, MonadThrow m) =>
    RenderSettings -> ConduitT Event Text m ()
    R.renderText RenderSettings
    forall a. Default a => a
    R.def ConduitT Event Text (Render s) ()
    -> ConduitT Text Void (Render s) Text
    -> ConduitT Event Void (Render s) Text
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .| ConduitT Text Void (Render s) Text
    forall (m :: * -> *) lazy strict o.
    (Monad m, LazySequence lazy strict) =>
    ConduitT strict o m lazy
    sinkLazy
        pure $ TL.unpack xml

    renderRoot :: MonadThrow m => Object -> ConduitT i Event m ()
    renderRoot :: forall (m :: * -> *) i.
    MonadThrow m =>
    Object -> ConduitT i Event m ()
    renderRoot Object
    obj = String -> Object -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    String -> Object -> ConduitT i Event m ()
    renderObject (ObjectPath -> String
    formatObjectPath (ObjectPath -> String) -> ObjectPath -> String
    forall a b. (a -> b) -> a -> b
    $ Object -> ObjectPath
    objectPath Object
    obj) Object
    obj

    renderObject :: MonadThrow m => String -> Object -> ConduitT i Event m ()
    renderObject :: forall (m :: * -> *) i.
    MonadThrow m =>
    String -> Object -> ConduitT i Event m ()
    renderObject String
    path Object{[Interface]
    [Object]
    ObjectPath
    objectPath :: Object -> ObjectPath
    objectPath :: ObjectPath
    objectInterfaces :: [Interface]
    objectChildren :: [Object]
    objectChildren :: Object -> [Object]
    objectInterfaces :: Object -> [Interface]
    ..} = Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    Monad m =>
    Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    R.tag Name
    "node"
        (Name -> Text -> Attributes
    R.attr Name
    "name" (String -> Text
    T.pack String
    path)) (ConduitT i Event m () -> ConduitT i Event m ())
    -> ConduitT i Event m () -> ConduitT i Event m ()
    forall a b. (a -> b) -> a -> b
    $ do
        (Interface -> ConduitT i Event m ())
    -> [Interface] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Interface -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    Interface -> ConduitT i Event m ()
    renderInterface [Interface]
    objectInterfaces
        (Object -> ConduitT i Event m ())
    -> [Object] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (ObjectPath -> Object -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    ObjectPath -> Object -> ConduitT i Event m ()
    renderChild ObjectPath
    objectPath) [Object]
    objectChildren

    renderChild :: MonadThrow m => ObjectPath -> Object -> ConduitT i Event m ()
    renderChild :: forall (m :: * -> *) i.
    MonadThrow m =>
    ObjectPath -> Object -> ConduitT i Event m ()
    renderChild ObjectPath
    parentPath Object
    obj
        | Bool -> Bool
    not (String
    parent' String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    path') =
            IOError -> ConduitT i Event m ()
    forall e a.
    (HasCallStack, Exception e) =>
    e -> ConduitT i Event m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, Exception e) =>
    e -> m a
    throwM (IOError -> ConduitT i Event m ())
    -> IOError -> ConduitT i Event m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IOError
    userError String
    "invalid child path"
        | String
    parent' String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    "/" = String -> Object -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    String -> Object -> ConduitT i Event m ()
    renderObject (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    1 String
    path') Object
    obj
        | Bool
    otherwise = String -> Object -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    String -> Object -> ConduitT i Event m ()
    renderObject (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    parent' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) String
    path') Object
    obj
      where
        path' :: String
    path' = ObjectPath -> String
    formatObjectPath (Object -> ObjectPath
    objectPath Object
    obj)
        parent' :: String
    parent' = ObjectPath -> String
    formatObjectPath ObjectPath
    parentPath

    renderInterface :: MonadThrow m => Interface -> ConduitT i Event m ()
    renderInterface :: forall (m :: * -> *) i.
    MonadThrow m =>
    Interface -> ConduitT i Event m ()
    renderInterface Interface{[Property]
    [Signal]
    [Method]
    InterfaceName
    interfaceName :: InterfaceName
    interfaceMethods :: [Method]
    interfaceSignals :: [Signal]
    interfaceProperties :: [Property]
    interfaceProperties :: Interface -> [Property]
    interfaceSignals :: Interface -> [Signal]
    interfaceMethods :: Interface -> [Method]
    interfaceName :: Interface -> InterfaceName
    ..} = Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    Monad m =>
    Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    R.tag Name
    "interface"
        (Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ InterfaceName -> String
    formatInterfaceName InterfaceName
    interfaceName) (ConduitT i Event m () -> ConduitT i Event m ())
    -> ConduitT i Event m () -> ConduitT i Event m ()
    forall a b. (a -> b) -> a -> b
    $ do
            (Method -> ConduitT i Event m ())
    -> [Method] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Method -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    Method -> ConduitT i Event m ()
    renderMethod [Method]
    interfaceMethods
            (Signal -> ConduitT i Event m ())
    -> [Signal] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Signal -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    Signal -> ConduitT i Event m ()
    renderSignal [Signal]
    interfaceSignals
            (Property -> ConduitT i Event m ())
    -> [Property] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Property -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    Property -> ConduitT i Event m ()
    renderProperty [Property]
    interfaceProperties

    renderMethod :: MonadThrow m => Method -> ConduitT i Event m ()
    renderMethod :: forall (m :: * -> *) i.
    MonadThrow m =>
    Method -> ConduitT i Event m ()
    renderMethod Method{[MethodArg]
    MemberName
    methodName :: MemberName
    methodArgs :: [MethodArg]
    methodArgs :: Method -> [MethodArg]
    methodName :: Method -> MemberName
    ..} = Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    Monad m =>
    Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    R.tag Name
    "method"
        (Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ MemberName -> String
    formatMemberName MemberName
    methodName) (ConduitT i Event m () -> ConduitT i Event m ())
    -> ConduitT i Event m () -> ConduitT i Event m ()
    forall a b. (a -> b) -> a -> b
    $
            (MethodArg -> ConduitT i Event m ())
    -> [MethodArg] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ MethodArg -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    MethodArg -> ConduitT i Event m ()
    renderMethodArg [MethodArg]
    methodArgs

    renderMethodArg :: MonadThrow m => MethodArg -> ConduitT i Event m ()
    renderMethodArg :: forall (m :: * -> *) i.
    MonadThrow m =>
    MethodArg -> ConduitT i Event m ()
    renderMethodArg MethodArg{String
    Type
    Direction
    methodArgName :: String
    methodArgType :: Type
    methodArgDirection :: Direction
    methodArgDirection :: MethodArg -> Direction
    methodArgType :: MethodArg -> Type
    methodArgName :: MethodArg -> String
    ..} = do
        typeStr <- Type -> ConduitT i Event m String
    forall (f :: * -> *). MonadThrow f => Type -> f String
    formatType Type
    methodArgType
        let typeAttr = Name -> Text -> Attributes
    R.attr Name
    "type" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    typeStr
            nameAttr = Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    methodArgName
            dirAttr = Name -> Text -> Attributes
    R.attr Name
    "direction" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ case Direction
    methodArgDirection of
                Direction
    In -> Text
    "in"
                Direction
    Out -> Text
    "out"
        R.tag "arg" (nameAttr <> typeAttr <> dirAttr) $ pure ()

    renderSignal :: MonadThrow m => Signal -> ConduitT i Event m ()
    renderSignal :: forall (m :: * -> *) i.
    MonadThrow m =>
    Signal -> ConduitT i Event m ()
    renderSignal Signal{[SignalArg]
    MemberName
    signalName :: MemberName
    signalArgs :: [SignalArg]
    signalArgs :: Signal -> [SignalArg]
    signalName :: Signal -> MemberName
    ..} = Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    Monad m =>
    Name
    -> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
    R.tag Name
    "signal"
        (Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ MemberName -> String
    formatMemberName MemberName
    signalName) (ConduitT i Event m () -> ConduitT i Event m ())
    -> ConduitT i Event m () -> ConduitT i Event m ()
    forall a b. (a -> b) -> a -> b
    $
            (SignalArg -> ConduitT i Event m ())
    -> [SignalArg] -> ConduitT i Event m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ SignalArg -> ConduitT i Event m ()
    forall (m :: * -> *) i.
    MonadThrow m =>
    SignalArg -> ConduitT i Event m ()
    renderSignalArg [SignalArg]
    signalArgs

    renderSignalArg :: MonadThrow m => SignalArg -> ConduitT i Event m ()
    renderSignalArg :: forall (m :: * -> *) i.
    MonadThrow m =>
    SignalArg -> ConduitT i Event m ()
    renderSignalArg SignalArg{String
    Type
    signalArgName :: String
    signalArgType :: Type
    signalArgType :: SignalArg -> Type
    signalArgName :: SignalArg -> String
    ..} = do
        typeStr <- Type -> ConduitT i Event m String
    forall (f :: * -> *). MonadThrow f => Type -> f String
    formatType Type
    signalArgType
        let typeAttr = Name -> Text -> Attributes
    R.attr Name
    "type" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    typeStr
            nameAttr = Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    signalArgName
        R.tag "arg" (nameAttr <> typeAttr) $ pure ()

    renderProperty :: MonadThrow m => Property -> ConduitT i Event m ()
    renderProperty :: forall (m :: * -> *) i.
    MonadThrow m =>
    Property -> ConduitT i Event m ()
    renderProperty Property{Bool
    String
    Type
    propertyName :: String
    propertyType :: Type
    propertyRead :: Bool
    propertyWrite :: Bool
    propertyWrite :: Property -> Bool
    propertyRead :: Property -> Bool
    propertyType :: Property -> Type
    propertyName :: Property -> String
    ..} = do
        typeStr <- Type -> ConduitT i Event m String
    forall (f :: * -> *). MonadThrow f => Type -> f String
    formatType Type
    propertyType
        let readStr = if Bool
    propertyRead then String
    "read" else String
    ""
            writeStr = if Bool
    propertyWrite then String
    "write" else String
    ""
            typeAttr = Name -> Text -> Attributes
    R.attr Name
    "type" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    typeStr
            nameAttr = Name -> Text -> Attributes
    R.attr Name
    "name" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    propertyName
            accessAttr = Name -> Text -> Attributes
    R.attr Name
    "access" (Text -> Attributes) -> Text -> Attributes
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (String
    readStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    writeStr)
        R.tag "property" (nameAttr <> typeAttr <> accessAttr) $ pure ()

    formatType :: MonadThrow f => Type -> f String
    formatType :: forall (f :: * -> *). MonadThrow f => Type -> f String
    formatType Type
    t = Signature -> String
    formatSignature (Signature -> String) -> f Signature -> f String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Type] -> f Signature
    forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
    signature [Type
    t]