Hello community, here is the log from the commit of package ghc-dbus for openSUSE:Factory checked in at 2018-12-21 08:21:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-dbus (Old) and /work/SRC/openSUSE:Factory/.ghc-dbus.new.28833 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-dbus" Fri Dec 21 08:21:07 2018 rev:4 rq:658074 version:1.2.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-dbus/ghc-dbus.changes 2018-12-06 12:16:53.489547209 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-dbus.new.28833/ghc-dbus.changes 2018-12-21 08:21:24.833570297 +0100 @@ -1,0 +2,6 @@ +Sun Dec 9 03:01:26 UTC 2018 - [email protected] + +- Update dbus to version 1.2.1. + Upstream does not provide a change log file. + +------------------------------------------------------------------- Old: ---- dbus-1.1.1.tar.gz New: ---- dbus-1.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-dbus.spec ++++++ --- /var/tmp/diff_new_pack.ZQ6jT1/_old 2018-12-21 08:21:25.277569881 +0100 +++ /var/tmp/diff_new_pack.ZQ6jT1/_new 2018-12-21 08:21:25.281569877 +0100 @@ -19,7 +19,7 @@ %global pkg_name dbus %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.1.1 +Version: 1.2.1 Release: 0 Summary: A client library for the D-Bus IPC system License: Apache-2.0 ++++++ dbus-1.1.1.tar.gz -> dbus-1.2.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/dbus.cabal new/dbus-1.2.1/dbus.cabal --- old/dbus-1.1.1/dbus.cabal 2018-11-25 04:17:02.000000000 +0100 +++ new/dbus-1.2.1/dbus.cabal 2018-12-08 02:18:35.000000000 +0100 @@ -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 <[email protected]> @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Client.hs new/dbus-1.2.1/lib/DBus/Client.hs --- old/dbus-1.1.1/lib/DBus/Client.hs 2018-05-05 06:09:43.000000000 +0200 +++ new/dbus-1.2.1/lib/DBus/Client.hs 2018-12-08 02:16:42.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Generation.hs new/dbus-1.2.1/lib/DBus/Generation.hs --- old/dbus-1.1.1/lib/DBus/Generation.hs 2018-11-23 06:10:28.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Generation.hs 2018-12-08 02:16:42.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Internal/Types.hs new/dbus-1.2.1/lib/DBus/Internal/Types.hs --- old/dbus-1.1.1/lib/DBus/Internal/Types.hs 2018-11-23 05:51:25.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Internal/Types.hs 2018-12-08 02:16:42.000000000 +0100 @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2009-2012 John Millikin <[email protected]> @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Introspection/Parse.hs new/dbus-1.2.1/lib/DBus/Introspection/Parse.hs --- old/dbus-1.1.1/lib/DBus/Introspection/Parse.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Introspection/Parse.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Introspection/Render.hs new/dbus-1.2.1/lib/DBus/Introspection/Render.hs --- old/dbus-1.1.1/lib/DBus/Introspection/Render.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Introspection/Render.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Introspection/Types.hs new/dbus-1.2.1/lib/DBus/Introspection/Types.hs --- old/dbus-1.1.1/lib/DBus/Introspection/Types.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Introspection/Types.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus/Introspection.hs new/dbus-1.2.1/lib/DBus/Introspection.hs --- old/dbus-1.1.1/lib/DBus/Introspection.hs 2018-11-25 04:06:48.000000000 +0100 +++ new/dbus-1.2.1/lib/DBus/Introspection.hs 2018-12-02 02:37:38.000000000 +0100 @@ -1,361 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2009-2012 John Millikin <[email protected]> --- --- 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 - '&' -> "&" - '<' -> "<" - '>' -> ">" - '"' -> """ - '\'' -> "'" - _ -> [c] +import DBus.Introspection.Types as X +import DBus.Introspection.Parse as X +import DBus.Introspection.Render as X diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/lib/DBus.hs new/dbus-1.2.1/lib/DBus.hs --- old/dbus-1.1.1/lib/DBus.hs 2018-05-05 06:09:43.000000000 +0200 +++ new/dbus-1.2.1/lib/DBus.hs 2018-12-08 02:16:42.000000000 +0100 @@ -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,14 +180,18 @@ 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. -- -- Use fields such as 'methodCallDestination' and 'methodCallBody' to populate diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/tests/DBusTests/Client.hs new/dbus-1.2.1/tests/DBusTests/Client.hs --- old/dbus-1.1.1/tests/DBusTests/Client.hs 2018-11-23 06:16:12.000000000 +0100 +++ new/dbus-1.2.1/tests/DBusTests/Client.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/tests/DBusTests/Generation.hs new/dbus-1.2.1/tests/DBusTests/Generation.hs --- old/dbus-1.1.1/tests/DBusTests/Generation.hs 2018-05-05 06:09:43.000000000 +0200 +++ new/dbus-1.2.1/tests/DBusTests/Generation.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/tests/DBusTests/Introspection.hs new/dbus-1.2.1/tests/DBusTests/Introspection.hs --- old/dbus-1.1.1/tests/DBusTests/Introspection.hs 2018-11-23 06:15:58.000000000 +0100 +++ new/dbus-1.2.1/tests/DBusTests/Introspection.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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) [] [] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.1.1/tests/DBusTests.hs new/dbus-1.2.1/tests/DBusTests.hs --- old/dbus-1.1.1/tests/DBusTests.hs 2018-05-05 06:09:43.000000000 +0200 +++ new/dbus-1.2.1/tests/DBusTests.hs 2018-12-02 02:37:38.000000000 +0100 @@ -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
