dbus 1.1.1 → 1.2.1

raw patch · 13 files changed

+526/−422 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• dbus.cabal +5/−2
• lib/DBus.hs +8/−2
• lib/DBus/Client.hs +6/−5
• lib/DBus/Generation.hs +10/−8
• lib/DBus/Internal/Types.hs +174/−42
• lib/DBus/Introspection.hs +4/−358
• lib/DBus/Introspection/Parse.hs +146/−0
• lib/DBus/Introspection/Render.hs +108/−0
• lib/DBus/Introspection/Types.hs +54/−0
• tests/DBusTests.hs +3/−1
• tests/DBusTests/Client.hs +2/−1
• tests/DBusTests/Generation.hs +1/−1
• tests/DBusTests/Introspection.hs +5/−2

@@ -1,5 +1,5 @@ name: dbus-version: 1.1.1+version: 1.2.1 license: Apache-2.0 license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -111,6 +111,9 @@     DBus.Internal.Types     DBus.Internal.Wire     DBus.Introspection+    DBus.Introspection.Parse+    DBus.Introspection.Render+    DBus.Introspection.Types     DBus.Socket     DBus.TH     DBus.Transport@@ -119,7 +122,7 @@   type: exitcode-stdio-1.0   main-is: DBusTests.hs   hs-source-dirs: tests-  ghc-options: -W -Wall+  ghc-options: -W -Wall -fno-warn-orphans    build-depends:       dbus

@@ -75,6 +75,7 @@     , IsAtom     , IsValue     , typeOf+    , typeOf'      -- * Signatures     , Signature@@ -171,6 +172,7 @@  import           Control.Monad (replicateM) import qualified Data.ByteString.Char8 as Char8+import           Data.Proxy (Proxy(..)) import           Data.Word (Word16) import           System.Random (randomRIO) import           Text.Printf (printf)@@ -178,13 +180,17 @@ import           DBus.Internal.Address import           DBus.Internal.Message import qualified DBus.Internal.Types-import           DBus.Internal.Types hiding (typeOf)+import           DBus.Internal.Types hiding (typeOf, typeOf') import           DBus.Internal.Wire --- | Get the D-Bus type corresponding to the given Haskell value. The value+-- | Deprecated. Get the D-Bus type corresponding to the given Haskell value. The value -- may be @undefined@. typeOf :: IsValue a => a -> Type typeOf = DBus.Internal.Types.typeOf++-- | Get the D-Bus type corresponding to the given Haskell type 'a'.+typeOf' :: IsValue a => Proxy a -> Type+typeOf' = DBus.Internal.Types.typeOf'  -- | Construct a new 'MethodCall' for the given object, interface, and method. --

@@ -189,7 +189,7 @@ import Data.Monoid import Data.String import qualified Data.Traversable as T-import Data.Typeable (Typeable)+import Data.Typeable (Typeable, Proxy(..)) import Data.Unique import Data.Word (Word32) import Prelude hiding (foldl, foldr, concat)@@ -197,7 +197,8 @@ import DBus import DBus.Internal.Message import qualified DBus.Internal.Types as T-import qualified DBus.Introspection as I+import qualified DBus.Introspection.Types as I+import qualified DBus.Introspection.Render as I import qualified DBus.Socket import DBus.Transport (TransportOpen, SocketTransport) @@ -1107,7 +1108,7 @@ instance IsValue a => AutoMethod (DBusR a) where     funTypes _ = ([], outTypes) where       aType :: Type-      aType = typeOf (undefined :: a)+      aType = typeOf' (Proxy :: Proxy a)       outTypes =         case aType of           TypeStructure ts -> ts@@ -1123,7 +1124,7 @@ instance IsValue a => AutoMethod (DBusR (Either Reply a)) where     funTypes _ = ([], outTypes) where       aType :: Type-      aType = typeOf (undefined :: a)+      aType = typeOf' (Proxy :: Proxy a)       outTypes =         case aType of           TypeStructure ts -> ts@@ -1175,7 +1176,7 @@   => MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property autoProperty name mgetter msetter =   Property name propType (fmap toVariant <$> mgetter) (variantSetter <$> msetter)-    where propType = typeOf (undefined :: v)+    where propType = typeOf' (Proxy :: Proxy v)           variantSetter setter =             let newFun variant = maybe (return ()) setter (fromVariant variant)             in newFun

