{-# 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.Monoid ((<>))
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 { 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 :: 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 (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 :: (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 (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 (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) ()
-> ConduitM Event Void (Render s) Text
-> ConduitT () Void (Render s) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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 {rsPretty :: Bool
R.rsPretty = Bool
True}) ConduitT Event Text (Render s) ()
-> ConduitM Text Void (Render s) Text
-> ConduitM Event Void (Render s) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM 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 (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 :: 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 :: String -> Object -> ConduitT i Event m ()
renderObject String
path Object{[Interface]
[Object]
ObjectPath
objectChildren :: Object -> [Object]
objectInterfaces :: Object -> [Interface]
objectChildren :: [Object]
objectInterfaces :: [Interface]
objectPath :: ObjectPath
objectPath :: Object -> ObjectPath
..} = 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 :: 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 (m :: * -> *) e a. (MonadThrow m, 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 (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 :: Interface -> ConduitT i Event m ()
renderInterface Interface{[Property]
[Signal]
[Method]
InterfaceName
interfaceProperties :: Interface -> [Property]
interfaceSignals :: Interface -> [Signal]
interfaceMethods :: Interface -> [Method]
interfaceName :: Interface -> InterfaceName
interfaceProperties :: [Property]
interfaceSignals :: [Signal]
interfaceMethods :: [Method]
interfaceName :: 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 :: Method -> ConduitT i Event m ()
renderMethod Method{[MethodArg]
MemberName
methodArgs :: Method -> [MethodArg]
methodName :: Method -> MemberName
methodArgs :: [MethodArg]
methodName :: 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 :: MethodArg -> ConduitT i Event m ()
renderMethodArg MethodArg{String
Type
Direction
methodArgDirection :: MethodArg -> Direction
methodArgType :: MethodArg -> Type
methodArgName :: MethodArg -> String
methodArgDirection :: Direction
methodArgType :: Type
methodArgName :: String
..} = 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

renderSignal :: MonadThrow m => Signal -> ConduitT i Event m ()
renderSignal :: Signal -> ConduitT i Event m ()
renderSignal Signal{[SignalArg]
MemberName
signalArgs :: Signal -> [SignalArg]
signalName :: Signal -> MemberName
signalArgs :: [SignalArg]
signalName :: 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 :: SignalArg -> ConduitT i Event m ()
renderSignalArg SignalArg{String
Type
signalArgType :: SignalArg -> Type
signalArgName :: SignalArg -> String
signalArgType :: Type
signalArgName :: String
..} = 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

renderProperty :: MonadThrow m => Property -> ConduitT i Event m ()
renderProperty :: Property -> ConduitT i Event m ()
renderProperty Property{Bool
String
Type
propertyWrite :: Property -> Bool
propertyRead :: Property -> Bool
propertyType :: Property -> Type
propertyName :: Property -> String
propertyWrite :: Bool
propertyRead :: Bool
propertyType :: Type
propertyName :: String
..} = 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

formatType :: MonadThrow f => Type -> f String
formatType :: 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]