{-# 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]