{-# 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 _ = 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 f :: 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 obj :: 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 obj :: 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 path :: String
path 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 "node"
    (Name -> Text -> Attributes
R.attr "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 parentPath :: ObjectPath
parentPath obj :: 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 "invalid child path"
    | String
parent' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "/" = 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 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
+ 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{..} = 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 "interface"
    (Name -> Text -> Attributes
R.attr "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{..} = 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 "method"
    (Name -> Text -> Attributes
R.attr "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{..} = 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 "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" (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 "direction" (Text -> Attributes) -> Text -> Attributes
forall a b. (a -> b) -> a -> b
$ case Direction
methodArgDirection of
            In -> "in"
            Out -> "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 "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{..} = 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 "signal"
    (Name -> Text -> Attributes
R.attr "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{..} = 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 "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" (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 "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{..} = 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 "read" else ""
        writeStr :: String
writeStr = if Bool
propertyWrite then "write" else ""
        typeAttr :: Attributes
typeAttr = Name -> Text -> Attributes
R.attr "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" (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 "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 "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 t :: 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]