{-# 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
    Text
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 {R.rsPretty = True}) 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
    String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack Text
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]
objectInterfaces :: Object -> [Interface]
objectChildren :: Object -> [Object]
..} = 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]
interfaceName :: Interface -> InterfaceName
interfaceMethods :: Interface -> [Method]
interfaceSignals :: Interface -> [Signal]
interfaceProperties :: Interface -> [Property]
..} = 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]
methodName :: Method -> MemberName
methodArgs :: Method -> [MethodArg]
..} = 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
methodArgName :: MethodArg -> String
methodArgType :: MethodArg -> Type
methodArgDirection :: MethodArg -> Direction
..} = do
    String
typeStr <- Type -> ConduitT i Event m String
forall (f :: * -> *). MonadThrow f => Type -> f String
formatType Type
methodArgType
    let typeAttr :: Attributes
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 :: Attributes
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 :: Attributes
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"
    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
"arg" (Attributes
nameAttr Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
dirAttr) (ConduitT i Event m () -> ConduitT i Event m ())
-> ConduitT i Event m () -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ () -> ConduitT i Event m ()
forall a. a -> ConduitT i Event m a
forall (f :: * -> *) a. Applicative f => a -> f a
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]
signalName :: Signal -> MemberName
signalArgs :: Signal -> [SignalArg]
..} = 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
signalArgName :: SignalArg -> String
signalArgType :: SignalArg -> Type
..} = do
    String
typeStr <- Type -> ConduitT i Event m String
forall (f :: * -> *). MonadThrow f => Type -> f String
formatType Type
signalArgType
    let typeAttr :: Attributes
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 :: Attributes
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
    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
"arg" (Attributes
nameAttr Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr) (ConduitT i Event m () -> ConduitT i Event m ())
-> ConduitT i Event m () -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ () -> ConduitT i Event m ()
forall a. a -> ConduitT i Event m a
forall (f :: * -> *) a. Applicative f => a -> f a
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
propertyName :: Property -> String
propertyType :: Property -> Type
propertyRead :: Property -> Bool
propertyWrite :: Property -> Bool
..} = do
    String
typeStr <- Type -> ConduitT i Event m String
forall (f :: * -> *). MonadThrow f => Type -> f String
formatType Type
propertyType
    let readStr :: String
readStr = if Bool
propertyRead then String
"read" else String
""
        writeStr :: String
writeStr = if Bool
propertyWrite then String
"write" else String
""
        typeAttr :: Attributes
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 :: Attributes
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 :: Attributes
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)
    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
"property" (Attributes
nameAttr Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
accessAttr) (ConduitT i Event m () -> ConduitT i Event m ())
-> ConduitT i Event m () -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ () -> ConduitT i Event m ()
forall a. a -> ConduitT i Event m a
forall (f :: * -> *) a. Applicative f => a -> f a
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]