{-# 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 { 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. Exception e => e -> Render s a
throwM e
_ = forall s a. MaybeT (ST s) a -> Render s a
Render forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall s a. MaybeT (ST s) a -> Render s a
Render forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall s a. Render s a -> MaybeT (ST s) a
runRender forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) i.
MonadThrow m =>
Object -> ConduitT i Event m ()
renderRoot Object
obj forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
R.renderText (forall a. Default a => a
R.def {rsPretty :: Bool
R.rsPretty = Bool
True}) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall (m :: * -> *) i.
MonadThrow m =>
String -> Object -> ConduitT i Event m ()
renderObject (ObjectPath -> String
formatObjectPath 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
objectChildren :: Object -> [Object]
objectInterfaces :: Object -> [Interface]
objectChildren :: [Object]
objectInterfaces :: [Interface]
objectPath :: ObjectPath
objectPath :: Object -> ObjectPath
..} = 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)) forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) i.
MonadThrow m =>
Interface -> ConduitT i Event m ()
renderInterface [Interface]
objectInterfaces
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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' forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
path') =
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"invalid child path"
    | String
parent' forall a. Eq a => a -> a -> Bool
== String
"/" = forall (m :: * -> *) i.
MonadThrow m =>
String -> Object -> ConduitT i Event m ()
renderObject (forall a. Int -> [a] -> [a]
drop Int
1 String
path') Object
obj
    | Bool
otherwise = forall (m :: * -> *) i.
MonadThrow m =>
String -> Object -> ConduitT i Event m ()
renderObject (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
parent' 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
interfaceProperties :: Interface -> [Property]
interfaceSignals :: Interface -> [Signal]
interfaceMethods :: Interface -> [Method]
interfaceName :: Interface -> InterfaceName
interfaceProperties :: [Property]
interfaceSignals :: [Signal]
interfaceMethods :: [Method]
interfaceName :: InterfaceName
..} = 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" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ InterfaceName -> String
formatInterfaceName InterfaceName
interfaceName) forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) i.
MonadThrow m =>
Method -> ConduitT i Event m ()
renderMethod [Method]
interfaceMethods
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) i.
MonadThrow m =>
Signal -> ConduitT i Event m ()
renderSignal [Signal]
interfaceSignals
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
methodArgs :: Method -> [MethodArg]
methodName :: Method -> MemberName
methodArgs :: [MethodArg]
methodName :: MemberName
..} = 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" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ MemberName -> String
formatMemberName MemberName
methodName) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
methodArgDirection :: MethodArg -> Direction
methodArgType :: MethodArg -> Type
methodArgName :: MethodArg -> String
methodArgDirection :: Direction
methodArgType :: Type
methodArgName :: String
..} = do
    String
typeStr <- forall (f :: * -> *). MonadThrow f => Type -> f String
formatType Type
methodArgType
    let typeAttr :: Attributes
typeAttr = Name -> Text -> Attributes
R.attr Name
"type" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
typeStr
        nameAttr :: Attributes
nameAttr = Name -> Text -> Attributes
R.attr Name
"name" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
methodArgName
        dirAttr :: Attributes
dirAttr = Name -> Text -> Attributes
R.attr Name
"direction" forall a b. (a -> b) -> a -> b
$ case Direction
methodArgDirection of
            Direction
In -> Text
"in"
            Direction
Out -> Text
"out"
    forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
R.tag Name
"arg" (Attributes
nameAttr forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr forall a. Semigroup a => a -> a -> a
<> Attributes
dirAttr) forall a b. (a -> b) -> a -> b
$ 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
signalArgs :: Signal -> [SignalArg]
signalName :: Signal -> MemberName
signalArgs :: [SignalArg]
signalName :: MemberName
..} = 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" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ MemberName -> String
formatMemberName MemberName
signalName) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
signalArgType :: SignalArg -> Type
signalArgName :: SignalArg -> String
signalArgType :: Type
signalArgName :: String
..} = do
    String
typeStr <- forall (f :: * -> *). MonadThrow f => Type -> f String
formatType Type
signalArgType
    let typeAttr :: Attributes
typeAttr = Name -> Text -> Attributes
R.attr Name
"type" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
typeStr
        nameAttr :: Attributes
nameAttr = Name -> Text -> Attributes
R.attr Name
"name" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
signalArgName
    forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
R.tag Name
"arg" (Attributes
nameAttr forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr) forall a b. (a -> b) -> a -> b
$ 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
propertyWrite :: Property -> Bool
propertyRead :: Property -> Bool
propertyType :: Property -> Type
propertyName :: Property -> String
propertyWrite :: Bool
propertyRead :: Bool
propertyType :: Type
propertyName :: String
..} = do
    String
typeStr <- 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" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
typeStr
        nameAttr :: Attributes
nameAttr = Name -> Text -> Attributes
R.attr Name
"name" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
propertyName
        accessAttr :: Attributes
accessAttr = Name -> Text -> Attributes
R.attr Name
"access" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
readStr forall a. [a] -> [a] -> [a]
++ String
writeStr)
    forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
R.tag Name
"property" (Attributes
nameAttr forall a. Semigroup a => a -> a -> a
<> Attributes
typeAttr forall a. Semigroup a => a -> a -> a
<> Attributes
accessAttr) forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Type
t]