@@ -7,7 +7,8 @@ import           DBus.Client as C import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T-import qualified DBus.Introspection as I+import qualified DBus.Introspection.Parse as I+import qualified DBus.Introspection.Types as I import qualified Data.ByteString as BS import qualified Data.Char as Char import           Data.Coerce@@ -18,6 +19,7 @@ import           Data.Maybe import           Data.Monoid import           Data.String+import qualified Data.Text.IO as Text import           Data.Traversable import           Data.Word import           Language.Haskell.TH@@ -535,10 +537,10 @@                         ]  generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]-generateFromFilePath generationParams filepath =-  let obj = unsafePerformIO $-            head . maybeToList . I.parseXML "/" <$> readFile filepath-      interface = head $ I.objectInterfaces obj-      signals = generateSignalsFromInterface generationParams interface-      client = generateClient generationParams interface-  in fmap (++) signals <*> client+generateFromFilePath generationParams filepath = do+    xml <- runIO $ Text.readFile filepath+    let obj = head $ maybeToList $ I.parseXML "/" xml+        interface = head $ I.objectInterfaces obj+        signals = generateSignalsFromInterface generationParams interface+        client = generateClient generationParams interface+     in fmap (++) signals <*> client

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}  -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>@@ -37,7 +38,7 @@ import qualified Data.Text import           Data.Text (Text) import qualified Data.Text.Lazy-import           Data.Typeable (Typeable)+import           Data.Typeable (Typeable, Proxy(..)) import qualified Data.Vector import           Data.Vector (Vector) import           Data.Word@@ -147,12 +148,12 @@  -- | Convert a list of types into a valid signature. ----- Returns @Nothing@ if the given types are not a valid signature.-signature :: [Type] -> Maybe Signature+-- Throws if the given types are not a valid signature.+signature :: MonadThrow m => [Type] -> m Signature signature = check where     check ts = if sumLen ts > 255-        then Nothing-        else Just (Signature ts)+        then throwM $ userError "invalid signature"+        else pure (Signature ts)     sumLen :: [Type] -> Int     sumLen = sum . map len @@ -308,6 +309,9 @@ extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v extractFromVariant v = fromVariant v +typeOf :: forall a. IsValue a => a -> Type+typeOf _ = typeOf' (Proxy :: Proxy a)+ class IsVariant a where     toVariant :: a -> Variant     fromVariant :: Variant -> Maybe a@@ -318,7 +322,7 @@ -- Users may not provide new instances of 'IsValue' because this could allow -- containers to be created with items of heterogenous types. class IsVariant a => IsValue a where-    typeOf :: a -> Type+    typeOf' :: Proxy a -> Type     toValue :: a -> Value     fromValue :: Value -> Maybe a @@ -452,7 +456,7 @@     ; fromAtom _ = Nothing \     }; \     instance IsValue HsType where \-    { typeOf _ = TypeCons \+    { typeOf' _ = TypeCons \     ; toValue = ValueAtom . toAtom \     ; fromValue (ValueAtom x) = fromAtom x \     ; fromValue _ = Nothing \@@ -477,7 +481,7 @@ IS_ATOM(ObjectPath, AtomObjectPath, TypeObjectPath)  instance IsValue Variant where-    typeOf _ = TypeVariant+    typeOf' _ = TypeVariant     toValue = ValueVariant     fromValue (ValueVariant x) = Just x     fromValue _ = Nothing@@ -491,7 +495,7 @@     fromAtom = fmap Data.Text.Lazy.fromStrict . fromAtom  instance IsValue Data.Text.Lazy.Text where-    typeOf _ = TypeString+    typeOf' _ = TypeString     toValue = ValueAtom . toAtom     fromValue (ValueAtom x) = fromAtom x     fromValue _ = Nothing@@ -505,7 +509,7 @@     fromAtom = fmap Data.Text.unpack . fromAtom  instance IsValue String where-    typeOf _ = TypeString+    typeOf' _ = TypeString     toValue = ValueAtom . toAtom     fromValue (ValueAtom x) = fromAtom x     fromValue _ = Nothing@@ -515,20 +519,19 @@     fromVariant (Variant val) = fromValue val  instance IsValue a => IsValue (Vector a) where-    typeOf v = TypeArray (vectorItemType v)-    toValue v = ValueVector (vectorItemType v) (Data.Vector.map toValue v)+    typeOf' _ = TypeArray (typeOf' (Proxy :: Proxy a))+    toValue v = ValueVector+        (typeOf' (Proxy :: Proxy a))+        (Data.Vector.map toValue v)     fromValue (ValueVector _ v) = Data.Vector.mapM fromValue v     fromValue _ = Nothing -vectorItemType :: IsValue a => Vector a -> Type-vectorItemType v = typeOf (undefined `asTypeOf` Data.Vector.head v)- instance IsValue a => IsVariant (Vector a) where     toVariant = Variant . toValue     fromVariant (Variant val) = fromValue val  instance IsValue a => IsValue [a] where-    typeOf v = TypeArray (typeOf (undefined `asTypeOf` head v))+    typeOf' _ = TypeArray (typeOf' (Proxy :: Proxy a))     toValue = toValue . Data.Vector.fromList     fromValue = fmap Data.Vector.toList . fromValue @@ -537,7 +540,7 @@     fromVariant = fmap Data.Vector.toList . fromVariant  instance IsValue BS.ByteString where-    typeOf _ = TypeArray TypeWord8+    typeOf' _ = TypeArray TypeWord8     toValue = ValueBytes     fromValue (ValueBytes bs) = Just bs     fromValue (ValueVector TypeWord8 v) = Just (vectorToBytes v)@@ -548,7 +551,7 @@     fromVariant (Variant val) = fromValue val  instance IsValue BL.ByteString where-    typeOf _ = TypeArray TypeWord8+    typeOf' _ = TypeArray TypeWord8     toValue = toValue             . BS.concat             . BL.toChunks@@ -560,11 +563,13 @@     fromVariant (Variant val) = fromValue val  instance (Ord k, IsAtom k, IsValue v) => IsValue (Map k v) where-    typeOf m = TypeDictionary kt vt where-        (kt, vt) = mapItemType m+    typeOf' _ = TypeDictionary+        (typeOf' (Proxy :: Proxy k))+        (typeOf' (Proxy :: Proxy v))      toValue m = ValueMap kt vt (bimap box m) where-        (kt, vt) = mapItemType m+        kt = typeOf' (Proxy :: Proxy k)+        vt = typeOf' (Proxy :: Proxy v)         box k v = (toAtom k, toValue v)      fromValue (ValueMap _ _ m) = bimapM unbox m where@@ -580,18 +585,12 @@ bimapM :: (Monad m, Ord k') => (k -> v -> m (k', v')) -> Map k v -> m (Map k' v') bimapM f = liftM Data.Map.fromList . mapM (\(k, v) -> f k v) . Data.Map.toList -mapItemType :: (IsValue k, IsValue v) => Map k v -> (Type, Type)-mapItemType m = (typeOf k, typeOf v) where-    mapItem :: Map k v -> (k, v)-    mapItem _ = (undefined, undefined)-    (k, v) = mapItem m- instance (Ord k, IsAtom k, IsValue v) => IsVariant (Map k v) where     toVariant = Variant . toValue     fromVariant (Variant val) = fromValue val  instance IsValue () where-  typeOf _ = TypeStructure []+  typeOf' _ = TypeStructure []   toValue _ = ValueStructure []   fromValue (ValueStructure []) = return ()   fromValue _ = Nothing@@ -602,7 +601,10 @@   fromVariant _ = Nothing  instance (IsValue a1, IsValue a2) => IsValue (a1, a2) where-    typeOf ~(a1, a2) = TypeStructure [typeOf a1, typeOf a2]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        ]     toValue (a1, a2) = ValueStructure [toValue a1, toValue a2]     fromValue (ValueStructure [a1, a2]) = do         a1' <- fromValue a1@@ -910,7 +912,11 @@     return (Variant (ValueAtom k), Variant v)  instance (IsValue a1, IsValue a2, IsValue a3) => IsValue (a1, a2, a3) where-    typeOf ~(a1, a2, a3) = TypeStructure [typeOf a1, typeOf a2, typeOf a3]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        ]     toValue (a1, a2, a3) = ValueStructure [toValue a1, toValue a2, toValue a3]     fromValue (ValueStructure [a1, a2, a3]) = do         a1' <- fromValue a1@@ -920,7 +926,12 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4) => IsValue (a1, a2, a3, a4) where-    typeOf ~(a1, a2, a3, a4) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        ]     toValue (a1, a2, a3, a4) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4]     fromValue (ValueStructure [a1, a2, a3, a4]) = do         a1' <- fromValue a1@@ -931,7 +942,13 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5) => IsValue (a1, a2, a3, a4, a5) where-    typeOf ~(a1, a2, a3, a4, a5) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        ]     toValue (a1, a2, a3, a4, a5) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5]     fromValue (ValueStructure [a1, a2, a3, a4, a5]) = do         a1' <- fromValue a1@@ -943,7 +960,14 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6) => IsValue (a1, a2, a3, a4, a5, a6) where-    typeOf ~(a1, a2, a3, a4, a5, a6) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        ]     toValue (a1, a2, a3, a4, a5, a6) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6]) = do         a1' <- fromValue a1@@ -956,7 +980,15 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7) => IsValue (a1, a2, a3, a4, a5, a6, a7) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7]) = do         a1' <- fromValue a1@@ -970,7 +1002,16 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8]) = do         a1' <- fromValue a1@@ -985,7 +1026,17 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = do         a1' <- fromValue a1@@ -1001,7 +1052,18 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10]) = do         a1' <- fromValue a1@@ -1018,7 +1080,19 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        , typeOf' (Proxy :: Proxy a11)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11]) = do         a1' <- fromValue a1@@ -1036,7 +1110,20 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        , typeOf' (Proxy :: Proxy a11)+        , typeOf' (Proxy :: Proxy a12)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12]) = do         a1' <- fromValue a1@@ -1055,7 +1142,21 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        , typeOf' (Proxy :: Proxy a11)+        , typeOf' (Proxy :: Proxy a12)+        , typeOf' (Proxy :: Proxy a13)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13]) = do         a1' <- fromValue a1@@ -1075,7 +1176,22 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13, typeOf a14]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        , typeOf' (Proxy :: Proxy a11)+        , typeOf' (Proxy :: Proxy a12)+        , typeOf' (Proxy :: Proxy a13)+        , typeOf' (Proxy :: Proxy a14)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14]) = do         a1' <- fromValue a1@@ -1096,7 +1212,23 @@     fromValue _ = Nothing  instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14, IsValue a15) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) where-    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13, typeOf a14, typeOf a15]+    typeOf' _ = TypeStructure+        [ typeOf' (Proxy :: Proxy a1)+        , typeOf' (Proxy :: Proxy a2)+        , typeOf' (Proxy :: Proxy a3)+        , typeOf' (Proxy :: Proxy a4)+        , typeOf' (Proxy :: Proxy a5)+        , typeOf' (Proxy :: Proxy a6)+        , typeOf' (Proxy :: Proxy a7)+        , typeOf' (Proxy :: Proxy a8)+        , typeOf' (Proxy :: Proxy a9)+        , typeOf' (Proxy :: Proxy a10)+        , typeOf' (Proxy :: Proxy a11)+        , typeOf' (Proxy :: Proxy a12)+        , typeOf' (Proxy :: Proxy a13)+        , typeOf' (Proxy :: Proxy a14)+        , typeOf' (Proxy :: Proxy a15)+        ]     toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14, toValue a15]     fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15]) = do         a1' <- fromValue a1

@@ -1,361 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}---- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------     http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.- module DBus.Introspection-    (-    -- * XML conversion-      parseXML-    , formatXML-    , Object(..)-    , Interface(..)-    , Method(..)-    , MethodArg(..)-    , Direction(..)-    , Signal(..)-    , SignalArg(..)-    , Property(..)+    ( module X     ) where -import           Conduit-import qualified Control.Applicative-import           Control.Monad (ap, liftM)-import qualified Data.ByteString.Lazy.Char8 as BL8-import           Data.List (isPrefixOf)-import           Data.Maybe-import qualified Data.Text as Text-import           Data.XML.Types-import qualified Text.XML.Stream.Parse as X--import qualified DBus as T--data Object = Object-    { objectPath :: T.ObjectPath-    , objectInterfaces :: [Interface]-    , objectChildren :: [Object]-    }-    deriving (Show, Eq)--data Interface = Interface-    { interfaceName :: T.InterfaceName-    , interfaceMethods :: [Method]-    , interfaceSignals :: [Signal]-    , interfaceProperties :: [Property]-    }-    deriving (Show, Eq)--data Method = Method-    { methodName :: T.MemberName-    , methodArgs :: [MethodArg]-    }-    deriving (Show, Eq)--data MethodArg = MethodArg-    { methodArgName :: String-    , methodArgType :: T.Type-    , methodArgDirection :: Direction-    }-    deriving (Show, Eq)--data Direction = In | Out-    deriving (Show, Eq)--data Signal = Signal-    { signalName :: T.MemberName-    , signalArgs :: [SignalArg]-    }-    deriving (Show, Eq)--data SignalArg = SignalArg-    { signalArgName :: String-    , signalArgType :: T.Type-    }-    deriving (Show, Eq)--data Property = Property-    { propertyName :: String-    , propertyType :: T.Type-    , propertyRead :: Bool-    , propertyWrite :: Bool-    }-    deriving (Show, Eq)--data ObjectChildren-    = InterfaceDefinition Interface-    | SubNode Object--data InterfaceChildren-    = MethodDefinition Method-    | SignalDefinition Signal-    | PropertyDefinition Property--parseXML :: T.ObjectPath -> String -> Maybe Object-parseXML path xml =-    runConduit $ X.parseLBS X.def (BL8.pack xml) .| X.force "parse error" (parseObject $ getRootName path)--getRootName :: T.ObjectPath -> X.AttrParser T.ObjectPath-getRootName defaultPath = do-    nodeName <- X.attr "name"-    pure $ maybe defaultPath (T.objectPath_ . Text.unpack) nodeName--getChildName :: T.ObjectPath -> X.AttrParser T.ObjectPath-getChildName parentPath = do-    nodeName <- X.requireAttr "name"-    let parentPath' = case T.formatObjectPath parentPath of-            "/" -> "/"-            x   -> x ++ "/"-    pure $ T.objectPath_ (parentPath' ++ Text.unpack nodeName)--parseObject-    :: X.AttrParser T.ObjectPath-    -> ConduitT Event o Maybe (Maybe Object)-parseObject getPath = X.tag' "node" getPath parseContent-  where-    parseContent objPath = do-        elems <- X.many $ X.choose-            [ fmap SubNode <$> parseObject (getChildName objPath)-            , fmap InterfaceDefinition <$> parseInterface-            ]-        let base = Object objPath [] []-            addElem e (Object p is cs) = case e of-                InterfaceDefinition i -> Object p (i:is) cs-                SubNode c -> Object p is (c:cs)-        pure $ foldr addElem base elems--parseInterface-    :: ConduitT Event o Maybe (Maybe Interface)-parseInterface = X.tag' "interface" getName parseContent-  where-    getName = do-        ifName <- X.requireAttr "name"-        pure $ T.interfaceName_ (Text.unpack ifName)-    parseContent ifName = do-        elems <- X.many $ X.choose-            [ parseMethod-            , parseSignal-            , parseProperty-            ]-        let base = Interface ifName [] [] []-            addElem e (Interface n ms ss ps) = case e of-                MethodDefinition m -> Interface n (m:ms) ss ps-                SignalDefinition s -> Interface n ms (s:ss) ps-                PropertyDefinition p -> Interface n ms ss (p:ps)-        pure $ foldr addElem base elems--parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)-parseMethod = X.tag' "method" getName parseArgs-  where-    getName = do-        ifName <- X.requireAttr "name"-        T.parseMemberName (Text.unpack ifName)-    parseArgs name = do-        args <- X.many $-            X.tag' "arg" getArg pure-        pure $ MethodDefinition $ Method name args-    getArg = do-        name <- fromMaybe "" <$> X.attr "name"-        typeStr <- X.requireAttr "type"-        dirStr <- fromMaybe "in" <$> X.attr "direction"-        X.ignoreAttrs-        typ <- parseType typeStr-        let dir = if dirStr == "in" then In else Out-        pure $ MethodArg (Text.unpack name) typ dir--parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)-parseSignal = X.tag' "signal" getName parseArgs-  where-    getName = do-        ifName <- X.requireAttr "name"-        T.parseMemberName (Text.unpack ifName)-    parseArgs name = do-        args <- X.many $-            X.tag' "arg" getArg pure-        pure $ SignalDefinition $ Signal name args-    getArg = do-        name <- fromMaybe "" <$> X.attr "name"-        typeStr <- X.requireAttr "type"-        X.ignoreAttrs-        typ <- parseType typeStr-        pure $ SignalArg (Text.unpack name) typ--parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)-parseProperty = X.tag' "property" getProp $ \p -> do-    X.many_ X.ignoreAnyTreeContent-    pure p-  where-    getProp = do-        name <- Text.unpack <$> X.requireAttr "name"-        typeStr <- X.requireAttr "type"-        accessStr <- fromMaybe "" <$> X.attr "access"-        X.ignoreAttrs-        typ <- parseType typeStr-        (canRead, canWrite) <- case accessStr of-            ""          -> pure (False, False)-            "read"      -> pure (True, False)-            "write"     -> pure (False, True)-            "readwrite" -> pure (True, True)-            _           -> throwM $ userError "invalid access value"--        pure $ PropertyDefinition $ Property name typ canRead canWrite--parseType :: MonadThrow m => Text.Text -> m T.Type-parseType typeStr = do-    typ <- T.parseSignature (Text.unpack typeStr)-    case T.signatureTypes typ of-        [t] -> pure t-        _ -> throwM $ userError "invalid type sig"--newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, String) }--instance Functor XmlWriter where-    fmap = liftM--instance Control.Applicative.Applicative XmlWriter where-    pure = return-    (<*>) = ap--instance Monad XmlWriter where-    return a = XmlWriter $ Just (a, "")-    m >>= f = XmlWriter $ do-        (a, w) <- runXmlWriter m-        (b, w') <- runXmlWriter (f a)-        return (b, w ++ w')--tell :: String -> XmlWriter ()-tell s = XmlWriter (Just ((), s))--formatXML :: Object -> Maybe String-formatXML obj = do-    (_, xml) <- runXmlWriter (writeRoot obj)-    return xml--writeRoot :: Object -> XmlWriter ()-writeRoot obj@(Object path _ _) = do-    tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'"-    tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n"-    writeObject (T.formatObjectPath path) obj--writeChild :: T.ObjectPath -> Object -> XmlWriter ()-writeChild parentPath obj@(Object path _ _) = write where-    path' = T.formatObjectPath path-    parent' = T.formatObjectPath  parentPath-    relpathM = if parent' `isPrefixOf` path'-        then Just $ if parent' == "/"-            then drop 1 path'-            else drop (length parent' + 1) path'-        else Nothing--    write = case relpathM of-        Just relpath -> writeObject relpath obj-        Nothing -> XmlWriter Nothing--writeObject :: String -> Object -> XmlWriter ()-writeObject path (Object fullPath interfaces children') = writeElement "node"-    [("name", path)] $ do-        mapM_ writeInterface interfaces-        mapM_ (writeChild fullPath) children'--writeInterface :: Interface -> XmlWriter ()-writeInterface (Interface name methods signals properties) = writeElement "interface"-    [("name", T.formatInterfaceName name)] $ do-        mapM_ writeMethod methods-        mapM_ writeSignal signals-        mapM_ writeProperty properties--writeMethod :: Method -> XmlWriter ()-writeMethod (Method name args) = writeElement "method"-    [("name", T.formatMemberName name)] $-        mapM_ writeMethodArg args--writeSignal :: Signal -> XmlWriter ()-writeSignal (Signal name args) = writeElement "signal"-    [("name", T.formatMemberName name)] $-        mapM_ writeSignalArg args--formatType :: T.Type -> XmlWriter String-formatType t = do-    sig <- case T.signature [t] of-        Just x -> return x-        Nothing -> XmlWriter Nothing-    return (T.formatSignature sig)--writeMethodArg :: MethodArg -> XmlWriter ()-writeMethodArg (MethodArg name t dir) = do-    typeStr <- formatType t-    let dirAttr = case dir of-            In -> "in"-            Out -> "out"-    writeEmptyElement "arg"-        [ ("name", name)-        , ("type", typeStr)-        , ("direction", dirAttr)-        ]--writeSignalArg :: SignalArg -> XmlWriter ()-writeSignalArg (SignalArg name t) = do-    typeStr <- formatType t-    writeEmptyElement "arg"-        [ ("name", name)-        , ("type", typeStr)-        ]--writeProperty :: Property -> XmlWriter ()-writeProperty (Property name t canRead canWrite) = do-    typeStr <- formatType t-    let readS = if canRead then "read" else ""-    let writeS = if canWrite then "write" else ""-    writeEmptyElement "property"-        [ ("name", name)-        , ("type", typeStr)-        , ("access", readS ++ writeS)-        ]----attributeString :: X.Name -> X.Element -> Maybe String---attributeString name e = fmap Data.Text.unpack (X.attributeText name e)--writeElement :: String -> [(String, String)] -> XmlWriter () -> XmlWriter ()-writeElement name attrs content = do-    tell "<"-    tell name-    mapM_ writeAttribute attrs-    tell ">"-    content-    tell "</"-    tell name-    tell ">"--writeEmptyElement :: String -> [(String, String)] -> XmlWriter ()-writeEmptyElement name attrs = do-    tell "<"-    tell name-    mapM_ writeAttribute attrs-    tell "/>"--writeAttribute :: (String, String) -> XmlWriter ()-writeAttribute (name, content) = do-    tell " "-    tell name-    tell "='"-    tell (escape content)-    tell "'"--escape :: String -> String-escape = concatMap $ \c -> case c of-    '&' -> "&amp;"-    '<' -> "&lt;"-    '>' -> "&gt;"-    '"' -> "&quot;"-    '\'' -> "&apos;"-    _ -> [c]+import DBus.Introspection.Types as X+import DBus.Introspection.Parse as X+import DBus.Introspection.Render as X

@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++module DBus.Introspection.Parse+    ( parseXML+    ) where++import Conduit+import Data.Maybe+import Data.XML.Types+import qualified Data.Text as T+import qualified Text.XML.Stream.Parse as X++import DBus.Internal.Types+import DBus.Introspection.Types++data ObjectChildren+    = InterfaceDefinition Interface+    | SubNode Object++data InterfaceChildren+    = MethodDefinition Method+    | SignalDefinition Signal+    | PropertyDefinition Property++parseXML :: ObjectPath -> T.Text -> Maybe Object+parseXML path xml =+    runConduit $ yieldMany [xml] .| X.parseText' X.def .| X.force "parse error" (parseObject $ getRootName path)++getRootName :: ObjectPath -> X.AttrParser ObjectPath+getRootName defaultPath = do+    nodeName <- X.attr "name"+    pure $ maybe defaultPath (objectPath_ . T.unpack) nodeName++getChildName :: ObjectPath -> X.AttrParser ObjectPath+getChildName parentPath = do+    nodeName <- X.requireAttr "name"+    let parentPath' = case formatObjectPath parentPath of+            "/" -> "/"+            x   -> x ++ "/"+    pure $ objectPath_ (parentPath' ++ T.unpack nodeName)++parseObject+    :: X.AttrParser ObjectPath+    -> ConduitT Event o Maybe (Maybe Object)+parseObject getPath = X.tag' "node" getPath parseContent+  where+    parseContent objPath = do+        elems <- X.many $ X.choose+            [ fmap SubNode <$> parseObject (getChildName objPath)+            , fmap InterfaceDefinition <$> parseInterface+            ]+        let base = Object objPath [] []+            addElem e (Object p is cs) = case e of+                InterfaceDefinition i -> Object p (i:is) cs+                SubNode c -> Object p is (c:cs)+        pure $ foldr addElem base elems++parseInterface+    :: ConduitT Event o Maybe (Maybe Interface)+parseInterface = X.tag' "interface" getName parseContent+  where+    getName = do+        ifName <- X.requireAttr "name"+        pure $ interfaceName_ (T.unpack ifName)+    parseContent ifName = do+        elems <- X.many $ do+            X.many_ $ X.ignoreTreeContent "annotation"+            X.choose+                [ parseMethod+                , parseSignal+                , parseProperty+                ]+        X.many_ $ X.ignoreTreeContent "annotation"+        let base = Interface ifName [] [] []+            addElem e (Interface n ms ss ps) = case e of+                MethodDefinition m -> Interface n (m:ms) ss ps+                SignalDefinition s -> Interface n ms (s:ss) ps+                PropertyDefinition p -> Interface n ms ss (p:ps)+        pure $ foldr addElem base elems++parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseMethod = X.tag' "method" getName parseArgs+  where+    getName = do+        ifName <- X.requireAttr "name"+        parseMemberName (T.unpack ifName)+    parseArgs name = do+        args <- X.many $ do+            X.many_ $ X.ignoreTreeContent "annotation"+            X.tag' "arg" getArg pure+        X.many_ $ X.ignoreTreeContent "annotation"+        pure $ MethodDefinition $ Method name args+    getArg = do+        name <- fromMaybe "" <$> X.attr "name"+        typeStr <- X.requireAttr "type"+        dirStr <- fromMaybe "in" <$> X.attr "direction"+        X.ignoreAttrs+        typ <- parseType typeStr+        let dir = if dirStr == "in" then In else Out+        pure $ MethodArg (T.unpack name) typ dir++parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseSignal = X.tag' "signal" getName parseArgs+  where+    getName = do+        ifName <- X.requireAttr "name"+        parseMemberName (T.unpack ifName)+    parseArgs name = do+        args <- X.many $ do+            X.many_ $ X.ignoreTreeContent "annotation"+            X.tag' "arg" getArg pure+        X.many_ $ X.ignoreTreeContent "annotation"+        pure $ SignalDefinition $ Signal name args+    getArg = do+        name <- fromMaybe "" <$> X.attr "name"+        typeStr <- X.requireAttr "type"+        X.ignoreAttrs+        typ <- parseType typeStr+        pure $ SignalArg (T.unpack name) typ++parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseProperty = X.tag' "property" getProp $ \p -> do+    X.many_ X.ignoreAnyTreeContent+    pure p+  where+    getProp = do+        name <- T.unpack <$> X.requireAttr "name"+        typeStr <- X.requireAttr "type"+        accessStr <- fromMaybe "" <$> X.attr "access"+        X.ignoreAttrs+        typ <- parseType typeStr+        (canRead, canWrite) <- case accessStr of+            ""          -> pure (False, False)+            "read"      -> pure (True, False)+            "write"     -> pure (False, True)+            "readwrite" -> pure (True, True)+            _           -> throwM $ userError "invalid access value"++        pure $ PropertyDefinition $ Property name typ canRead canWrite++parseType :: MonadThrow m => T.Text -> m Type+parseType typeStr = do+    typ <- parseSignature (T.unpack typeStr)+    case signatureTypes typ of+        [t] -> pure t+        _ -> throwM $ userError "invalid type sig"

@@ -0,0 +1,108 @@+{-# 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 { 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 _ = Render $ MaybeT $ pure Nothing++instance PrimMonad (Render s) where+    type PrimState (Render s) = s+    primitive f = Render $ lift $ primitive f++formatXML :: Object -> Maybe String+formatXML obj = do+    xml <- runST $ runMaybeT $ runRender $ runConduit $+        renderRoot obj .| R.renderText (R.def {R.rsPretty = True}) .| sinkLazy+    pure $ TL.unpack xml++renderRoot :: MonadThrow m => Object -> ConduitT i Event m ()+renderRoot obj = renderObject (formatObjectPath $ objectPath obj) obj++renderObject :: MonadThrow m => String -> Object -> ConduitT i Event m ()+renderObject path Object{..} = R.tag "node"+    (R.attr "name" (T.pack path)) $ do+    mapM_ renderInterface objectInterfaces+    mapM_ (renderChild objectPath) objectChildren++renderChild :: MonadThrow m => ObjectPath -> Object -> ConduitT i Event m ()+renderChild parentPath obj+    | not (parent' `isPrefixOf` path') =+        throwM $ userError "invalid child path"+    | parent' == "/" = renderObject (drop 1 path') obj+    | otherwise = renderObject (drop (length parent' + 1) path') obj+  where+    path' = formatObjectPath (objectPath obj)+    parent' = formatObjectPath parentPath++renderInterface :: MonadThrow m => Interface -> ConduitT i Event m ()+renderInterface Interface{..} = R.tag "interface"+    (R.attr "name" $ T.pack $ formatInterfaceName interfaceName) $ do+        mapM_ renderMethod interfaceMethods+        mapM_ renderSignal interfaceSignals+        mapM_ renderProperty interfaceProperties++renderMethod :: MonadThrow m => Method -> ConduitT i Event m ()+renderMethod Method{..} = R.tag "method"+    (R.attr "name" $ T.pack $ formatMemberName methodName) $+        mapM_ renderMethodArg methodArgs++renderMethodArg :: MonadThrow m => MethodArg -> ConduitT i Event m ()+renderMethodArg MethodArg{..} = do+    typeStr <- formatType methodArgType+    let typeAttr = R.attr "type" $ T.pack typeStr+        nameAttr = R.attr "name" $ T.pack methodArgName+        dirAttr = R.attr "direction" $ case methodArgDirection of+            In -> "in"+            Out -> "out"+    R.tag "arg" (nameAttr <> typeAttr <> dirAttr) $ pure ()++renderSignal :: MonadThrow m => Signal -> ConduitT i Event m ()+renderSignal Signal{..} = R.tag "signal"+    (R.attr "name" $ T.pack $ formatMemberName signalName) $+        mapM_ renderSignalArg signalArgs++renderSignalArg :: MonadThrow m => SignalArg -> ConduitT i Event m ()+renderSignalArg SignalArg{..} = do+    typeStr <- formatType signalArgType+    let typeAttr = R.attr "type" $ T.pack typeStr+        nameAttr = R.attr "name" $ T.pack signalArgName+    R.tag "arg" (nameAttr <> typeAttr) $ pure ()++renderProperty :: MonadThrow m => Property -> ConduitT i Event m ()+renderProperty Property{..} = do+    typeStr <- formatType propertyType+    let readStr = if propertyRead then "read" else ""+        writeStr = if propertyWrite then "write" else ""+        typeAttr = R.attr "type" $ T.pack typeStr+        nameAttr = R.attr "name" $ T.pack propertyName+        accessAttr = R.attr "access" $ T.pack (readStr ++ writeStr)+    R.tag "property" (nameAttr <> typeAttr <> accessAttr) $ pure ()++formatType :: MonadThrow f => Type -> f String+formatType t = formatSignature <$> signature [t]

@@ -0,0 +1,54 @@+module DBus.Introspection.Types where++import qualified DBus as T++data Object = Object+    { objectPath :: T.ObjectPath+    , objectInterfaces :: [Interface]+    , objectChildren :: [Object]+    }+    deriving (Show, Eq)++data Interface = Interface+    { interfaceName :: T.InterfaceName+    , interfaceMethods :: [Method]+    , interfaceSignals :: [Signal]+    , interfaceProperties :: [Property]+    }+    deriving (Show, Eq)++data Method = Method+    { methodName :: T.MemberName+    , methodArgs :: [MethodArg]+    }+    deriving (Show, Eq)++data MethodArg = MethodArg+    { methodArgName :: String+    , methodArgType :: T.Type+    , methodArgDirection :: Direction+    }+    deriving (Show, Eq)++data Direction = In | Out+    deriving (Show, Eq)++data Signal = Signal+    { signalName :: T.MemberName+    , signalArgs :: [SignalArg]+    }+    deriving (Show, Eq)++data SignalArg = SignalArg+    { signalArgName :: String+    , signalArgType :: T.Type+    }+    deriving (Show, Eq)++data Property = Property+    { propertyName :: String+    , propertyType :: T.Type+    , propertyRead :: Bool+    , propertyWrite :: Bool+    }+    deriving (Show, Eq)

@@ -44,7 +44,9 @@ import DBus.Internal.Message () import DBus.Internal.Types () import DBus.Internal.Wire ()-import DBus.Introspection ()+import DBus.Introspection.Parse ()+import DBus.Introspection.Render ()+import DBus.Introspection.Types () import DBus.Socket ()  tests :: TestTree

@@ -25,7 +25,8 @@ import DBus import qualified DBus.Client import qualified DBus.Socket-import DBus.Introspection+import DBus.Introspection.Parse+import DBus.Introspection.Types import DBus.Internal.Types  import DBusTests.Util

@@ -4,7 +4,7 @@  import           DBus.Client import qualified DBus.Internal.Types as T-import qualified DBus.Introspection as I+import qualified DBus.Introspection.Types as I import           Data.Int import           Data.Map as M 

@@ -21,9 +21,12 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck+import qualified Data.Text as T  import DBus-import qualified DBus.Introspection as I+import qualified DBus.Introspection.Parse as I+import qualified DBus.Introspection.Render as I+import qualified DBus.Introspection.Types as I  import DBusTests.InterfaceName () import DBusTests.MemberName ()@@ -43,7 +46,7 @@ test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let     path = I.objectPath obj     Just xml = I.formatXML obj-    in I.parseXML path xml == Just obj+    in I.parseXML path (T.pack xml) == Just obj  buildEmptyObject :: String -> I.Object buildEmptyObject name = I.Object (objectPath_ name) [] []