dbus-core 0.8.3.1 → 0.8.4

raw patch · 30 files changed

+2885/−1378 lines, 30 filesdep +libxml-saxdep +xml-typesdep −HaXmldep −monads-tfdep −prettydep ~parsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: libxml-sax, xml-types

Dependencies removed: HaXml, monads-tf, pretty, transformers

Dependency ranges changed: parsec

API changes (from Hackage documentation)

Files

• dbus-core.cabal +6/−12
• hs/DBus/Address.hs +24/−2
• hs/DBus/Authentication.hs +39/−0
• hs/DBus/Bus.hs +48/−0
• hs/DBus/Connection.hs +117/−2
• hs/DBus/Constants.hs +12/−0
• hs/DBus/Introspection.hs +248/−133
• hs/DBus/MatchRule.hs +62/−0
• hs/DBus/Message.hs +26/−0
• hs/DBus/Message/Internal.hs +54/−0
• hs/DBus/NameReservation.hs +34/−0
• hs/DBus/Types.cpphs +0/−504
• hs/DBus/Types.hs +121/−0
• hs/DBus/Types/Internal.cpphs +706/−0
• hs/DBus/UUID.hs +10/−0
• hs/DBus/Util.hs +8/−2
• hs/DBus/Util/MonadError.hs +27/−25
• hs/DBus/Wire.hs +18/−0
• hs/DBus/Wire/Internal.hs +28/−0
• hs/DBus/Wire/Marshal.hs +215/−89
• hs/DBus/Wire/Unicode.hs +6/−0
• hs/DBus/Wire/Unmarshal.hs +230/−71
• hs/Tests.hs +88/−0
• src/addresses.anansi +2/−2
• src/authentication.anansi +1/−0
• src/connections.anansi +5/−2
• src/introspection.anansi +212/−176
• src/types.anansi +282/−160
• src/util.anansi +23/−27
• src/wire.anansi +233/−171

@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8.3.1+version: 0.8.4 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -34,18 +34,16 @@    build-depends:       base >=4.0 && < 5.0-    , parsec >= 3.0 && < 4+    , parsec >= 2.0 && < 3.2     , binary >= 0.4 && < 0.6     , bytestring >= 0.9 && < 0.10     , data-binary-ieee754 >= 0.3 && < 0.5-    , HaXml >= 1.20 && < 1.21-    , pretty >= 1.0 && < 1.1     , text >= 0.7 && < 0.8-    , transformers >= 0.2 && < 0.3-    , monads-tf >= 0.1 && < 0.2     , containers >= 0.1 && < 0.4     , unix >= 2.2 && < 2.5     , network >= 2.2 && < 2.3+    , libxml-sax >= 0.5 && < 0.6+    , xml-types >= 0.1 && < 0.2    exposed-modules:     DBus.Address@@ -63,6 +61,7 @@    other-modules:     DBus.Message.Internal+    DBus.Types.Internal     DBus.Wire.Internal     DBus.Wire.Marshal     DBus.Wire.Unmarshal@@ -86,11 +85,6 @@     ghc-options: -fhpc    other-modules:-    DBus.Address-    DBus.Constants-    DBus.Introspection-    DBus.Message-    DBus.Types-    DBus.Wire+    DBus.Types.Internal     DBus.Util 

@@ -1,3 +1,7 @@++#line 19 "src/addresses.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 20 "src/addresses.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 21 "src/addresses.anansi" module DBus.Address 	( Address 	, addressMethod@@ -20,17 +30,25 @@ 	, mkAddresses 	, strAddress 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/addresses.anansi"+ import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))+import qualified Text.ParserCombinators.Parsec as P+import Text.ParserCombinators.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe)++#line 74 "src/addresses.anansi" optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."++#line 82 "src/addresses.anansi" data Address = Address 	{ addressMethod     :: Text 	, addressParameters :: M.Map Text Text@@ -39,6 +57,8 @@ instance Show Address where 	showsPrec d x = showParen (d> 10) $ 		showString "Address " . shows (strAddress x)++#line 97 "src/addresses.anansi" mkAddresses :: Text -> Maybe [Address] mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where 	address = do@@ -63,6 +83,8 @@ 		P.char '%' 		hex <- P.count 2 P.hexDigit 		return . chr . hexToInt $ hex++#line 128 "src/addresses.anansi" strAddress :: Address -> Text strAddress (Address t ps) = TL.concat [t, ":", ps'] where 	ps' = TL.intercalate "," $ do

@@ -1,3 +1,7 @@++#line 27 "src/authentication.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 28 "src/authentication.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 29 "src/authentication.anansi" {-# LANGUAGE DeriveDataTypeable #-} module DBus.Authentication 	( Command@@ -21,31 +31,54 @@ 	, authenticate 	, realUserID 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++#line 38 "src/authentication.anansi"++#line 45 "src/authentication.anansi" import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString+import Data.ByteString.Lazy.Char8 () import qualified DBus.UUID as UUID++#line 61 "src/authentication.anansi" import Data.Typeable (Typeable) import qualified Control.Exception as E++#line 78 "src/authentication.anansi" import Data.Word (Word8)++#line 94 "src/authentication.anansi" import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd)++#line 115 "src/authentication.anansi" import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf)++#line 136 "src/authentication.anansi" import Data.Maybe (isJust)++#line 52 "src/authentication.anansi" type Command = Text newtype Mechanism = Mechanism 	{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID 	}++#line 66 "src/authentication.anansi" data AuthenticationError 	= AuthenticationError Text 	deriving (Show, Typeable)  instance E.Exception AuthenticationError++#line 82 "src/authentication.anansi" authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8              -> IO UUID.UUID authenticate mech put getByte = do@@ -53,12 +86,16 @@ 	uuid <- mechanismRun mech (putCommand put getByte) 	put "BEGIN\r\n" 	return uuid++#line 101 "src/authentication.anansi" putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command putCommand put get cmd = do 	let getC = liftM (chr . fromIntegral) get 	put $ encodeUtf8 cmd 	put "\r\n" 	liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC++#line 121 "src/authentication.anansi" realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do 	uid <- getRealUserID@@ -68,6 +105,8 @@ 	case eitherUUID of 		Right uuid -> return uuid 		Left err -> E.throwIO $ AuthenticationError err++#line 140 "src/authentication.anansi" checkOK :: Command -> Either Text UUID.UUID checkOK cmd = if validUUID then Right uuid else Left errorMsg where 	validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID

@@ -1,3 +1,7 @@++#line 19 "src/bus.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 20 "src/bus.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 21 "src/bus.anansi" module DBus.Bus 	( getBus 	, getFirstBus@@ -20,9 +30,13 @@ 	, getSessionBus 	, getStarterBus 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/bus.anansi"+ import qualified Control.Exception as E import Control.Monad (when) import Data.Maybe (fromJust, isNothing)@@ -36,36 +50,64 @@ import qualified DBus.Message as M import qualified DBus.Types as T import DBus.Util (fromRight)++#line 50 "src/bus.anansi" busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c ++#line 99 "src/api-docs.anansi" -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus.++#line 54 "src/bus.anansi" getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) getBus = ((busForConnection =<<) .) . C.connect++#line 62 "src/bus.anansi"++#line 104 "src/api-docs.anansi" -- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to -- the central bus.++#line 63 "src/bus.anansi" getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst++#line 74 "src/bus.anansi"++#line 109 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set.++#line 75 "src/bus.anansi" getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where 	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" 	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" 	noEnv (E.SomeException _) = return defaultAddr ++#line 116 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set.++#line 82 "src/bus.anansi" getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" ++#line 121 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set.++#line 86 "src/bus.anansi" getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"++#line 91 "src/bus.anansi" getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do 	addr <- fmap TL.pack io@@ -73,6 +115,8 @@ 		Just [x] -> getBus Auth.realUserID x 		Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] 		_        -> E.throwIO $ C.InvalidAddress addr++#line 103 "src/bus.anansi" hello :: M.MethodCall hello = M.MethodCall dbusPath 	"Hello"@@ -80,6 +124,8 @@ 	(Just dbusName) 	Set.empty 	[]++#line 113 "src/bus.anansi" sendHello :: C.Connection -> IO T.BusName sendHello c = do 	serial <- fromRight `fmap` C.send c return hello@@ -92,6 +138,8 @@ 		E.throwIO $ E.AssertionFailed "Invalid response to Hello()" 	 	return . fromJust $ name++#line 128 "src/bus.anansi" waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn waitForReply c serial = do 	received <- C.receive c

@@ -1,3 +1,7 @@++#line 19 "src/connections.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,39 +16,83 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 20 "src/connections.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 21 "src/connections.anansi" {-# LANGUAGE DeriveDataTypeable #-} module DBus.Connection (++#line 53 "src/connections.anansi" 	  Connection 	, connectionAddress 	, connectionUUID++#line 288 "src/connections.anansi" 	, ConnectionError (..)++#line 327 "src/connections.anansi" 	, connect 	, connectFirst++#line 340 "src/connections.anansi" 	, connectionClose++#line 370 "src/connections.anansi" 	, send++#line 394 "src/connections.anansi" 	, receive++#line 24 "src/connections.anansi" 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++#line 26 "src/connections.anansi"++#line 36 "src/connections.anansi" import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID++#line 75 "src/connections.anansi" import qualified Data.ByteString.Lazy as L import Data.Word (Word32)++#line 107 "src/connections.anansi" import qualified Network as N import qualified Data.Map as Map++#line 147 "src/connections.anansi" import qualified Network.Socket as NS-import qualified Text.Parsec as P++#line 193 "src/connections.anansi"+import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be)++#line 255 "src/connections.anansi" import qualified System.IO as I++#line 272 "src/connections.anansi" import qualified Control.Exception as E import Data.Typeable (Typeable)++#line 297 "src/connections.anansi" import qualified DBus.Authentication as Auth++#line 353 "src/connections.anansi" import qualified DBus.Wire as W++#line 43 "src/connections.anansi" data Connection = Connection 	{ connectionAddress    :: A.Address 	, connectionTransport  :: Transport@@ -52,23 +100,35 @@ 	, connectionReadMVar   :: C.MVar () 	, connectionUUID       :: UUID.UUID 	}++#line 62 "src/connections.anansi" instance Show Connection where 	showsPrec d con = showParen (d > 10) strCon where 		addr = A.strAddress $ connectionAddress con 		strCon = s "<Connection " . shows addr . s ">" 		s = showString++#line 80 "src/connections.anansi"++#line 59 "src/api-docs.anansi" -- | A 'Transport' is anything which can send and receive bytestrings, -- typically via a socket.++#line 81 "src/connections.anansi" data Transport = Transport 	{ transportSend :: L.ByteString -> IO () 	, transportRecv :: Word32 -> IO L.ByteString 	, transportClose :: IO () 	}++#line 92 "src/connections.anansi" connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where 	transport' "unix" = unix 	transport' "tcp"  = tcp 	transport' _      = E.throwIO . UnknownMethod++#line 112 "src/connections.anansi" unix :: A.Address -> IO Transport unix a = port >>= N.connectTo "localhost" >>= handleTransport where 	params = A.addressParameters a@@ -86,6 +146,8 @@ 		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew 		(Just x, Nothing) -> return $ TL.unpack x 		(Nothing, Just x) -> return $ '\x00' : TL.unpack x++#line 151 "src/connections.anansi" tcp :: A.Address -> IO Transport tcp a = openHandle >>= handleTransport where 	params = A.addressParameters a@@ -95,13 +157,19 @@ 		addresses <- getAddresses family 		socket <- openSocket port addresses 		NS.socketToHandle socket I.ReadWriteMode++#line 165 "src/connections.anansi" 	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params++#line 169 "src/connections.anansi" 	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] 	getFamily = case Map.lookup "family" params of 		Just "ipv4" -> return NS.AF_INET 		Just "ipv6" -> return NS.AF_INET6 		Nothing     -> return NS.AF_UNSPEC 		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x++#line 178 "src/connections.anansi" 	missingPort = "TCP transport requires the ``port'' parameter." 	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] 	getPort = case Map.lookup "port" params of@@ -109,14 +177,21 @@ 		Just x -> case P.parse parseWord16 "" (TL.unpack x) of 			Right x' -> return $ NS.PortNum x' 			Left  _  -> E.throwIO $ BadParameters a $ badPort x++#line 200 "src/connections.anansi" 	parseWord16 = do 		chars <- P.many1 P.digit 		P.eof 		let value = read chars :: Integer 		unless (value > 0 && value <= 65535) $-			P.parserFail "bad port" >> return ()+			-- Calling 'fail' is acceptable here, because Parsec 2+			-- offers no other error reporting mechanism, and+			-- implements 'fail'.+			fail "bad port" 		let word = fromIntegral value 		return $ runGet getWord16host (runPut (putWord16be word))++#line 214 "src/connections.anansi" 	getAddresses family = do 		let hints = NS.defaultHints 			{ NS.addrFlags = [NS.AI_ADDRCONFIG]@@ -124,9 +199,13 @@ 			, NS.addrSocketType = NS.Stream 			} 		NS.getAddrInfo (Just hints) (Just hostname) Nothing++#line 228 "src/connections.anansi" 	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x 	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z 	setPort _    addr                       = addr++#line 238 "src/connections.anansi" 	openSocket _ [] = E.throwIO $ NoWorkingAddress [a] 	openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ 		\(E.SomeException _) -> openSocket port addrs@@ -136,11 +215,15 @@ 		                  (NS.addrProtocol addr) 		NS.connect sock . setPort port . NS.addrAddress $ addr 		return sock++#line 259 "src/connections.anansi" handleTransport :: I.Handle -> IO Transport handleTransport h = do 	I.hSetBuffering h I.NoBuffering 	I.hSetBinaryMode h True 	return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h)++#line 277 "src/connections.anansi" data ConnectionError 	= InvalidAddress Text 	| BadParameters A.Address Text@@ -149,8 +232,14 @@ 	deriving (Show, Typeable)  instance E.Exception ConnectionError++#line 301 "src/connections.anansi"++#line 64 "src/api-docs.anansi" -- | Open a connection to some address, using a given authentication -- mechanism. If the connection fails, a 'ConnectionError' will be thrown.++#line 302 "src/connections.anansi" connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do 	t <- connectTransport a@@ -159,18 +248,34 @@ 	readLock <- C.newMVar () 	serialMVar <- C.newMVar M.firstSerial 	return $ Connection a t serialMVar readLock uuid++#line 317 "src/connections.anansi"++#line 69 "src/api-docs.anansi" -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened.++#line 318 "src/connections.anansi" connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where 	allAddrs = [a | (_, a) <- orig] 	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs 	connectFirst' ((mech, a):as) = E.catch (connect mech a) $ 		\(E.SomeException _) -> connectFirst' as++#line 334 "src/connections.anansi"++#line 74 "src/api-docs.anansi" -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used.++#line 335 "src/connections.anansi" connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport++#line 357 "src/connections.anansi"++#line 79 "src/api-docs.anansi" -- | Send a single message, with a generated 'M.Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it -- receives the serial the message /will/ be sent with, before it's actually@@ -179,6 +284,8 @@ -- Only one message may be sent at a time; if multiple threads attempt to -- send messages in parallel, one will block until after the other has -- finished.++#line 358 "src/connections.anansi" send :: M.Message a => Connection -> (M.Serial -> IO b) -> a      -> IO (Either W.MarshalError b) send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial ->@@ -188,6 +295,8 @@ 			transportSend t bytes 			return $ Right x 		Left  err   -> return $ Left err++#line 374 "src/connections.anansi" withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do 	s <- C.takeMVar m@@ -195,12 +304,18 @@ 	x <- E.unblock (io s) `E.onException` C.putMVar m s' 	C.putMVar m s' 	return x++#line 387 "src/connections.anansi"++#line 90 "src/api-docs.anansi" -- | Receive the next message from the connection, blocking until one is -- available. -- -- Only one message may be received at a time; if multiple threads attempt -- to receive messages in parallel, one will block until after the other has -- finished.++#line 388 "src/connections.anansi" receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> 	W.unmarshalMessage $ transportRecv t

@@ -1,3 +1,7 @@++#line 19 "src/constants.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +16,8 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 20 "src/constants.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T@@ -25,6 +31,8 @@  arrayMaximumLength :: Word32 arrayMaximumLength = 67108864++#line 38 "src/constants.anansi" dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -33,6 +41,8 @@  dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus"++#line 51 "src/constants.anansi" interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -41,6 +51,8 @@  interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer"++#line 64 "src/constants.anansi" errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed" 

@@ -1,3 +1,7 @@++#line 44 "src/introspection.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 45 "src/introspection.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 46 "src/introspection.anansi" module DBus.Introspection 	( Object (..) 	, Interface (..)@@ -24,16 +34,28 @@ 	, toXML 	, fromXML 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL-import qualified Text.XML.HaXml as H-import Text.XML.HaXml.Parse (xmlParse')-import DBus.Util (eitherToMaybe)-import Data.Char (chr)-import Data.Maybe (fromMaybe)-import Text.XML.HaXml.Pretty (document)-import Text.PrettyPrint.HughesPJ (render)++#line 58 "src/introspection.anansi"++#line 105 "src/introspection.anansi"+import qualified Data.XML.Types as X+import qualified Text.XML.LibXML.SAX as SAX+import Control.Monad.ST (runST)+import qualified Data.STRef as ST+import Data.Text.Encoding (encodeUtf8)++#line 254 "src/introspection.anansi"+import Control.Monad ((>=>))+import Data.Maybe (fromMaybe, listToMaybe)++#line 59 "src/introspection.anansi" import qualified DBus.Types as T++#line 65 "src/introspection.anansi" data Object = Object T.ObjectPath [Interface] [Object] 	deriving (Show, Eq) @@ -54,176 +76,269 @@  data PropertyAccess = Read | Write 	deriving (Show, Eq)++#line 94 "src/introspection.anansi" fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do-	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text-	let (H.Document _ _ root _) = doc+	root <- parseElement text 	parseRoot path root-parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object++#line 113 "src/introspection.anansi"+parseElement :: Text -> Maybe X.Element+parseElement text = runST $ do+	stackRef <- ST.newSTRef [([], [])]+	let callbacks = SAX.ParserCallbacks+		{ SAX.parsedBeginElement = \_ attrs -> do+			ST.modifySTRef stackRef ((attrs, []):)+		, SAX.parsedEndElement = \name -> do+			stack <- ST.readSTRef stackRef+			let (attrs, children'):stack' = stack+			let e = X.Element name attrs (map X.NodeElement (reverse children'))+			let (pAttrs, pChildren):stack'' = stack'+			let parent = (pAttrs, e:pChildren)+			ST.writeSTRef stackRef (parent:stack'')+		, SAX.parsedCharacters = \_ -> return ()+		, SAX.parsedComment = \_ -> return ()+		, SAX.parsedProcessingInstruction = \_ -> return ()+		}+	let onError _ = ST.writeSTRef stackRef []+	p <- SAX.newParser callbacks onError Nothing+	mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text+	SAX.parseComplete p+	stack <- ST.readSTRef stackRef+	return $ case stack of+		[] -> Nothing+		(_, children'):_ -> Just $ head children'++#line 148 "src/introspection.anansi"+parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do-	path <- case getAttr "name" e of+	path <- case getattrM "name" e of 		Nothing -> Just defaultPath 		Just x  -> T.mkObjectPath x-	parseObject' path e-parseChild :: T.ObjectPath -> H.Element a -> Maybe Object+	parseObject path e++#line 161 "src/introspection.anansi"+parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do 	let parentPath' = case T.strObjectPath parentPath of 		"/" -> "/" 		x   -> TL.append x "/"-	pathSegment <- getAttr "name" e+	pathSegment <- getattrM "name" e 	path <- T.mkObjectPath $ TL.append parentPath' pathSegment-	parseObject' path e-parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object-parseObject' path e@(H.Elem "node" _ _)  = do-	interfaces <- children parseInterface (H.tag "interface") e-	children' <- children (parseChild path) (H.tag "node") e+	parseObject path e++#line 175 "src/introspection.anansi"+parseObject :: T.ObjectPath -> X.Element -> Maybe Object+parseObject path e | X.elementName e == toName "node" = do+	interfaces <- children parseInterface (named "interface") e+	children' <- children (parseChild path) (named "node") e 	return $ Object path interfaces children'-parseObject' _ _ = Nothing-parseInterface :: H.Element a -> Maybe Interface+parseObject _ _ = Nothing++#line 186 "src/introspection.anansi"+parseInterface :: X.Element -> Maybe Interface parseInterface e = do-	name <- T.mkInterfaceName =<< getAttr "name" e-	methods <- children parseMethod (H.tag "method") e-	signals <- children parseSignal (H.tag "signal") e-	properties <- children parseProperty (H.tag "property") e+	name <- T.mkInterfaceName =<< getattrM "name" e+	methods <- children parseMethod (named "method") e+	signals <- children parseSignal (named "signal") e+	properties <- children parseProperty (named "property") e 	return $ Interface name methods signals properties-parseMethod :: H.Element a -> Maybe Method++#line 199 "src/introspection.anansi"+parseMethod :: X.Element -> Maybe Method parseMethod e = do-	name <- T.mkMemberName =<< getAttr "name" e+	name <- T.mkMemberName =<< getattrM "name" e 	paramsIn <- children parseParameter (isParam ["in", ""]) e 	paramsOut <- children parseParameter (isParam ["out"]) e 	return $ Method name paramsIn paramsOut-parseSignal :: H.Element a -> Maybe Signal++#line 210 "src/introspection.anansi"+parseSignal :: X.Element -> Maybe Signal parseSignal e = do-	name <- T.mkMemberName =<< getAttr "name" e+	name <- T.mkMemberName =<< getattrM "name" e 	params <- children parseParameter (isParam ["out", ""]) e 	return $ Signal name params-parseParameter :: H.Element a -> Maybe Parameter++#line 220 "src/introspection.anansi"+parseParameter :: X.Element -> Maybe Parameter parseParameter e = do-	let name = getAttr' "name" e+	let name = getattr "name" e 	sig <- parseType e 	return $ Parameter name sig-parseType :: H.Element a -> Maybe T.Signature++#line 228 "src/introspection.anansi"+parseType :: X.Element -> Maybe T.Signature parseType e = do-	sig <- T.mkSignature =<< getAttr "type" e+	sig <- T.mkSignature =<< getattrM "type" e 	case T.signatureTypes sig of 		[_] -> Just sig 		_   -> Nothing-parseProperty :: H.Element a -> Maybe Property++#line 240 "src/introspection.anansi"+parseProperty :: X.Element -> Maybe Property parseProperty e = do-	let name = getAttr' "name" e+	let name = getattr "name" e 	sig <- parseType e-	access <- case getAttr' "access" e of+	access <- case getattr "access" e of 		""          -> Just [] 		"read"      -> Just [Read] 		"write"     -> Just [Write] 		"readwrite" -> Just [Read, Write] 		_           -> Nothing 	return $ Property name sig access-attrValue :: H.AttValue -> Maybe Text-attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where-	(H.AttValue parts) = attr-	-	unescape (Left x) = Just x-	unescape (Right (H.RefEntity x)) = lookup x namedRefs-	unescape (Right (H.RefChar x)) = Just [chr x]-	-	namedRefs =-		[ ("lt", "<")-		, ("gt", ">")-		, ("amp", "&")-		, ("apos", "'")-		, ("quot", "\"")-		]-getAttr :: String -> H.Element a -> Maybe Text-getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue -getAttr' :: String -> H.Element a -> Text-getAttr' = (fromMaybe "" .) . getAttr+#line 259 "src/introspection.anansi"+getattrM :: Text -> X.Element -> Maybe Text+getattrM name = fmap attrText . listToMaybe . attrs where+	attrText = textContent . X.attributeContent+	attrs = X.elementAttributes >=> X.isNamed (toName name)+	textContent cs = TL.concat [t | X.ContentText t <- cs] -isParam :: [Text] -> H.CFilter a-isParam dirs content = do-	arg@(H.CElem e _) <- H.tag "arg" content-	let direction = getAttr' "direction" e-	[arg | direction `elem` dirs]+getattr :: Text -> X.Element -> Text+getattr = (fromMaybe "" .) . getattrM -children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]-children f filt (H.Elem _ _ contents) =-	mapM f [x | (H.CElem x _) <- concatMap filt contents]-dtdPublicID, dtdSystemID :: String-dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"+isParam :: [Text] -> X.Element -> [X.Element]+isParam dirs = named "arg" >=> checkDir where+	checkDir e = [e | getattr "direction" e `elem` dirs]++children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b]+children f p = mapM f . concatMap p . X.elementChildren++named :: X.Named a => Text -> a -> [a]+named = X.isNamed . toName++toName :: Text -> X.Name+toName t = X.Name t Nothing Nothing++#line 293 "src/introspection.anansi"+newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) }++instance Monad XmlWriter where+	return a = XmlWriter $ Just (a, TL.empty)+	m >>= f = XmlWriter $ do+		(a, w) <- runXmlWriter m+		(b, w') <- runXmlWriter (f a)+		return (b, TL.append w w')++#line 304 "src/introspection.anansi"+tell :: Text -> XmlWriter ()+tell t = XmlWriter $ Just ((), t)++#line 309 "src/introspection.anansi" toXML :: Object -> Maybe Text-toXML obj = fmap (TL.pack . render . document) doc where-	prolog = H.Prolog Nothing [] (Just doctype) []-	doctype = H.DTD "node" (Just (H.PUBLIC-		(H.PubidLiteral dtdPublicID)-		(H.SystemLiteral dtdSystemID))) []-	doc = do-		root <- xmlRoot obj-		return $ H.Document prolog H.emptyST root []-xmlRoot :: Object -> Maybe (H.Element a)-xmlRoot obj@(Object path _ _) = do-	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-	return root-xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)-xmlObject parentPath obj@(Object path _ _) = do-	let path' = T.strObjectPath path-	    parent' = T.strObjectPath parentPath-	relpath <- if TL.isPrefixOf parent' path'+toXML obj = do+	(_, text) <- runXmlWriter (writeRoot obj)+	return text++#line 316 "src/introspection.anansi"+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.strObjectPath path) obj++#line 324 "src/introspection.anansi"+writeChild :: T.ObjectPath -> Object -> XmlWriter ()+writeChild parentPath obj@(Object path _ _) = write where+	path' = T.strObjectPath path+	parent' = T.strObjectPath parentPath+	relpathM = if TL.isPrefixOf parent' path' 		then Just $ if parent' == "/" 			then TL.drop 1 path' 			else TL.drop (TL.length parent' + 1) path' 		else Nothing-	xmlObject' relpath obj-xmlObject' :: Text -> Object -> Maybe (H.Content a)-xmlObject' path (Object fullPath interfaces children') = do-	children'' <- mapM (xmlObject fullPath) children'-	return $ mkElement "node"-		[mkAttr "name" $ TL.unpack path]-		$ concat-			[ map xmlInterface interfaces-			, children''-			]-xmlInterface :: Interface -> H.Content a-xmlInterface (Interface name methods signals properties) =-	mkElement "interface"-		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]-		$ concat-			[ map xmlMethod methods-			, map xmlSignal signals-			, map xmlProperty properties-			]-xmlMethod :: Method -> H.Content a-xmlMethod (Method name inParams outParams) = mkElement "method"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ concat-		[ map (xmlParameter "in") inParams-		, map (xmlParameter "out") outParams-		]-xmlSignal :: Signal -> H.Content a-xmlSignal (Signal name params) = mkElement "signal"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ map (xmlParameter "out") params-xmlParameter :: String -> Parameter -> H.Content a-xmlParameter direction (Parameter name sig) = mkElement "arg"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "direction" direction-	] []-xmlProperty :: Property -> H.Content a-xmlProperty (Property name sig access) = mkElement "property"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "access" $ xmlAccess access-	] []-xmlAccess :: [PropertyAccess] -> String-xmlAccess access = readS ++ writeS where+	+	write = case relpathM of+		Just relpath -> writeObject relpath obj+		Nothing -> XmlWriter Nothing++#line 340 "src/introspection.anansi"+writeObject :: Text -> Object -> XmlWriter ()+writeObject path (Object fullPath interfaces children') = writeElement "node"+	[("name", path)] $ do+		mapM_ writeInterface interfaces+		mapM_ (writeChild fullPath) children'++#line 348 "src/introspection.anansi"+writeInterface :: Interface -> XmlWriter ()+writeInterface (Interface name methods signals properties) = writeElement "interface"+	[("name", T.strInterfaceName name)] $ do+		mapM_ writeMethod methods+		mapM_ writeSignal signals+		mapM_ writeProperty properties++#line 357 "src/introspection.anansi"+writeMethod :: Method -> XmlWriter ()+writeMethod (Method name inParams outParams) = writeElement "method"+	[("name", T.strMemberName name)] $ do+		mapM_ (writeParameter "in") inParams+		mapM_ (writeParameter "out") outParams++#line 365 "src/introspection.anansi"+writeSignal :: Signal -> XmlWriter ()+writeSignal (Signal name params) = writeElement "signal"+	[("name", T.strMemberName name)] $ do+		mapM_ (writeParameter "out") params++#line 372 "src/introspection.anansi"+writeParameter :: Text -> Parameter -> XmlWriter ()+writeParameter direction (Parameter name sig) = writeEmptyElement "arg"+	[ ("name", name)+	, ("type", T.strSignature sig)+	, ("direction", direction)+	]++#line 381 "src/introspection.anansi"+writeProperty :: Property -> XmlWriter ()+writeProperty (Property name sig access) = writeEmptyElement "property"+	[ ("name", name)+	, ("type", T.strSignature sig)+	, ("access", strAccess access)+	]++#line 390 "src/introspection.anansi"+strAccess :: [PropertyAccess] -> Text+strAccess access = TL.append readS writeS where 	readS = if elem Read access then "read" else "" 	writeS = if elem Write access then "write" else ""-mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a-mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined -mkAttr :: String -> String -> H.Attribute-mkAttr name value = (name, H.AttValue [Left escaped]) where-	raw = H.CString True value ()-	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]+#line 397 "src/introspection.anansi"+writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter ()+writeElement name attrs content = do+	tell "<"+	tell name+	mapM_ writeAttribute attrs+	tell ">"+	content+	tell "</"+	tell name+	tell ">"++#line 410 "src/introspection.anansi"+writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter ()+writeEmptyElement name attrs = do+	tell "<"+	tell name+	mapM_ writeAttribute attrs+	tell "/>"++#line 419 "src/introspection.anansi"+writeAttribute :: (Text, Text) -> XmlWriter ()+writeAttribute (name, content) = do+	tell " "+	tell name+	tell "='"+	tell (escape content)+	tell "'"++#line 429 "src/introspection.anansi"+escape :: Text -> Text+escape = TL.concatMap escapeChar where+	escapeChar c = case c of+		'&' -> "&amp;"+		'<' -> "&lt;"+		'>' -> "&gt;"+		'"' -> "&quot;"+		'\'' -> "&apos;"+		_ -> TL.singleton c

@@ -1,3 +1,7 @@++#line 23 "src/match-rules.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 24 "src/match-rules.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 25 "src/match-rules.anansi" module DBus.MatchRule ( 	  MatchRule (..) 	, MessageType (..)@@ -22,8 +32,12 @@ 	, matchAll 	, matches 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++#line 35 "src/match-rules.anansi" import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set@@ -31,6 +45,8 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex)++#line 45 "src/match-rules.anansi" -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation.@@ -45,6 +61,8 @@ 	, matchParameters  :: [ParameterValue] 	} 	deriving (Show)++#line 62 "src/match-rules.anansi" -- | Parameters may match against two types, strings and object paths. It's -- probably an error to have two values for the same parameter. -- @@ -56,6 +74,8 @@ 	= StringValue Word8 Text 	| PathValue Word8 T.ObjectPath 	deriving (Show, Eq)++#line 76 "src/match-rules.anansi" -- | The set of allowed message types to filter on is separate from the set -- supported for sending over the wire. This allows the server to support -- additional types not yet implemented in the library, or vice-versa.@@ -66,8 +86,14 @@ 	| Signal 	| Error 	deriving (Show, Eq)++#line 92 "src/match-rules.anansi"++#line 126 "src/api-docs.anansi" -- | Format a 'MatchRule' as the bus expects to receive in a call to -- @AddMatch@.++#line 93 "src/match-rules.anansi" formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where 	filters = structureFilters ++ parameterFilters@@ -81,12 +107,16 @@ 		, ("destination", fmap T.strBusName . matchDestination) 		] 	unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule++#line 109 "src/match-rules.anansi" formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where 	key = "arg" `TL.append` TL.pack (show index) formatParameter (PathValue index x) = formatFilter' key value where 	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" 	value = T.strObjectPath x++#line 121 "src/match-rules.anansi" formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -95,7 +125,13 @@ formatType MethodReturn = "method_return" formatType Signal       = "signal" formatType Error        = "error"++#line 135 "src/match-rules.anansi"++#line 131 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for adding a match rule to the bus.++#line 136 "src/match-rules.anansi" addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall 	C.dbusPath@@ -104,7 +140,13 @@ 	(Just C.dbusName) 	Set.empty 	[T.toVariant $ formatRule rule]++#line 150 "src/match-rules.anansi"++#line 135 "src/api-docs.anansi" -- | An empty match rule, which matches everything.++#line 151 "src/match-rules.anansi" matchAll :: MatchRule matchAll = MatchRule 	{ matchType        = Nothing@@ -115,8 +157,14 @@ 	, matchDestination = Nothing 	, matchParameters  = [] 	}++#line 167 "src/match-rules.anansi"++#line 139 "src/api-docs.anansi" -- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful -- for implementing signal handlers.++#line 168 "src/match-rules.anansi" matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ rule) $ 	[ fmap      (typeMatches msg) . matchType@@ -127,32 +175,44 @@ 	, fmap      (destMatches msg) . matchDestination 	, Just . parametersMatch msg  . matchParameters 	]++#line 181 "src/match-rules.anansi" typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True typeMatches (M.ReceivedSignal       _ _ _) Signal       = True typeMatches (M.ReceivedError        _ _ _) Error        = True typeMatches _ _ = False++#line 190 "src/match-rules.anansi" senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name++#line 195 "src/match-rules.anansi" ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name = 	Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name = 	name == M.signalInterface msg ifaceMatches _ _ = False++#line 204 "src/match-rules.anansi" memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name = 	name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name = 	name == M.signalMember msg memberMatches _ _ = False++#line 213 "src/match-rules.anansi" pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path = 	path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path = 	path == M.signalPath msg pathMatches _ _ = False++#line 222 "src/match-rules.anansi" destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = 	Just name == M.methodCallDestination msg@@ -163,6 +223,8 @@ destMatches (M.ReceivedSignal _ _ msg) name = 	Just name == M.signalDestination msg destMatches _ _ = False++#line 235 "src/match-rules.anansi" parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool parametersMatch _ [] = True parametersMatch msg values = all validParam values where

@@ -1,3 +1,7 @@++#line 23 "src/messages.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,24 +16,46 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 24 "src/messages.anansi" module DBus.Message (++#line 51 "src/messages.anansi" 	Message ( messageFlags 	        , messageBody 	        )++#line 69 "src/messages.anansi" 	, Flag (..)++#line 124 "src/messages.anansi" 	, Serial 	, serialValue 	, firstSerial 	, nextSerial++#line 169 "src/messages.anansi" 	, MethodCall (..)++#line 206 "src/messages.anansi" 	, MethodReturn (..)++#line 256 "src/messages.anansi" 	, Error (..) 	, errorMessage++#line 296 "src/messages.anansi" 	, Signal (..)++#line 327 "src/messages.anansi" 	, Unknown (..)++#line 377 "src/messages.anansi" 	, ReceivedMessage (..) 	, receivedSerial 	, receivedSender 	, receivedBody++#line 26 "src/messages.anansi" 	) where import DBus.Message.Internal

@@ -1,3 +1,7 @@++#line 31 "src/messages.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,24 +16,40 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 32 "src/messages.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 33 "src/messages.anansi" module DBus.Message.Internal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++#line 35 "src/messages.anansi" import qualified Data.Set as S import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) import qualified DBus.Types as T import DBus.Util (maybeIndex)++#line 43 "src/messages.anansi" class Message a where 	messageTypeCode     :: a -> Word8 	messageHeaderFields :: a -> [HeaderField] 	messageFlags        :: a -> S.Set Flag 	messageBody         :: a -> [T.Variant]++#line 62 "src/messages.anansi" data Flag 	= NoReplyExpected 	| NoAutoStart 	deriving (Show, Eq, Ord)++#line 80 "src/messages.anansi" data HeaderField 	= Path        T.ObjectPath 	| Interface   T.InterfaceName@@ -40,8 +60,14 @@ 	| Sender      T.BusName 	| Signature   T.Signature 	deriving (Show, Eq)++#line 98 "src/messages.anansi"++#line 152 "src/api-docs.anansi" -- | A value used to uniquely identify a particular message within a session. -- 'Serial's are 32-bit unsigned integers, and eventually wrap.++#line 99 "src/messages.anansi" newtype Serial = Serial { serialValue :: Word32 } 	deriving (Eq, Ord) @@ -51,13 +77,19 @@ instance T.Variable Serial where 	toVariant (Serial x) = T.toVariant x 	fromVariant = fmap Serial . T.fromVariant++#line 113 "src/messages.anansi" firstSerial :: Serial firstSerial = Serial 1  nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1)++#line 138 "src/messages.anansi" maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x'])++#line 145 "src/messages.anansi" data MethodCall = MethodCall 	{ methodCallPath        :: T.ObjectPath 	, methodCallMember      :: T.MemberName@@ -79,6 +111,8 @@ 		, maybe' Interface . methodCallInterface $ m 		, maybe' Destination . methodCallDestination $ m 		]++#line 187 "src/messages.anansi" data MethodReturn = MethodReturn 	{ methodReturnSerial      :: Serial 	, methodReturnDestination :: Maybe T.BusName@@ -95,6 +129,8 @@ 		  ] 		, maybe' Destination . methodReturnDestination $ m 		]++#line 221 "src/messages.anansi" data Error = Error 	{ errorName        :: T.ErrorName 	, errorSerial      :: Serial@@ -113,6 +149,8 @@ 		  ] 		, maybe' Destination . errorDestination $ m 		]++#line 246 "src/messages.anansi" errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do 	field <- maybeIndex (errorBody msg) 0@@ -120,6 +158,8 @@ 	if TL.null text 		then Nothing 		else return text++#line 273 "src/messages.anansi" data Signal = Signal 	{ signalPath        :: T.ObjectPath 	, signalMember      :: T.MemberName@@ -140,15 +180,23 @@ 		  ] 		, maybe' Destination . signalDestination $ m 		]++#line 318 "src/messages.anansi" data Unknown = Unknown 	{ unknownType    :: Word8 	, unknownFlags   :: S.Set Flag 	, unknownBody    :: [T.Variant] 	} 	deriving (Show, Eq)++#line 339 "src/messages.anansi"++#line 157 "src/api-docs.anansi" -- | Not an actual message type, but a wrapper around messages received from -- the bus. Each value contains the message's 'Serial' and possibly the -- origin's 'T.BusName'++#line 340 "src/messages.anansi" data ReceivedMessage 	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall 	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn@@ -156,18 +204,24 @@ 	| ReceivedSignal       Serial (Maybe T.BusName) Signal 	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown 	deriving (Show, Eq)++#line 350 "src/messages.anansi" receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall   s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s receivedSerial (ReceivedError        s _ _) = s receivedSerial (ReceivedSignal       s _ _) = s receivedSerial (ReceivedUnknown      s _ _) = s++#line 359 "src/messages.anansi" receivedSender :: ReceivedMessage -> Maybe T.BusName receivedSender (ReceivedMethodCall   _ s _) = s receivedSender (ReceivedMethodReturn _ s _) = s receivedSender (ReceivedError        _ s _) = s receivedSender (ReceivedSignal       _ s _) = s receivedSender (ReceivedUnknown      _ s _) = s++#line 368 "src/messages.anansi" receivedBody :: ReceivedMessage -> [T.Variant] receivedBody (ReceivedMethodCall   _ _ x) = messageBody x receivedBody (ReceivedMethodReturn _ _ x) = messageBody x

@@ -1,3 +1,7 @@++#line 22 "src/name-reservation.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +16,8 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 23 "src/name-reservation.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation 	( RequestNameFlag (..)@@ -29,17 +35,27 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex)++#line 43 "src/name-reservation.anansi" data RequestNameFlag 	= AllowReplacement 	| ReplaceExisting 	| DoNotQueue 	deriving (Show)++#line 51 "src/name-reservation.anansi" encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where 	flagValue AllowReplacement = 0x1 	flagValue ReplaceExisting  = 0x2 	flagValue DoNotQueue       = 0x4++#line 62 "src/name-reservation.anansi"++#line 144 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for requesting a registered bus name.++#line 63 "src/name-reservation.anansi" requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall 	{ M.methodCallPath = C.dbusPath@@ -51,24 +67,36 @@ 		[ T.toVariant name 		, T.toVariant . encodeFlags $ flags] 	}++#line 77 "src/name-reservation.anansi" data RequestNameReply 	= PrimaryOwner 	| InQueue 	| Exists 	| AlreadyOwner 	deriving (Show)++#line 86 "src/name-reservation.anansi" mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg = 	maybeIndex (M.messageBody msg) 0 >>= 	T.fromVariant >>= 	decodeRequestReply++#line 94 "src/name-reservation.anansi" decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue decodeRequestReply 3 = Just Exists decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing++#line 103 "src/name-reservation.anansi"++#line 148 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for releasing a registered bus name.++#line 104 "src/name-reservation.anansi" releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall 	{ M.methodCallPath = C.dbusPath@@ -78,16 +106,22 @@ 	, M.methodCallMember = "ReleaseName" 	, M.methodCallBody = [T.toVariant name] 	}++#line 116 "src/name-reservation.anansi" data ReleaseNameReply 	= Released 	| NonExistent 	| NotOwner 	deriving (Show)++#line 124 "src/name-reservation.anansi" mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg = 	maybeIndex (M.messageBody msg) 0 >>= 	T.fromVariant >>= 	decodeReleaseReply++#line 132 "src/name-reservation.anansi" decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent

@@ -1,504 +0,0 @@--- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>--- --- This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- any later version.--- --- This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.--- --- You should have received a copy of the GNU General Public License--- along with this program.  If not, see <http://www.gnu.org/licenses/>.-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-module DBus.Types (-	  -- * Available types-	  Type (..)-	, typeCode-	  -- * Variants-	, Variant-	, Variable (..)-	, variantType-	  -- * Signatures-	, Signature-	, signatureTypes-	, strSignature-	, mkSignature-	, mkSignature_-	  -- * Object paths-	, ObjectPath-	, strObjectPath-	, mkObjectPath-	, mkObjectPath_-	  -- * Arrays-	, Array-	, arrayType-	, arrayItems-	, toArray-	, fromArray-	, arrayFromItems-	, arrayToBytes-	, arrayFromBytes-	  -- * Dictionaries-	, Dictionary-	, dictionaryItems-	, dictionaryKeyType-	, dictionaryValueType-	, toDictionary-	, fromDictionary-	, dictionaryFromItems-	, dictionaryToArray-	, arrayToDictionary-	  -- * Structures-	, Structure (..)-	-- * Names-	  -- ** Bus names-	, BusName-	, strBusName-	, mkBusName-	, mkBusName_-	  -- ** Interface names-	, InterfaceName-	, strInterfaceName-	, mkInterfaceName-	, mkInterfaceName_-	  -- ** Error names-	, ErrorName-	, strErrorName-	, mkErrorName-	, mkErrorName_-	  -- ** Member names-	, MemberName-	, strMemberName-	, mkMemberName-	, mkMemberName_-	) where-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import qualified Data.Text as T-import Data.Ord (comparing)-import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import DBus.Util (checkLength, parseMaybe)-import DBus.Util (mkUnsafe)-import qualified Data.String as String-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as ByteString-import qualified Data.ByteString as StrictByteString-import Data.List (intercalate)-import Control.Monad (unless)-import Control.Arrow ((***))-import qualified Data.Map as Map-import Control.Monad (forM)-data Type-	= DBusBoolean-	| DBusByte-	| DBusInt16-	| DBusInt32-	| DBusInt64-	| DBusWord16-	| DBusWord32-	| DBusWord64-	| DBusDouble-	| DBusString-	| DBusSignature-	| DBusObjectPath-	| DBusVariant-	| DBusArray Type-	| DBusDictionary Type Type-	| DBusStructure [Type]-	deriving (Show, Eq)--- | \"Atomic\" types are any which can't contain any other types. Only--- atomic types may be used as dictionary keys.-isAtomicType :: Type -> Bool-isAtomicType DBusBoolean    = True-isAtomicType DBusByte       = True-isAtomicType DBusInt16      = True-isAtomicType DBusInt32      = True-isAtomicType DBusInt64      = True-isAtomicType DBusWord16     = True-isAtomicType DBusWord32     = True-isAtomicType DBusWord64     = True-isAtomicType DBusDouble     = True-isAtomicType DBusString     = True-isAtomicType DBusSignature  = True-isAtomicType DBusObjectPath = True-isAtomicType _              = False--- | Every type has an associated type code; a textual representation of--- the type, useful for debugging.-typeCode :: Type -> Text-typeCode DBusBoolean    = "b"-typeCode DBusByte       = "y"-typeCode DBusInt16      = "n"-typeCode DBusInt32      = "i"-typeCode DBusInt64      = "x"-typeCode DBusWord16     = "q"-typeCode DBusWord32     = "u"-typeCode DBusWord64     = "t"-typeCode DBusDouble     = "d"-typeCode DBusString     = "s"-typeCode DBusSignature  = "g"-typeCode DBusObjectPath = "o"-typeCode DBusVariant    = "v"-typeCode (DBusArray t) = TL.cons 'a' $ typeCode t-typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]-typeCode (DBusStructure ts) = TL.concat $-	["("] ++ map typeCode ts ++ [")"]--- | 'Variant's may contain any other built-in D-Bus value. Besides--- representing native @VARIANT@ values, they allow type-safe storage and--- deconstruction of heterogeneous collections.-data Variant-	= VarBoxBool Bool-	| VarBoxWord8 Word8-	| VarBoxInt16 Int16-	| VarBoxInt32 Int32-	| VarBoxInt64 Int64-	| VarBoxWord16 Word16-	| VarBoxWord32 Word32-	| VarBoxWord64 Word64-	| VarBoxDouble Double-	| VarBoxString Text-	| VarBoxSignature Signature-	| VarBoxObjectPath ObjectPath-	| VarBoxVariant Variant-	| VarBoxArray Array-	| VarBoxDictionary Dictionary-	| VarBoxStructure Structure-	deriving (Eq)--class Variable a where-	toVariant :: a -> Variant-	fromVariant :: Variant -> Maybe a-instance Show Variant where-	showsPrec d var = showParen (d > 10) full where-		full = s "Variant " . shows code . s " " . valueStr-		code = typeCode $ variantType var-		s = showString-		valueStr = showsPrecVar 11 var--showsPrecVar :: Int -> Variant -> ShowS-showsPrecVar d var = case var of-	(VarBoxBool x) -> showsPrec d x-	(VarBoxWord8 x) -> showsPrec d x-	(VarBoxInt16 x) -> showsPrec d x-	(VarBoxInt32 x) -> showsPrec d x-	(VarBoxInt64 x) -> showsPrec d x-	(VarBoxWord16 x) -> showsPrec d x-	(VarBoxWord32 x) -> showsPrec d x-	(VarBoxWord64 x) -> showsPrec d x-	(VarBoxDouble x) -> showsPrec d x-	(VarBoxString x) -> showsPrec d x-	(VarBoxSignature x) -> showsPrec d x-	(VarBoxObjectPath x) -> showsPrec d x-	(VarBoxVariant x) -> showsPrec d x-	(VarBoxArray x) -> showsPrec d x-	(VarBoxDictionary x) -> showsPrec d x-	(VarBoxStructure x) -> showsPrec d x--- | Every variant is strongly-typed; that is, the type of its contained--- value is known at all times. This function retrieves that type, so that--- the correct cast can be used to retrieve the value.-variantType :: Variant -> Type-variantType var = case var of-	(VarBoxBool _) -> DBusBoolean-	(VarBoxWord8 _) -> DBusByte-	(VarBoxInt16 _) -> DBusInt16-	(VarBoxInt32 _) -> DBusInt32-	(VarBoxInt64 _) -> DBusInt64-	(VarBoxWord16 _) -> DBusWord16-	(VarBoxWord32 _) -> DBusWord32-	(VarBoxWord64 _) -> DBusWord64-	(VarBoxDouble _) -> DBusDouble-	(VarBoxString _) -> DBusString-	(VarBoxSignature _) -> DBusSignature-	(VarBoxObjectPath _) -> DBusObjectPath-	(VarBoxVariant _) -> DBusVariant-	(VarBoxArray x) -> DBusArray (arrayType x)-	(VarBoxDictionary x) -> let-		keyT = dictionaryKeyType x-		valueT = dictionaryValueType x-		in DBusDictionary keyT valueT-	(VarBoxStructure x) -> let-		Structure items = x-		in DBusStructure (map variantType items)-#define INSTANCE_VARIABLE(TYPE) \-	instance Variable TYPE where \-		{ toVariant = VarBox/**/TYPE \-		; fromVariant (VarBox/**/TYPE x) = Just x \-		; fromVariant _ = Nothing \-		}-INSTANCE_VARIABLE(Variant)-INSTANCE_VARIABLE(Bool)-INSTANCE_VARIABLE(Word8)-INSTANCE_VARIABLE(Int16)-INSTANCE_VARIABLE(Int32)-INSTANCE_VARIABLE(Int64)-INSTANCE_VARIABLE(Word16)-INSTANCE_VARIABLE(Word32)-INSTANCE_VARIABLE(Word64)-INSTANCE_VARIABLE(Double)-instance Variable TL.Text where-	toVariant = VarBoxString-	fromVariant (VarBoxString x) = Just x-	fromVariant _ = Nothing-instance Variable T.Text where-	toVariant = toVariant . TL.fromChunks . (:[])-	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant-instance Variable String where-	toVariant = toVariant . TL.pack-	fromVariant = fmap TL.unpack . fromVariant-INSTANCE_VARIABLE(Signature)-data Signature = Signature { signatureTypes :: [Type] }-	deriving (Eq)--instance Show Signature where-	showsPrec d x = showParen (d > 10) $-		showString "Signature " . shows (strSignature x)-strSignature :: Signature -> Text-strSignature (Signature ts) = TL.concat $ map typeCode ts-instance Ord Signature where-	compare = comparing strSignature-mkSignature :: Text -> Maybe Signature-mkSignature text = parsed where-	just t = Just $ Signature [t]-	fast = case TL.head text of-		'b' -> just DBusBoolean-		'y' -> just DBusByte-		'n' -> just DBusInt16-		'i' -> just DBusInt32-		'x' -> just DBusInt64-		'q' -> just DBusWord16-		'u' -> just DBusWord32-		't' -> just DBusWord64-		'd' -> just DBusDouble-		's' -> just DBusString-		'g' -> just DBusSignature-		'o' -> just DBusObjectPath-		'v' -> just DBusVariant-		_   -> Nothing-	slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text-	sigParser = do-		types <- P.many parseType-		P.eof-		return $ Signature types-	parseType = parseAtom <|> parseContainer-	parseContainer =-		    parseArray-		<|> parseStruct-		<|> (P.char 'v' >> return DBusVariant)-	parseArray = do-		P.char 'a'-		parseDict <|> fmap DBusArray parseType-	parseDict = do-		P.char '{'-		keyType <- parseAtom-		valueType <- parseType-		P.char '}'-		return $ DBusDictionary keyType valueType-	parseStruct = do-		P.char '('-		types <- P.many parseType-		P.char ')'-		return $ DBusStructure types-	parseAtom =-		    (P.char 'b' >> return DBusBoolean)-		<|> (P.char 'y' >> return DBusByte)-		<|> (P.char 'n' >> return DBusInt16)-		<|> (P.char 'i' >> return DBusInt32)-		<|> (P.char 'x' >> return DBusInt64)-		<|> (P.char 'q' >> return DBusWord16)-		<|> (P.char 'u' >> return DBusWord32)-		<|> (P.char 't' >> return DBusWord64)-		<|> (P.char 'd' >> return DBusDouble)-		<|> (P.char 's' >> return DBusString)-		<|> (P.char 'g' >> return DBusSignature)-		<|> (P.char 'o' >> return DBusObjectPath)-	parsed = case TL.length text of-		0 -> Just $ Signature []-		1 -> fast-		_ -> slow-mkSignature_ :: Text -> Signature-mkSignature_ = mkUnsafe "signature" mkSignature--instance String.IsString Signature where-	fromString = mkSignature_ . TL.pack-INSTANCE_VARIABLE(ObjectPath)-newtype ObjectPath = ObjectPath-	{ strObjectPath :: Text-	}-	deriving (Eq, Ord)--instance Show ObjectPath where-	showsPrec d (ObjectPath x) = showParen (d > 10) $-		showString "ObjectPath " . shows x--instance String.IsString ObjectPath where-	fromString = mkObjectPath_ . TL.pack-mkObjectPath :: Text -> Maybe ObjectPath-mkObjectPath s = parseMaybe path' (TL.unpack s) where-	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char-	path' = path >> P.eof >> return (ObjectPath s)--mkObjectPath_ :: Text -> ObjectPath-mkObjectPath_ = mkUnsafe "object path" mkObjectPath-INSTANCE_VARIABLE(Array)-data Array-	= VariantArray Type [Variant]-	| ByteArray ByteString-	deriving (Eq)---- | This is the type contained within the array, not the type of the array--- itself.-arrayType :: Array -> Type-arrayType (VariantArray t _) = t-arrayType (ByteArray _) = DBusByte--arrayItems :: Array -> [Variant]-arrayItems (VariantArray _ xs) = xs-arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs-instance Show Array where-	showsPrec d array = showParen (d > 10) $-		s "Array " . showSig . s " [" . s valueString . s "]" where-			s = showString-			showSig = shows . typeCode . arrayType $ array-			showVar var = showsPrecVar 0 var ""-			valueString = intercalate ", " $ map showVar $ arrayItems array-arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)--arrayFromItems t vs = do-	mkSignature (typeCode t)-	if all (\x -> variantType x == t) vs-		then Just $ VariantArray t vs-		else Nothing-toArray :: Variable a => Type -> [a] -> Maybe Array-toArray t = arrayFromItems t . map toVariant--fromArray :: Variable a => Array -> Maybe [a]-fromArray = mapM fromVariant . arrayItems-arrayToBytes :: Array -> Maybe ByteString-arrayToBytes (ByteArray x) = Just x-arrayToBytes _             = Nothing--arrayFromBytes :: ByteString -> Array-arrayFromBytes = ByteArray-instance Variable ByteString where-	toVariant = toVariant . arrayFromBytes-	fromVariant x = fromVariant x >>= arrayToBytes-instance Variable StrictByteString.ByteString where-	toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]-	fromVariant x = do-		chunks <- ByteString.toChunks `fmap` fromVariant x-		return $ StrictByteString.concat chunks-INSTANCE_VARIABLE(Dictionary)-data Dictionary = Dictionary-	{ dictionaryKeyType   :: Type-	, dictionaryValueType :: Type-	, dictionaryItems     :: [(Variant, Variant)]-	}-	deriving (Eq)-instance Show Dictionary where-	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $-		s "Dictionary " . showSig . s " {" . s valueString . s "}" where-			s = showString-			showSig = shows $ TL.append (typeCode kt) (typeCode vt)-			valueString = intercalate ", " $ map showPair pairs-			showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""-dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary-dictionaryFromItems kt vt pairs = do-	unless (isAtomicType kt) Nothing-	mkSignature (typeCode kt)-	mkSignature (typeCode vt)-	-	let sameType (k, v) = variantType k == kt &&-	                      variantType v == vt-	if all sameType pairs-		then Just $ Dictionary kt vt pairs-		else Nothing-toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b-             -> Maybe Dictionary-toDictionary kt vt = dictionaryFromItems kt vt . pairs where-	pairs = map (toVariant *** toVariant) . Map.toList-fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary-               -> Maybe (Map.Map a b)-fromDictionary (Dictionary _ _ vs) = do-	pairs <- forM vs $ \(k, v) -> do-		k' <- fromVariant k-		v' <- fromVariant v-		return (k', v')-	return $ Map.fromList pairs-dictionaryToArray :: Dictionary -> Array-dictionaryToArray (Dictionary kt vt items) = array where-	Just array = toArray itemType structs-	itemType = DBusStructure [kt, vt]-	structs = [Structure [k, v] | (k, v) <- items]-arrayToDictionary :: Array -> Maybe Dictionary-arrayToDictionary array = do-	let toPair x = do-		struct <- fromVariant x-		case struct of-			Structure [k, v] -> Just (k, v)-			_                -> Nothing-	(kt, vt) <- case arrayType array of-		DBusStructure [kt, vt] -> Just (kt, vt)-		_                      -> Nothing-	pairs <- mapM toPair $ arrayItems array-	dictionaryFromItems kt vt pairs-INSTANCE_VARIABLE(Structure)-data Structure = Structure [Variant]-	deriving (Show, Eq)-#define NAME_TYPE(TYPE, NAME) \-	newtype TYPE = TYPE {str/**/TYPE :: Text} \-		deriving (Eq, Ord); \-		\-	instance Show TYPE where \-		{ showsPrec d (TYPE x) = showParen (d > 10) $ \-			showString "TYPE " . shows x \-		}; \-		\-	instance String.IsString TYPE where \-		{ fromString = mk/**/TYPE/**/_ . TL.pack }; \-		\-	instance Variable TYPE where \-		{ toVariant = toVariant . str/**/TYPE \-		; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \-		                                                \-	mk/**/TYPE/**/_ :: Text -> TYPE; \-	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE-NAME_TYPE(BusName, "bus name")--mkBusName :: Text -> Maybe BusName-mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-	c' = c ++ ['0'..'9']-	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)-	unique = P.char ':' >> elems c'-	wellKnown = elems c-	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)-	elem' start = P.oneOf start >> P.many (P.oneOf c')-NAME_TYPE(InterfaceName, "interface name")--mkInterfaceName :: Text -> Maybe InterfaceName-mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	element = P.oneOf c >> P.many (P.oneOf c')-	name = element >> P.many1 (P.char '.' >> element)-	parser = name >> P.eof >> return (InterfaceName s)-NAME_TYPE(ErrorName, "error name")--mkErrorName :: Text -> Maybe ErrorName-mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName-NAME_TYPE(MemberName, "member name")--mkMemberName :: Text -> Maybe MemberName-mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	name = P.oneOf c >> P.many (P.oneOf c')-	parser = name >> P.eof >> return (MemberName s)

@@ -0,0 +1,121 @@++#line 23 "src/types.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 24 "src/types.anansi"+module DBus.Types (++#line 100 "src/types.anansi"+	  -- * Available types+	  Type (..)+	, typeCode++#line 176 "src/types.anansi"+	  -- * Variants+	, Variant+	, Variable (..)++#line 248 "src/types.anansi"+	, variantType++#line 442 "src/types.anansi"+	  -- * Signatures+	, Signature+	, signatureTypes+	, strSignature++#line 714 "src/types.anansi"+	, mkSignature+	, mkSignature_++#line 789 "src/types.anansi"+	  -- * Object paths+	, ObjectPath+	, strObjectPath+	, mkObjectPath+	, mkObjectPath_++#line 839 "src/types.anansi"+	  -- * Arrays+	, Array+	, arrayType+	, arrayItems++#line 885 "src/types.anansi"+	, toArray+	, fromArray+	, arrayFromItems++#line 903 "src/types.anansi"+	, arrayToBytes+	, arrayFromBytes++#line 967 "src/types.anansi"+	  -- * Dictionaries+	, Dictionary+	, dictionaryItems+	, dictionaryKeyType+	, dictionaryValueType++#line 1044 "src/types.anansi"+	, toDictionary+	, fromDictionary+	, dictionaryFromItems++#line 1116 "src/types.anansi"+	, dictionaryToArray+	, arrayToDictionary++#line 1133 "src/types.anansi"+	  -- * Structures+	, Structure (..)++#line 1174 "src/types.anansi"+	-- * Names++#line 1204 "src/types.anansi"+	  -- ** Bus names+	, BusName+	, strBusName+	, mkBusName+	, mkBusName_++#line 1257 "src/types.anansi"+	  -- ** Interface names+	, InterfaceName+	, strInterfaceName+	, mkInterfaceName+	, mkInterfaceName_++#line 1298 "src/types.anansi"+	  -- ** Error names+	, ErrorName+	, strErrorName+	, mkErrorName+	, mkErrorName_++#line 1334 "src/types.anansi"+	  -- ** Member names+	, MemberName+	, strMemberName+	, mkMemberName+	, mkMemberName_++#line 26 "src/types.anansi"+	) where+import DBus.Types.Internal

@@ -0,0 +1,706 @@++#line 31 "src/types.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 32 "src/types.anansi"++#line 52 "src/introduction.anansi"+{-# LANGUAGE OverloadedStrings #-}++#line 33 "src/types.anansi"++#line 372 "src/types.anansi"+{-# LANGUAGE TypeSynonymInstances #-}++#line 34 "src/types.anansi"+module DBus.Types.Internal where++#line 56 "src/introduction.anansi"+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++#line 36 "src/types.anansi"++#line 325 "src/types.anansi"+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++#line 359 "src/types.anansi"+import qualified Data.Text as T++#line 433 "src/types.anansi"+import Data.Ord (comparing)++#line 454 "src/types.anansi"+import Data.Text.Encoding (decodeUtf8)++#line 513 "src/types.anansi"+import qualified Data.ByteString.Unsafe as B+import qualified Foreign as F+import System.IO.Unsafe (unsafePerformIO)++#line 684 "src/types.anansi"+import Data.Text.Lazy.Encoding (encodeUtf8)++#line 697 "src/types.anansi"+import DBus.Util (mkUnsafe)+import qualified Data.String as String++#line 772 "src/types.anansi"+import Text.ParserCombinators.Parsec ((<|>))+import qualified Text.ParserCombinators.Parsec as P+import DBus.Util (checkLength, parseMaybe)++#line 978 "src/types.anansi"+import Data.List (intercalate)++#line 995 "src/types.anansi"+import Control.Monad (unless)++#line 1017 "src/types.anansi"+import Control.Arrow ((***))+import qualified Data.Map as Map++#line 1029 "src/types.anansi"+import Control.Monad (forM)++#line 37 "src/types.anansi"+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BL8++#line 52 "src/types.anansi"+data Type+	= DBusBoolean+	| DBusByte+	| DBusInt16+	| DBusInt32+	| DBusInt64+	| DBusWord16+	| DBusWord32+	| DBusWord64+	| DBusDouble+	| DBusString+	| DBusSignature+	| DBusObjectPath+	| DBusVariant+	| DBusArray Type+	| DBusDictionary Type Type+	| DBusStructure [Type]+	deriving (Show, Eq)++#line 73 "src/types.anansi"++#line 27 "src/api-docs.anansi"+-- | \"Atomic\" types are any which can't contain any other types. Only+-- atomic types may be used as dictionary keys.++#line 74 "src/types.anansi"+isAtomicType :: Type -> Bool+isAtomicType DBusBoolean    = True+isAtomicType DBusByte       = True+isAtomicType DBusInt16      = True+isAtomicType DBusInt32      = True+isAtomicType DBusInt64      = True+isAtomicType DBusWord16     = True+isAtomicType DBusWord32     = True+isAtomicType DBusWord64     = True+isAtomicType DBusDouble     = True+isAtomicType DBusString     = True+isAtomicType DBusSignature  = True+isAtomicType DBusObjectPath = True+isAtomicType _              = False++#line 94 "src/types.anansi"++#line 32 "src/api-docs.anansi"+-- | Every type has an associated type code; a textual representation of+-- the type, useful for debugging.++#line 95 "src/types.anansi"+typeCode :: Type -> Text++#line 458 "src/types.anansi"+typeCode t = TL.fromChunks [decodeUtf8 $ typeCodeB t]++typeCodeB :: Type -> B.ByteString+typeCodeB DBusBoolean    = "b"+typeCodeB DBusByte       = "y"+typeCodeB DBusInt16      = "n"+typeCodeB DBusInt32      = "i"+typeCodeB DBusInt64      = "x"+typeCodeB DBusWord16     = "q"+typeCodeB DBusWord32     = "u"+typeCodeB DBusWord64     = "t"+typeCodeB DBusDouble     = "d"+typeCodeB DBusString     = "s"+typeCodeB DBusSignature  = "g"+typeCodeB DBusObjectPath = "o"+typeCodeB DBusVariant    = "v"++#line 480 "src/types.anansi"+typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t++#line 487 "src/types.anansi"+typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"]++#line 495 "src/types.anansi"+typeCodeB (DBusStructure ts) = B.concat $+	["("] ++ map typeCodeB ts ++ [")"]++#line 150 "src/types.anansi"++#line 37 "src/api-docs.anansi"+-- | 'Variant's may contain any other built-in D-Bus value. Besides+-- representing native @VARIANT@ values, they allow type-safe storage and+-- deconstruction of heterogeneous collections.++#line 151 "src/types.anansi"+data Variant+	= VarBoxBool Bool+	| VarBoxWord8 Word8+	| VarBoxInt16 Int16+	| VarBoxInt32 Int32+	| VarBoxInt64 Int64+	| VarBoxWord16 Word16+	| VarBoxWord32 Word32+	| VarBoxWord64 Word64+	| VarBoxDouble Double+	| VarBoxString Text+	| VarBoxSignature Signature+	| VarBoxObjectPath ObjectPath+	| VarBoxVariant Variant+	| VarBoxArray Array+	| VarBoxDictionary Dictionary+	| VarBoxStructure Structure+	deriving (Eq)++class Variable a where+	toVariant :: a -> Variant+	fromVariant :: Variant -> Maybe a++#line 186 "src/types.anansi"+instance Show Variant where+	showsPrec d var = showParen (d > 10) full where+		full = s "Variant " . shows code . s " " . valueStr+		code = typeCode $ variantType var+		s = showString+		valueStr = showsPrecVar 11 var++showsPrecVar :: Int -> Variant -> ShowS+showsPrecVar d var = case var of+	(VarBoxBool x) -> showsPrec d x+	(VarBoxWord8 x) -> showsPrec d x+	(VarBoxInt16 x) -> showsPrec d x+	(VarBoxInt32 x) -> showsPrec d x+	(VarBoxInt64 x) -> showsPrec d x+	(VarBoxWord16 x) -> showsPrec d x+	(VarBoxWord32 x) -> showsPrec d x+	(VarBoxWord64 x) -> showsPrec d x+	(VarBoxDouble x) -> showsPrec d x+	(VarBoxString x) -> showsPrec d x+	(VarBoxSignature x) -> showsPrec d x+	(VarBoxObjectPath x) -> showsPrec d x+	(VarBoxVariant x) -> showsPrec d x+	(VarBoxArray x) -> showsPrec d x+	(VarBoxDictionary x) -> showsPrec d x+	(VarBoxStructure x) -> showsPrec d x++#line 218 "src/types.anansi"++#line 43 "src/api-docs.anansi"+-- | Every variant is strongly-typed; that is, the type of its contained+-- value is known at all times. This function retrieves that type, so that+-- the correct cast can be used to retrieve the value.++#line 219 "src/types.anansi"+variantType :: Variant -> Type+variantType var = case var of+	(VarBoxBool _) -> DBusBoolean+	(VarBoxWord8 _) -> DBusByte+	(VarBoxInt16 _) -> DBusInt16+	(VarBoxInt32 _) -> DBusInt32+	(VarBoxInt64 _) -> DBusInt64+	(VarBoxWord16 _) -> DBusWord16+	(VarBoxWord32 _) -> DBusWord32+	(VarBoxWord64 _) -> DBusWord64+	(VarBoxDouble _) -> DBusDouble+	(VarBoxString _) -> DBusString+	(VarBoxSignature _) -> DBusSignature+	(VarBoxObjectPath _) -> DBusObjectPath+	(VarBoxVariant _) -> DBusVariant+	(VarBoxArray x) -> DBusArray (arrayType x)+	(VarBoxDictionary x) -> let+		keyT = dictionaryKeyType x+		valueT = dictionaryValueType x+		in DBusDictionary keyT valueT+	(VarBoxStructure x) -> let+		Structure items = x+		in DBusStructure (map variantType items)++variantSignature :: Variant -> Maybe Signature+variantSignature = mkBytesSignature . typeCodeB . variantType++#line 255 "src/types.anansi"+#define INSTANCE_VARIABLE(TYPE) \+	instance Variable TYPE where \+		{ toVariant = VarBox/**/TYPE \+		; fromVariant (VarBox/**/TYPE x) = Just x \+		; fromVariant _ = Nothing \+		}++#line 266 "src/types.anansi"+INSTANCE_VARIABLE(Variant)++#line 330 "src/types.anansi"+INSTANCE_VARIABLE(Bool)+INSTANCE_VARIABLE(Word8)+INSTANCE_VARIABLE(Int16)+INSTANCE_VARIABLE(Int32)+INSTANCE_VARIABLE(Int64)+INSTANCE_VARIABLE(Word16)+INSTANCE_VARIABLE(Word32)+INSTANCE_VARIABLE(Word64)+INSTANCE_VARIABLE(Double)++#line 348 "src/types.anansi"+instance Variable TL.Text where+	toVariant = VarBoxString+	fromVariant (VarBoxString x) = Just x+	fromVariant _ = Nothing++#line 363 "src/types.anansi"+instance Variable T.Text where+	toVariant = toVariant . TL.fromChunks . (:[])+	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant++#line 376 "src/types.anansi"+instance Variable String where+	toVariant = toVariant . TL.pack+	fromVariant = fmap TL.unpack . fromVariant++#line 409 "src/types.anansi"+INSTANCE_VARIABLE(Signature)+data Signature = Signature { signatureTypes :: [Type] }+	deriving (Eq)++instance Show Signature where+	showsPrec d x = showParen (d > 10) $+		showString "Signature " . shows (strSignature x)++#line 422 "src/types.anansi"+bytesSignature :: Signature -> B.ByteString+bytesSignature (Signature ts) = B.concat $ map typeCodeB ts++strSignature :: Signature -> Text+strSignature (Signature ts) = TL.concat $ map typeCode ts++#line 437 "src/types.anansi"+instance Ord Signature where+	compare = comparing strSignature++#line 529 "src/types.anansi"+mkBytesSignature :: B.ByteString -> Maybe Signature+mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where++#line 542 "src/types.anansi"+	parseAtom c yes no = case c of+		0x62 -> yes DBusBoolean+		0x79 -> yes DBusByte+		0x6E -> yes DBusInt16+		0x69 -> yes DBusInt32+		0x78 -> yes DBusInt64+		0x71 -> yes DBusWord16+		0x75 -> yes DBusWord32+		0x74 -> yes DBusWord64+		0x64 -> yes DBusDouble+		0x73 -> yes DBusString+		0x67 -> yes DBusSignature+		0x6F -> yes DBusObjectPath+		_ -> no+	+	fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of+		0x76 -> Just (Signature [DBusVariant])+		_ -> Nothing++#line 532 "src/types.anansi"++#line 563 "src/types.anansi"+	slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature)+	slow buf len = loop [] 0 where+		loop acc ii | ii >= len = return . Just . Signature $ reverse acc+		loop acc ii = do+			c <- F.peekElemOff buf ii+			let next t = loop (t : acc) (ii + 1)+			parseAtom c next $ case c of+				0x76 -> next DBusVariant+				+				-- '('+				0x28 -> do+					mt <- structure buf len (ii + 1)+					case mt of+						Just (ii', t) -> loop (t : acc) ii'+						Nothing -> return Nothing+				+				-- 'a'+				0x61 -> do+					mt <- array buf len (ii + 1)+					case mt of+						Just (ii', t) -> loop (t : acc) ii'+						Nothing -> return Nothing+				+				_ -> return Nothing++#line 590 "src/types.anansi"+	structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+	structure buf len = loop [] where+		loop _ ii | ii >= len = return Nothing+		loop acc ii = do+			c <- F.peekElemOff buf ii+			let next t = loop (t : acc) (ii + 1)+			parseAtom c next $ case c of+				0x76 -> next DBusVariant+				+				-- '('+				0x28 -> do+					mt <- structure buf len (ii + 1)+					case mt of+						Just (ii', t) -> loop (t : acc) ii'+						Nothing -> return Nothing+				+				-- ')'+				0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc))+				+				-- 'a'+				0x61 -> do+					mt <- array buf len (ii + 1)+					case mt of+						Just (ii', t) -> loop (t : acc) ii'+						Nothing -> return Nothing+				+				_ -> return Nothing++#line 620 "src/types.anansi"+	array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+	array _   len ii | ii >= len = return Nothing+	array buf len ii = do+		c <- F.peekElemOff buf ii+		let next t = return $ Just (ii + 1, DBusArray t)+		parseAtom c next $ case c of+			0x76 -> next DBusVariant+			+			-- '('+			0x28 -> do+				mt <- structure buf len (ii + 1)+				case mt of+					Just (ii', t) -> return $ Just (ii', DBusArray t)+					Nothing -> return Nothing+			+			-- '{'+			0x7B -> dict buf len (ii + 1)+			+			-- 'a'+			0x61 -> do+				mt <- array buf len (ii + 1)+				case mt of+					Just (ii', t) -> return $ Just (ii', DBusArray t)+					Nothing -> return Nothing+			+			_ -> return Nothing++#line 649 "src/types.anansi"+	dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+	dict _   len ii | ii + 1 >= len = return Nothing+	dict buf len ii = do+		c1 <- F.peekElemOff buf ii+		c2 <- F.peekElemOff buf (ii + 1)+		+		let mt1 = parseAtom c1 Just Nothing+		+		let next t = return $ Just (ii + 2, t)+		mt2 <- parseAtom c2 next $ case c2 of+			0x76 -> next DBusVariant+			+			-- '('+			0x28 -> structure buf len (ii + 2)+			+			-- 'a'+			0x61 -> array buf len (ii + 2)+			+			_ -> return Nothing+		+		case mt2 of+			Nothing -> return Nothing+			Just (ii', t2) -> if ii' >= len+				then return Nothing+				else do+					c3 <- F.peekElemOff buf ii'+					return $ do+						if c3 == 0x7D then Just () else Nothing+						t1 <- mt1+						Just (ii' + 1, DBusDictionary t1 t2)++#line 533 "src/types.anansi"+	+	io (cstr, len) = case len of+		0 -> return $ Just $ Signature []+		1 -> fmap fast $ F.peek cstr+		_ | len <= 255 -> slow (F.castPtr cstr) len+		_ -> return Nothing++#line 688 "src/types.anansi"+mkSignature :: Text -> Maybe Signature+mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8++#line 702 "src/types.anansi"+mkSignature_ :: Text -> Signature+mkSignature_ = mkUnsafe "signature" mkSignature++instance String.IsString Signature where+	fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack++#line 724 "src/types.anansi"+maybeValidType :: Type -> Maybe ()+maybeValidType t = if B.length (typeCodeB t) > 255+	then Nothing+	else Just ()++#line 745 "src/types.anansi"+INSTANCE_VARIABLE(ObjectPath)+newtype ObjectPath = ObjectPath+	{ strObjectPath :: Text+	}+	deriving (Eq, Ord)++instance Show ObjectPath where+	showsPrec d (ObjectPath x) = showParen (d > 10) $+		showString "ObjectPath " . shows x++instance String.IsString ObjectPath where+	fromString = mkObjectPath_ . TL.pack++#line 778 "src/types.anansi"+mkObjectPath :: Text -> Maybe ObjectPath+mkObjectPath s = parseMaybe path' (TL.unpack s) where+	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char+	path' = path >> P.eof >> return (ObjectPath s)++mkObjectPath_ :: Text -> ObjectPath+mkObjectPath_ = mkUnsafe "object path" mkObjectPath++#line 822 "src/types.anansi"+INSTANCE_VARIABLE(Array)+data Array+	= VariantArray Type [Variant]+	| ByteArray BL.ByteString+	deriving (Eq)+++#line 49 "src/api-docs.anansi"+-- | This is the type contained within the array, not the type of the array+-- itself.++#line 829 "src/types.anansi"+arrayType :: Array -> Type+arrayType (VariantArray t _) = t+arrayType (ByteArray _) = DBusByte++arrayItems :: Array -> [Variant]+arrayItems (VariantArray _ xs) = xs+arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs++#line 849 "src/types.anansi"+instance Show Array where+	showsPrec d array = showParen (d > 10) $+		s "Array " . showSig . s " [" . s valueString . s "]" where+			s = showString+			showSig = shows . typeCode . arrayType $ array+			showVar var = showsPrecVar 0 var ""+			valueString = intercalate ", " $ map showVar $ arrayItems array++#line 863 "src/types.anansi"+arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems DBusByte vs = fmap (ByteArray . BL.pack) (mapM fromVariant vs)++arrayFromItems t vs = do+	maybeValidType t+	if all (\x -> variantType x == t) vs+		then Just $ VariantArray t vs+		else Nothing++#line 877 "src/types.anansi"+toArray :: Variable a => Type -> [a] -> Maybe Array+toArray t = arrayFromItems t . map toVariant++fromArray :: Variable a => Array -> Maybe [a]+fromArray = mapM fromVariant . arrayItems++#line 894 "src/types.anansi"+arrayToBytes :: Array -> Maybe BL.ByteString+arrayToBytes (ByteArray x) = Just x+arrayToBytes _             = Nothing++arrayFromBytes :: BL.ByteString -> Array+arrayFromBytes = ByteArray++#line 911 "src/types.anansi"+instance Variable BL.ByteString where+	toVariant = toVariant . arrayFromBytes+	fromVariant x = fromVariant x >>= arrayToBytes++#line 917 "src/types.anansi"+instance Variable B.ByteString where+	toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x]+	fromVariant = fmap (B.concat . BL.toChunks) . fromVariant++#line 956 "src/types.anansi"+INSTANCE_VARIABLE(Dictionary)++data Dictionary = Dictionary+	{ dictionaryKeyType   :: Type+	, dictionaryValueType :: Type+	, dictionaryItems     :: [(Variant, Variant)]+	}+	deriving (Eq)++#line 982 "src/types.anansi"+instance Show Dictionary where+	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $+		s "Dictionary " . showSig . s " {" . s valueString . s "}" where+			s = showString+			showSig = shows $ TL.append (typeCode kt) (typeCode vt)+			valueString = intercalate ", " $ map showPair pairs+			showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""++#line 999 "src/types.anansi"+dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary+dictionaryFromItems kt vt pairs = do+	unless (isAtomicType kt) Nothing+	maybeValidType kt+	maybeValidType vt+	+	let sameType (k, v) = variantType k == kt &&+	                      variantType v == vt+	if all sameType pairs+		then Just $ Dictionary kt vt pairs+		else Nothing++#line 1022 "src/types.anansi"+toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b+             -> Maybe Dictionary+toDictionary kt vt = dictionaryFromItems kt vt . pairs where+	pairs = map (toVariant *** toVariant) . Map.toList++#line 1033 "src/types.anansi"+fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary+               -> Maybe (Map.Map a b)+fromDictionary (Dictionary _ _ vs) = do+	pairs <- forM vs $ \(k, v) -> do+		k' <- fromVariant k+		v' <- fromVariant v+		return (k', v')+	return $ Map.fromList pairs++#line 1093 "src/types.anansi"+dictionaryToArray :: Dictionary -> Array+dictionaryToArray (Dictionary kt vt items) = array where+	Just array = toArray itemType structs+	itemType = DBusStructure [kt, vt]+	structs = [Structure [k, v] | (k, v) <- items]++#line 1101 "src/types.anansi"+arrayToDictionary :: Array -> Maybe Dictionary+arrayToDictionary array = do+	let toPair x = do+		struct <- fromVariant x+		case struct of+			Structure [k, v] -> Just (k, v)+			_                -> Nothing+	(kt, vt) <- case arrayType array of+		DBusStructure [kt, vt] -> Just (kt, vt)+		_                      -> Nothing+	pairs <- mapM toPair $ arrayItems array+	dictionaryFromItems kt vt pairs++#line 1126 "src/types.anansi"+INSTANCE_VARIABLE(Structure)++data Structure = Structure [Variant]+	deriving (Show, Eq)++#line 1153 "src/types.anansi"+#define NAME_TYPE(TYPE, NAME) \+	newtype TYPE = TYPE {str/**/TYPE :: Text} \+		deriving (Eq, Ord); \+		\+	instance Show TYPE where \+		{ showsPrec d (TYPE x) = showParen (d > 10) $ \+			showString "TYPE " . shows x \+		}; \+		\+	instance String.IsString TYPE where \+		{ fromString = mk/**/TYPE/**/_ . TL.pack }; \+		\+	instance Variable TYPE where \+		{ toVariant = toVariant . str/**/TYPE \+		; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \+		                                                \+	mk/**/TYPE/**/_ :: Text -> TYPE; \+	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE++#line 1190 "src/types.anansi"+NAME_TYPE(BusName, "bus name")++mkBusName :: Text -> Maybe BusName+mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+	c' = c ++ ['0'..'9']+	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)+	unique = P.char ':' >> elems c'+	wellKnown = elems c+	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)+	elem' start = P.oneOf start >> P.many (P.oneOf c')++#line 1245 "src/types.anansi"+NAME_TYPE(InterfaceName, "interface name")++mkInterfaceName :: Text -> Maybe InterfaceName+mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	element = P.oneOf c >> P.many (P.oneOf c')+	name = element >> P.many1 (P.char '.' >> element)+	parser = name >> P.eof >> return (InterfaceName s)++#line 1291 "src/types.anansi"+NAME_TYPE(ErrorName, "error name")++mkErrorName :: Text -> Maybe ErrorName+mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName++#line 1323 "src/types.anansi"+NAME_TYPE(MemberName, "member name")++mkMemberName :: Text -> Maybe MemberName+mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	name = P.oneOf c >> P.many (P.oneOf c')+	parser = name >> P.eof >> return (MemberName s)

@@ -1,3 +1,7 @@++#line 22 "src/util.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,13 +16,19 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 23 "src/util.anansi" module DBus.UUID 	( UUID 	, toHex 	, fromHex 	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++#line 29 "src/util.anansi"  newtype UUID = UUID Text -- TODO: (Word64, Word64)? 	deriving (Eq)

@@ -1,3 +1,7 @@++#line 58 "src/util.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,8 +16,10 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 59 "src/util.anansi" module DBus.Util where-import Text.Parsec (Parsec, parse)+import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt) import Data.List (isPrefixOf) @@ -21,7 +27,7 @@ checkLength length' s | length s <= length' = Just s checkLength _ _ = Nothing -parseMaybe :: Parsec String () a -> String -> Maybe a+parseMaybe :: Parser a -> String -> Maybe a parseMaybe p = either (const Nothing) Just . parse p ""  mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b

@@ -1,3 +1,7 @@++#line 117 "src/util.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,20 +16,32 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.-{-# LANGUAGE TypeFamilies #-}++#line 118 "src/util.anansi" module DBus.Util.MonadError-	( ErrorT (..)-	, throwError+	( ErrorM (..)+	, ErrorT (..)+	, throwErrorM+	, throwErrorT 	) where-import Control.Monad.Trans.Class-import Control.Monad.State-import Control.Monad.Error.Class+newtype ErrorM e a = ErrorM { runErrorM :: Either e a } -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }+instance Functor (ErrorM e) where+	fmap f m = ErrorM $ case runErrorM m of+		Left err -> Left err+		Right x -> Right $ f x -instance Functor m => Functor (ErrorT e m) where-	fmap f = ErrorT . fmap (fmap f) . runErrorT+instance Monad (ErrorM e) where+	return = ErrorM . Right+	(>>=) m k = case runErrorM m of+		Left err -> ErrorM $ Left err+		Right x -> k x +throwErrorM :: e -> ErrorM e a+throwErrorM = ErrorM . Left++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }+ instance Monad m => Monad (ErrorT e m) where 	return = ErrorT . return . Right 	(>>=) m k = ErrorT $ do@@ -34,19 +50,5 @@ 			Left l -> return $ Left l 			Right r -> runErrorT $ k r -instance MonadTrans (ErrorT e) where-	lift = ErrorT . liftM Right--instance Monad m => MonadError (ErrorT e m) where-	type ErrorType (ErrorT e m) = e-	throwError = ErrorT . return . Left-	catchError m h = ErrorT $ do-		x <- runErrorT m-		case x of-			Left l -> runErrorT $ h l-			Right r -> return $ Right r--instance MonadState m => MonadState (ErrorT e m) where-	type StateType (ErrorT e m) = StateType m-	get = lift get-	put = lift . put+throwErrorT :: Monad m => e -> ErrorT e m a+throwErrorT = ErrorT . return . Left

@@ -1,3 +1,7 @@++#line 21 "src/wire.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,12 +16,26 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 22 "src/wire.anansi" module DBus.Wire (++#line 54 "src/wire.anansi" 	  Endianness (..)++#line 238 "src/wire.anansi" 	, MarshalError (..)++#line 442 "src/wire.anansi" 	, UnmarshalError (..)++#line 921 "src/wire.anansi" 	, marshalMessage++#line 991 "src/wire.anansi" 	, unmarshalMessage++#line 24 "src/wire.anansi" 	) where import DBus.Wire.Internal import DBus.Wire.Marshal

@@ -1,3 +1,7 @@++#line 31 "src/wire.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,9 +16,13 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 32 "src/wire.anansi" module DBus.Wire.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T++#line 40 "src/wire.anansi" data Endianness = LittleEndian | BigEndian 	deriving (Show, Eq) @@ -26,7 +34,11 @@ decodeEndianness 108 = Just LittleEndian decodeEndianness 66  = Just BigEndian decodeEndianness _   = Nothing++#line 69 "src/wire.anansi" alignment :: T.Type -> Word8++#line 451 "src/wire.anansi" alignment T.DBusByte    = 1 alignment T.DBusWord16  = 2 alignment T.DBusWord32  = 4@@ -35,14 +47,30 @@ alignment T.DBusInt32   = 4 alignment T.DBusInt64   = 8 alignment T.DBusDouble  = 8++#line 548 "src/wire.anansi" alignment T.DBusBoolean = 4++#line 629 "src/wire.anansi" alignment T.DBusString     = 4 alignment T.DBusObjectPath = 4++#line 671 "src/wire.anansi" alignment T.DBusSignature  = 1++#line 687 "src/wire.anansi" alignment (T.DBusArray _) = 4++#line 769 "src/wire.anansi" alignment (T.DBusDictionary _ _) = 4++#line 786 "src/wire.anansi" alignment (T.DBusStructure _) = 8++#line 804 "src/wire.anansi" alignment T.DBusVariant = 1++#line 71 "src/wire.anansi"  padding :: Word64 -> Word8 -> Word64 padding current count = required where

@@ -1,3 +1,7 @@++#line 89 "src/wire.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,94 +16,167 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 90 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL-import qualified Control.Monad.State as State-import qualified DBus.Util.MonadError as E++#line 93 "src/wire.anansi"++#line 105 "src/wire.anansi"+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B++#line 514 "src/wire.anansi" import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE++#line 599 "src/wire.anansi" import DBus.Wire.Unicode (maybeEncodeUtf8)-import Data.Text.Lazy.Encoding (encodeUtf8)++#line 703 "src/wire.anansi" import qualified DBus.Constants as C++#line 830 "src/wire.anansi" import qualified DBus.Message.Internal as M++#line 845 "src/wire.anansi" import Data.Bits ((.|.)) import qualified Data.Set as Set++#line 94 "src/wire.anansi" import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust) import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)+import Data.Int (Int64)  import qualified DBus.Types as T-data MarshalState = MarshalState Endianness B.Builder !Word64-type MarshalM = E.ErrorT MarshalError (State.State MarshalState)+import qualified DBus.Types.Internal as T++#line 111 "src/wire.anansi"+data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64++data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState+ type Marshal = MarshalM ()+newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a }++instance Monad MarshalM where+	{-# INLINE return #-}+	return a = MarshalM $ \_ s -> MarshalRR a s+	+	{-# INLINE (>>=) #-}+	m >>= k = MarshalM $ \e s -> case unMarshalM m e s of+		MarshalRL err -> MarshalRL err+		MarshalRR a s' -> unMarshalM (k a) e s'+	+	{-# INLINE (>>) #-}+	m >> k = MarshalM $ \e s -> case unMarshalM m e s of+		MarshalRL err -> MarshalRL err+		MarshalRR _ s' -> unMarshalM k e s'++throwError :: MarshalError -> MarshalM a+throwError err = MarshalM $ \_ _ -> MarshalRL err++{-# INLINE getState #-}+getState :: MarshalM MarshalState+getState = MarshalM $ \_ s -> MarshalRR s s++{-# INLINE putState #-}+putState :: MarshalState -> MarshalM ()+putState s = MarshalM $ \_ _ -> MarshalRR () s++#line 148 "src/wire.anansi" runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal m e = case State.runState (E.runErrorT m) initialState of-	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)-	(Left  x, _) -> Left x-	where initialState = MarshalState e B.empty 0+runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of+	MarshalRL err -> Left err+	MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder++#line 155 "src/wire.anansi" marshal :: T.Variant -> Marshal-marshal v = marshalType (T.variantType v) where-	x :: T.Variable a => a-	x = fromJust . T.fromVariant $ v-	marshalType :: T.Type -> Marshal-	marshalType T.DBusByte   = append $ L.singleton x-	marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x-	marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x-	marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x-	marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)-	marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)-	marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)-	marshalType T.DBusDouble = do-		pad 8-		(MarshalState e _ _) <- State.get-		let put = case e of-			BigEndian -> IEEE.putFloat64be-			LittleEndian -> IEEE.putFloat64le-		let bytes = runPut $ put x-		append bytes-	marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0-	marshalType T.DBusString = marshalText x-	marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x-	marshalType T.DBusSignature = marshalSignature x-	marshalType (T.DBusArray _) = marshalArray x-	marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)-	marshalType (T.DBusStructure _) = do-		let T.Structure vs = x+marshal v = case v of++#line 483 "src/wire.anansi"+	T.VarBoxWord8  x -> marshalWord8 x+	T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x+	T.VarBoxWord32 x -> marshalWord32 x+	T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x+	T.VarBoxInt16  x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x+	T.VarBoxInt32  x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x+	T.VarBoxInt64  x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x++#line 523 "src/wire.anansi"+	T.VarBoxDouble x -> marshalDouble x++#line 552 "src/wire.anansi"+	T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0++#line 634 "src/wire.anansi"+	T.VarBoxString x -> marshalText x+	T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x++#line 675 "src/wire.anansi"+	T.VarBoxSignature x -> marshalSignature x++#line 691 "src/wire.anansi"+	T.VarBoxArray x -> marshalArray x++#line 773 "src/wire.anansi"+	T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x)++#line 790 "src/wire.anansi"+	T.VarBoxStructure (T.Structure vs) -> do 		pad 8 		mapM_ marshal vs-	marshalType T.DBusVariant = do-		let rawSig = T.typeCode . T.variantType $ x-		sig <- case T.mkSignature rawSig of++#line 808 "src/wire.anansi"+	T.VarBoxVariant x -> do+		let textSig = T.typeCode . T.variantType $ x+		sig <- case T.variantSignature x of 			Just x' -> return x'-			Nothing -> E.throwError $ InvalidVariantSignature rawSig+			Nothing -> throwError $ InvalidVariantSignature textSig 		marshalSignature sig 		marshal x-append :: L.ByteString -> Marshal-append bytes = do-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ B.fromLazyByteString bytes-	    count' = count + fromIntegral (L.length bytes)-	State.put $ MarshalState e builder' count'++#line 163 "src/wire.anansi"+appendS :: BS.ByteString -> Marshal+appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.fromByteString bytes+	count' = count + fromIntegral (BS.length bytes)+	in MarshalRR () (MarshalState builder' count')++#line 171 "src/wire.anansi"+appendL :: L.ByteString -> Marshal+appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.fromLazyByteString bytes+	count' = count + fromIntegral (L.length bytes)+	in MarshalRR () (MarshalState builder' count')++#line 179 "src/wire.anansi" pad :: Word8 -> Marshal-pad count = do-	(MarshalState _ _ existing) <- State.get-	let padding' = fromIntegral $ padding existing count-	append $ L.replicate padding' 0+pad count = MarshalM $ \e s@(MarshalState _ existing) -> let+	padding' = fromIntegral $ padding existing count+	bytes = BS.replicate padding' 0+	in unMarshalM (appendS bytes) e s++#line 190 "src/wire.anansi" marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do 	pad size-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ case e of-		BigEndian -> be x-		LittleEndian -> le x-	let count' = count + fromIntegral size-	State.put $ MarshalState e builder' count'+	MarshalM $ \e (MarshalState builder count) -> let+		builder' = B.append builder $ case e of+			BigEndian -> be x+			LittleEndian -> le x+		size' = fromIntegral size+		in MarshalRR () (MarshalState builder' (count + size'))++#line 216 "src/wire.anansi" data MarshalError 	= MessageTooLong Word64 	| ArrayTooLong Word64@@ -119,55 +196,89 @@ 		["Invalid variant signature: ", show x] 	show (InvalidText x) = concat 		["Text cannot be marshaled: ", show x]++#line 465 "src/wire.anansi" marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le++#line 470 "src/wire.anansi"+{-# INLINE marshalWord8 #-}+marshalWord8 :: Word8 -> Marshal+marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.singleton x+	in MarshalRR () (MarshalState builder' (count + 1))++#line 527 "src/wire.anansi"+marshalDouble :: Double -> Marshal+marshalDouble x = do+	pad 8+	MarshalM $ \e s -> let+		put = case e of+			BigEndian -> IEEE.putFloat64be+			LittleEndian -> IEEE.putFloat64le+		bytes = runPut $ put x+		in unMarshalM (appendL bytes) e s++#line 603 "src/wire.anansi" marshalText :: Text -> Marshal marshalText x = do 	bytes <- case maybeEncodeUtf8 x of 		Just x' -> return x'-		Nothing -> E.throwError $ InvalidText x+		Nothing -> throwError $ InvalidText x 	when (L.any (== 0) bytes) $-		E.throwError $ InvalidText x+		throwError $ InvalidText x 	marshalWord32 . fromIntegral . L.length $ bytes-	append bytes-	append (L.singleton 0)+	appendL bytes+	marshalWord8 0++#line 651 "src/wire.anansi" marshalSignature :: T.Signature -> Marshal marshalSignature x = do-	let bytes = encodeUtf8 . T.strSignature $ x-	let size = fromIntegral . L.length $ bytes-	append (L.singleton size)-	append bytes-	append (L.singleton 0)+	let bytes = T.bytesSignature x+	let size = fromIntegral . BS.length $ bytes+	marshalWord8 size+	appendS bytes+	marshalWord8 0++#line 707 "src/wire.anansi" marshalArray :: T.Array -> Marshal marshalArray x = do 	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x 	let arrayLen = L.length arrayBytes 	when (arrayLen > fromIntegral C.arrayMaximumLength)-		(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)+		(throwError $ ArrayTooLong $ fromIntegral arrayLen) 	marshalWord32 $ fromIntegral arrayLen-	append $ L.replicate arrayPadding 0-	append arrayBytes+	appendL $ L.replicate arrayPadding 0+	appendL arrayBytes++#line 719 "src/wire.anansi" getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where 	Just bytes = T.arrayToBytes x++#line 725 "src/wire.anansi" getArrayBytes itemType x = do 	let vs = T.arrayItems x-	s <- State.get-	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get-	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get+	s <- getState+	(MarshalState _ afterLength) <- marshalWord32 0 >> getState+	(MarshalState _ afterPadding) <- pad (alignment itemType) >> getState 	-	State.put $ MarshalState e B.empty afterPadding-	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get+	putState $ MarshalState B.empty afterPadding+	(MarshalState itemBuilder _) <- mapM_ marshal vs >> getState 	 	let itemBytes = B.toLazyByteString itemBuilder 	    paddingSize = fromIntegral $ afterPadding - afterLength 	-	State.put s+	putState s 	return (paddingSize, itemBytes)++#line 850 "src/wire.anansi" encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where 	flagValue M.NoReplyExpected = 0x1 	flagValue M.NoAutoStart     = 0x2++#line 868 "src/wire.anansi" encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x)        = encodeField' 1 x encodeField (M.Interface x)   = encodeField' 2 x@@ -183,49 +294,64 @@ 	[ T.toVariant code 	, T.toVariant $ T.toVariant x 	]++#line 925 "src/wire.anansi"++#line 163 "src/api-docs.anansi" -- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is -- possible for marshaling to fail -- if this occurs, an appropriate error -- will be returned instead.++#line 926 "src/wire.anansi" marshalMessage :: M.Message a => Endianness -> M.Serial -> a                -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where 	body = M.messageBody msg 	marshaler = do 		sig <- checkBodySig body-		empty <- State.get+		empty <- getState 		mapM_ marshal body-		(MarshalState _ bodyBytesB _) <- State.get-		State.put empty+		(MarshalState bodyBytesB _) <- getState+		putState empty 		marshalEndianness e 		let bodyBytes = B.toLazyByteString bodyBytesB 		marshalHeader msg serial sig 			$ fromIntegral . L.length $ bodyBytes 		pad 8-		append bodyBytes+		appendL bodyBytes 		checkMaximumSize++#line 946 "src/wire.anansi" checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let-	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs-	invalid = E.throwError $ InvalidBodySignature sigStr-	in case T.mkSignature sigStr of+	textSig = TL.concat . map (T.typeCode . T.variantType) $ vs+	bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs+	invalid = throwError $ InvalidBodySignature textSig+	in case T.mkBytesSignature bytesSig of 		Just x -> return x 		Nothing -> invalid++#line 957 "src/wire.anansi" marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32               -> Marshal marshalHeader msg serial bodySig bodyLength = do 	let fields = M.Signature bodySig : M.messageHeaderFields msg-	marshal . T.toVariant . M.messageTypeCode $ msg-	marshal . T.toVariant . encodeFlags . M.messageFlags $ msg-	marshal . T.toVariant $ C.protocolVersion+	marshalWord8 . M.messageTypeCode $ msg+	marshalWord8 . encodeFlags . M.messageFlags $ msg+	marshalWord8 C.protocolVersion 	marshalWord32 bodyLength-	marshal . T.toVariant $ serial+	marshalWord32 . M.serialValue $ serial 	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]-	marshal . T.toVariant . fromJust . T.toArray fieldType+	marshalArray . fromJust . T.toArray fieldType 	        $ map encodeField fields++#line 972 "src/wire.anansi" marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness++#line 977 "src/wire.anansi" checkMaximumSize :: Marshal checkMaximumSize = do-	(MarshalState _ _ messageLength) <- State.get+	(MarshalState _ messageLength) <- getState 	when (messageLength > fromIntegral C.messageMaximumLength)-		(E.throwError $ MessageTooLong $ fromIntegral messageLength)+		(throwError $ MessageTooLong $ fromIntegral messageLength)

@@ -1,3 +1,7 @@++#line 574 "src/wire.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +16,8 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 575 "src/wire.anansi" module DBus.Wire.Unicode 	( maybeEncodeUtf8 	, maybeDecodeUtf8) where

@@ -1,3 +1,7 @@++#line 246 "src/wire.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,39 +16,102 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 247 "src/wire.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 248 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL-import qualified Control.Monad.State as State-import Control.Monad.Trans.Class (lift)++#line 251 "src/wire.anansi"++#line 262 "src/wire.anansi"+import Control.Monad (liftM) import qualified DBus.Util.MonadError as E-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++#line 364 "src/wire.anansi" import qualified Data.Binary.Get as G++#line 519 "src/wire.anansi" import qualified Data.Binary.IEEE754 as IEEE++#line 616 "src/wire.anansi" import DBus.Wire.Unicode (maybeDecodeUtf8)++#line 834 "src/wire.anansi" import qualified DBus.Message.Internal as M++#line 840 "src/wire.anansi" import Data.Bits ((.&.)) import qualified Data.Set as Set++#line 987 "src/wire.anansi" import qualified DBus.Constants as C-import Control.Monad (when, unless, liftM)++#line 252 "src/wire.anansi"+import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64)  import DBus.Wire.Internal-import qualified DBus.Types as T-data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState)-runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where-	state = UnmarshalState e bytes 0+import qualified DBus.Types.Internal as T++#line 272 "src/wire.anansi"+data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64++data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState++newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a }++instance Monad Unmarshal where+	{-# INLINE return #-}+	return a = Unmarshal $ \_ s -> UnmarshalRR a s+	+	{-# INLINE (>>=) #-}+	m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of+		UnmarshalRL err -> UnmarshalRL err+		UnmarshalRR a s' -> unUnmarshal (k a) e s'+	+	{-# INLINE (>>) #-}+	m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of+		UnmarshalRL err -> UnmarshalRL err+		UnmarshalRR _ s' -> unUnmarshal k e s'++throwError :: UnmarshalError -> Unmarshal a+throwError err = Unmarshal $ \_ _ -> UnmarshalRL err++{-# INLINE getState #-}+getState :: Unmarshal UnmarshalState+getState = Unmarshal $ \_ s -> UnmarshalRR s s++{-# INLINE putState #-}+putState :: UnmarshalState -> Unmarshal ()+putState s = Unmarshal $ \_ _ -> UnmarshalRR () s++#line 305 "src/wire.anansi"+runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a+runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of+	UnmarshalRL err -> Left err+	UnmarshalRR a _ -> Right a++#line 312 "src/wire.anansi" unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes  unmarshalType :: T.Type -> Unmarshal T.Variant-unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1++#line 493 "src/wire.anansi"+unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le@@ -60,76 +127,104 @@ unmarshalType T.DBusInt64  = do 	x <- unmarshalGet 8 G.getWord64be G.getWord64le 	return . T.toVariant $ (fromIntegral x :: Int64)++#line 539 "src/wire.anansi" unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le++#line 556 "src/wire.anansi" unmarshalType T.DBusBoolean = unmarshalWord32 >>= 	fromMaybeU' "boolean" (\x -> case x of 		0 -> Just False 		1 -> Just True 		_ -> Nothing)-unmarshalType T.DBusString = fmap T.toVariant unmarshalText +#line 639 "src/wire.anansi"+unmarshalType T.DBusString = liftM T.toVariant unmarshalText+ unmarshalType T.DBusObjectPath = unmarshalText >>= 	fromMaybeU' "object path" T.mkObjectPath-unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature-unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t++#line 679 "src/wire.anansi"+unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature++#line 695 "src/wire.anansi"+unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t++#line 777 "src/wire.anansi" unmarshalType (T.DBusDictionary kt vt) = do 	let pairType = T.DBusStructure [kt, vt] 	array <- unmarshalArray pairType 	fromMaybeU' "dictionary" T.arrayToDictionary array++#line 796 "src/wire.anansi" unmarshalType (T.DBusStructure ts) = do 	skipPadding 8-	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts+	liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts++#line 818 "src/wire.anansi" unmarshalType T.DBusVariant = do 	let getType sig = case T.signatureTypes sig of 		[t] -> Just t 		_   -> Nothing 	 	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature-	T.toVariant `fmap` unmarshalType t-consume :: Word64 -> Unmarshal L.ByteString-consume count = do-	(UnmarshalState e bytes offset) <- State.get-	let (x, bytes') = L.splitAt (fromIntegral count) bytes-	unless (L.length x == fromIntegral count) $-		E.throwError $ UnexpectedEOF offset-	-	State.put $ UnmarshalState e bytes' (offset + count)-	return x+	T.toVariant `liftM` unmarshalType t++#line 322 "src/wire.anansi"+{-# INLINE consume #-}+consume :: Word64 -> Unmarshal BL.ByteString+consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let+	count' = fromIntegral count+	(x, bytes') = BL.splitAt count' bytes+	in if BL.length x == count'+		then UnmarshalRR x (UnmarshalState bytes' (offset + count))+		else UnmarshalRL $ UnexpectedEOF offset++#line 333 "src/wire.anansi" skipPadding :: Word8 -> Unmarshal () skipPadding count = do-	(UnmarshalState _ _ offset) <- State.get+	(UnmarshalState _ offset) <- getState 	bytes <- consume $ padding offset count-	unless (L.all (== 0) bytes) $-		E.throwError $ InvalidPadding offset+	unless (BL.all (== 0) bytes) $+		throwError $ InvalidPadding offset++#line 342 "src/wire.anansi" skipTerminator :: Unmarshal () skipTerminator = do-	(UnmarshalState _ _ offset) <- State.get+	(UnmarshalState _ offset) <- getState 	bytes <- consume 1-	unless (L.all (== 0) bytes) $-		E.throwError $ MissingTerminator offset+	unless (BL.all (== 0) bytes) $+		throwError $ MissingTerminator offset++#line 351 "src/wire.anansi" fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of 	Just x' -> return x'-	Nothing -> E.throwError . Invalid label . TL.pack . show $ x+	Nothing -> throwError . Invalid label . TL.pack . show $ x  fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a            -> Unmarshal T.Variant fromMaybeU' label f x = do 	x' <- fromMaybeU label f x 	return $ T.toVariant x'++#line 368 "src/wire.anansi" unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do 	skipPadding count-	(UnmarshalState e _ _) <- State.get 	bs <- consume . fromIntegral $ count-	let get' = case e of-		BigEndian -> be-		LittleEndian -> le-	return $ G.runGet get' bs+	+	Unmarshal $ \e s -> let+		get = case e of+			BigEndian -> be+			LittleEndian -> le+		in UnmarshalRR (G.runGet get bs) s  unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a               -> Unmarshal T.Variant-unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le+unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le++#line 385 "src/wire.anansi" untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do 	done <- test@@ -139,6 +234,8 @@ 			x <- comp 			xs <- untilM test comp 			return $ x:xs++#line 412 "src/wire.anansi" data UnmarshalError 	= UnsupportedProtocolVersion Word8 	| UnexpectedEOF Word64@@ -166,46 +263,60 @@ 	show (MissingTerminator pos) = concat 		["Missing NUL terminator at position ", show pos] 	show ArraySizeMismatch = "Array size mismatch"++#line 478 "src/wire.anansi" unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le++#line 620 "src/wire.anansi" unmarshalText :: Unmarshal Text unmarshalText = do 	byteCount <- unmarshalWord32 	bytes <- consume . fromIntegral $ byteCount 	skipTerminator 	fromMaybeU "text" maybeDecodeUtf8 bytes++#line 661 "src/wire.anansi" unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do-	byteCount <- L.head `fmap` consume 1-	bytes <- consume $ fromIntegral byteCount-	sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes+	byteCount <- BL.head `liftM` consume 1+	lazy <- consume $ fromIntegral byteCount 	skipTerminator-	fromMaybeU "signature" T.mkSignature sigText+	let bytes = B.concat $ BL.toChunks lazy+	fromMaybeU "signature" T.mkBytesSignature bytes++#line 744 "src/wire.anansi" unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do 	byteCount <- unmarshalWord32-	T.arrayFromBytes `fmap` consume (fromIntegral byteCount)+	T.arrayFromBytes `liftM` consume (fromIntegral byteCount)++#line 751 "src/wire.anansi" unmarshalArray itemType = do 	let getOffset = do-		(UnmarshalState _ _ o) <- State.get+		(UnmarshalState _ o) <- getState 		return o 	byteCount <- unmarshalWord32 	skipPadding (alignment itemType) 	start <- getOffset 	let end = start + fromIntegral byteCount-	vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)+	vs <- untilM (liftM (>= end) getOffset) (unmarshalType itemType) 	end' <- getOffset 	when (end' > end) $-		E.throwError ArraySizeMismatch+		throwError ArraySizeMismatch 	fromMaybeU "array" (T.arrayFromItems itemType) vs++#line 857 "src/wire.anansi" decodeFlags :: Word8 -> Set.Set M.Flag decodeFlags word = Set.fromList flags where 	flagSet = [ (0x1, M.NoReplyExpected) 	          , (0x2, M.NoAutoStart) 	          ] 	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]-decodeField :: Monad m => T.Structure-            -> E.ErrorT UnmarshalError m [M.HeaderField]++#line 886 "src/wire.anansi"+decodeField :: T.Structure+            -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of 	(1, x) -> decodeField' x M.Path "path" 	(2, x) -> decodeField' x M.Interface "interface"@@ -217,68 +328,106 @@ 	(8, x) -> decodeField' x M.Signature "signature" 	_      -> return [] -decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text-             -> E.ErrorT UnmarshalError m [b]+decodeField' :: T.Variable a => T.Variant -> (a -> b) -> Text+             -> E.ErrorM UnmarshalError [b] decodeField' x f label = case T.fromVariant x of 	Just x' -> return [f x']-	Nothing -> E.throwError $ InvalidHeaderField label x+	Nothing -> E.throwErrorM $ InvalidHeaderField label x++#line 907 "src/wire.anansi" unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where 	T.Structure [c, v] = struct 	c' = fromJust . T.fromVariant $ c 	v' = fromJust . T.fromVariant $ v++#line 995 "src/wire.anansi"++#line 169 "src/api-docs.anansi" -- | Read bytes from a monad until a complete message has been received.-unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)++#line 996 "src/wire.anansi"+unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do-	let getBytes = lift . getBytes'+	let getBytes = E.ErrorT . liftM Right . getBytes' 	++#line 1011 "src/wire.anansi" 	let fixedSig = "yyyyuuu" 	fixedBytes <- getBytes 16-	let messageVersion = L.index fixedBytes 3++#line 1020 "src/wire.anansi"+	let messageVersion = BL.index fixedBytes 3 	when (messageVersion /= C.protocolVersion) $-		E.throwError $ UnsupportedProtocolVersion messageVersion-	let eByte = L.index fixedBytes 0+		E.throwErrorT $ UnsupportedProtocolVersion messageVersion++#line 1028 "src/wire.anansi"+	let eByte = BL.index fixedBytes 0 	endianness <- case decodeEndianness eByte of 		Just x' -> return x'-		Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte+		Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte++#line 1038 "src/wire.anansi" 	let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of 		Right x' -> return x'-		Left  e  -> E.throwError e+		Left  e  -> E.throwErrorT e 	fixed <- unmarshal' fixedSig fixedBytes 	let typeCode = fromJust . T.fromVariant $ fixed !! 1 	let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 	let bodyLength = fromJust . T.fromVariant $ fixed !! 4 	let serial = fromJust . T.fromVariant $ fixed !! 5++#line 1053 "src/wire.anansi" 	let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6++#line 1002 "src/wire.anansi"++#line 1060 "src/wire.anansi" 	let headerSig  = "yyyyuua(yv)" 	fieldBytes <- getBytes fieldByteCount-	let headerBytes = L.append fixedBytes fieldBytes+	let headerBytes = BL.append fixedBytes fieldBytes 	header <- unmarshal' headerSig headerBytes++#line 1069 "src/wire.anansi" 	let fieldArray = fromJust . T.fromVariant $ header !! 6 	let fieldStructures = fromJust . T.fromArray $ fieldArray-	fields <- concat `liftM` mapM decodeField fieldStructures+	fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of+		Left err -> E.throwErrorT err+		Right x -> return x++#line 1003 "src/wire.anansi"++#line 1080 "src/wire.anansi" 	let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 	getBytes . fromIntegral $ bodyPadding++#line 1091 "src/wire.anansi" 	let bodySig = findBodySignature fields++#line 1097 "src/wire.anansi" 	bodyBytes <- getBytes bodyLength 	body <- unmarshal' bodySig bodyBytes-	y <- case buildReceivedMessage typeCode fields of-		EitherM (Right x) -> return x-		EitherM (Left x) -> E.throwError $ MissingHeaderField x++#line 1004 "src/wire.anansi"++#line 1105 "src/wire.anansi"+	y <- case E.runErrorM $ buildReceivedMessage typeCode fields of+		Right x -> return x+		Left err -> E.throwErrorT $ MissingHeaderField err 	return $ y serial flags body++#line 1085 "src/wire.anansi" findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where 	signature = listToMaybe [x | M.Signature x <- fields]-newtype EitherM a b = EitherM (Either a b) -instance Monad (EitherM a) where-	return = EitherM . Right-	(EitherM (Left x)) >>= _ = EitherM (Left x)-	(EitherM (Right x)) >>= k = k x-buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text+#line 1114 "src/wire.anansi"+buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage)++#line 1122 "src/wire.anansi" buildReceivedMessage 1 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -288,6 +437,8 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.MethodCall path member iface dest flags body 		in M.ReceivedMethodCall serial sender msg++#line 1136 "src/wire.anansi" buildReceivedMessage 2 fields = do 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] 	return $ \serial _ body -> let@@ -295,6 +446,8 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.MethodReturn replySerial dest body 		in M.ReceivedMethodReturn serial sender msg++#line 1148 "src/wire.anansi" buildReceivedMessage 3 fields = do 	name <- require "error name" [x | M.ErrorName x <- fields] 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]@@ -303,6 +456,8 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.Error name replySerial dest body 		in M.ReceivedError serial sender msg++#line 1161 "src/wire.anansi" buildReceivedMessage 4 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -312,10 +467,14 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.Signal path member iface dest body 		in M.ReceivedSignal serial sender msg++#line 1175 "src/wire.anansi" buildReceivedMessage typeCode fields = return $ \serial flags body -> let 	sender = listToMaybe [x | M.Sender x <- fields] 	msg = M.Unknown typeCode flags body 	in M.ReceivedUnknown serial sender msg-require :: Text -> [a] -> EitherM Text a++#line 1182 "src/wire.anansi"+require :: Text -> [a] -> E.ErrorM Text a require _     (x:_) = return x-require label _     = EitherM $ Left label+require label _     = E.throwErrorM label

@@ -1,3 +1,7 @@++#line 64 "src/introduction.anansi"++#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,8 +16,16 @@ --  -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>.++#line 65 "src/introduction.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}++#line 66 "src/introduction.anansi" module Main (tests, main) where++#line 159 "src/util.anansi" import Test.QuickCheck import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -40,8 +52,12 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I +#line 68 "src/introduction.anansi"+ tests :: [F.Test] tests = [ F.testGroup "dummy" []++#line 384 "src/types.anansi" 	, F.testGroup "String" 		[ testProperty "String -> strict Text" 			$ funEq (fromVariant . toVariant) (Just . T.pack)@@ -56,19 +72,27 @@ 		, testProperty "Strict Text <- lazy Text" 			$ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) 		]++#line 736 "src/types.anansi" 	, F.testGroup "Signature" 		[ testProperty "Signature identity" 			$ funEq (mkSignature . strSignature) Just 		]++#line 806 "src/types.anansi" 	, F.testGroup "ObjectPath" 		[ testProperty "ObjectPath identity" 			$ funEq (mkObjectPath . strObjectPath) Just 		]++#line 942 "src/types.anansi" 	, F.testGroup "Array" 		[ testProperty "Array identity" 			$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) 		, testProperty "Array homogeneity" prop_ArrayHomogeneous 		]++#line 1071 "src/types.anansi" 	, F.testGroup "Dictionary" 		[ testProperty "Dictionary identity" 			$ \x -> Just x == dictionaryFromItems@@ -82,22 +106,32 @@ 		, testProperty "Dictionary <-> Array conversion" 			$ funEq (arrayToDictionary . dictionaryToArray) Just 		]++#line 1232 "src/types.anansi" 	, F.testGroup "BusName" 		[ testProperty "BusName identity" 			$ funEq (mkBusName . strBusName) Just 		]++#line 1279 "src/types.anansi" 	, F.testGroup "InterfaceName" 		[ testProperty "InterfaceName identity" 			$ funEq (mkInterfaceName . strInterfaceName) Just 		]++#line 1311 "src/types.anansi" 	, F.testGroup "ErrorName" 		[ testProperty "ErrorName identity" 			$ funEq (mkErrorName . strErrorName) Just 		]++#line 1354 "src/types.anansi" 	, F.testGroup "MemberName" 		[ testProperty "MemberName identity" 			$ funEq (mkMemberName . strMemberName) Just 		]++#line 1223 "src/wire.anansi" 	, F.testGroup "Wire format" 		[ testProperty "Marshal -> Ummarshal" prop_Unmarshal 		, F.testGroup "Messages"@@ -107,6 +141,8 @@ 			, testProperty "Signals" prop_WireSignal 			] 		]++#line 177 "src/addresses.anansi" 	, F.testGroup "Addresses" 		[ testProperty "Address identity" 			$ \x -> mkAddresses (strAddress x) == Just [x]@@ -137,6 +173,8 @@ 			, test "no param" $ isNothing . mkAddresses $ "a:," 			] 		]++#line 508 "src/introspection.anansi" 	, F.testGroup "Introspection" 		[ testProperty "Generate -> Parse" 			$ \x@(I.Object path _ _) -> let@@ -145,10 +183,14 @@ 			parsed = I.fromXML path xml' 			in isJust xml ==> I.fromXML path xml' == Just x 		]++#line 72 "src/introduction.anansi" 	]  main :: IO () main = F.defaultMain tests++#line 106 "src/types.anansi" instance Arbitrary Type where 	arbitrary = oneof [atomicType, containerType] @@ -179,6 +221,8 @@ 			return $ DBusDictionary kt vt 		2 -> fmap DBusStructure $ halfSized arbitrary 		3 -> return DBusVariant++#line 272 "src/types.anansi" instance Arbitrary Variant where 	arbitrary = arbitrary >>= genVariant @@ -200,14 +244,20 @@ 	(DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) 	(DBusStructure _)    -> fmap toVariant (arbitrary :: Gen Structure) 	DBusVariant          -> fmap toVariant (arbitrary :: Gen Variant)++#line 731 "src/types.anansi" instance Arbitrary Signature where 	arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary++#line 797 "src/types.anansi" instance Arbitrary ObjectPath where 	arbitrary = fmap (mkObjectPath_ . TL.pack) path' where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" 		path = fmap (intercalate "/" . ([] :)) genElements 		path' = frequency [(1, return "/"), (9, path)] 		genElements = atLeast 1 (atLeast 1 (elements c))++#line 926 "src/types.anansi" instance Arbitrary Array where 	arbitrary = do 		t <- atomicType@@ -221,6 +271,8 @@ 	firstType = if null types 		then DBusByte 		else head types++#line 1053 "src/types.anansi" instance Arbitrary Dictionary where 	arbitrary = do 		kt <- atomicType@@ -236,8 +288,12 @@ 	vType = dictionaryValueType x 	correctType (k, v) = variantType k == kType && 	                     variantType v == vType++#line 1138 "src/types.anansi" instance Arbitrary Structure where 	arbitrary = fmap Structure $ halfSized arbitrary++#line 1212 "src/types.anansi" instance Arbitrary BusName where 	arbitrary = sizedText 255 (oneof [unique, wellKnown]) where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"@@ -255,6 +311,8 @@ 			x <- elements start 			xs <- atLeast 0 (elements c') 			return (x:xs)++#line 1265 "src/types.anansi" instance Arbitrary InterfaceName where 	arbitrary = sizedText 255 genName where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"@@ -266,8 +324,12 @@ 			x <- elements c 			xs <- atLeast 0 (elements c') 			return (x:xs)++#line 1306 "src/types.anansi" instance Arbitrary ErrorName where 	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary++#line 1342 "src/types.anansi" instance Arbitrary MemberName where 	arbitrary = sizedText 255 genName where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"@@ -277,10 +339,16 @@ 			x <- elements c 			xs <- atLeast 0 (elements c') 			return . TL.pack $ (x:xs)++#line 73 "src/messages.anansi" instance Arbitrary Flag where 	arbitrary = elements [NoReplyExpected, NoAutoStart]++#line 131 "src/messages.anansi" instance Arbitrary Serial where 	arbitrary = fmap Serial arbitrary++#line 173 "src/messages.anansi" instance Arbitrary MethodCall where 	arbitrary = do 		path   <- arbitrary@@ -290,12 +358,16 @@ 		flags  <- fmap Set.fromList arbitrary 		Structure body <- arbitrary 		return $ MethodCall path member iface dest flags body++#line 210 "src/messages.anansi" instance Arbitrary MethodReturn where 	arbitrary = do 		serial <- arbitrary 		dest   <- arbitrary 		Structure body <- arbitrary 		return $ MethodReturn serial dest body++#line 261 "src/messages.anansi" instance Arbitrary Error where 	arbitrary = do 		name   <- arbitrary@@ -303,6 +375,8 @@ 		dest   <- arbitrary 		Structure body <- arbitrary 		return $ Error name serial dest body++#line 300 "src/messages.anansi" instance Arbitrary Signal where 	arbitrary = do 		path   <- arbitrary@@ -311,8 +385,12 @@ 		dest   <- arbitrary 		Structure body <- arbitrary 		return $ Signal path member iface dest body++#line 58 "src/wire.anansi" instance Arbitrary Endianness where 	arbitrary = elements [LittleEndian, BigEndian]++#line 1188 "src/wire.anansi" prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where 	sig = mkSignature . typeCode . variantType $ x@@ -345,6 +423,8 @@  prop_WireSignal e serial msg = prop_MarshalMessage e serial msg 	$ ReceivedSignal serial Nothing msg++#line 138 "src/addresses.anansi" instance Arbitrary Address where 	arbitrary = genAddress where 		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."@@ -381,6 +461,8 @@ 			let addrStr = concat [m, ":", params, extraSemicolon] 			let Just [addr] = mkAddresses $ TL.pack addrStr 			return addr++#line 443 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do 	let nonRoot = do@@ -443,6 +525,8 @@ 			[[], [I.Read], [I.Write], 			 [I.Read, I.Write]] 		return $ I.Property (TL.pack name) sig access++#line 187 "src/util.anansi" halfSized :: Gen a -> Gen a halfSized gen = sized $ \n -> if n > 0 then 	resize (n `div` 2) gen@@ -466,9 +550,13 @@  isRight :: Either a b -> Bool isRight = either (const False) (const True)++#line 216 "src/util.anansi" test :: Testable a => F.TestName -> a -> F.Test test name prop = F.plusTestOptions options (testProperty name prop) where 	options = F.TestOptions Nothing (Just 1) Nothing Nothing++#line 225 "src/util.anansi" instance Arbitrary Word8 where 	arbitrary = arbitraryBoundedIntegral 	shrink    = shrinkIntegral

@@ -30,8 +30,8 @@ import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))+import qualified Text.ParserCombinators.Parsec as P+import Text.ParserCombinators.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe) : 

@@ -44,6 +44,7 @@ :d authentication imports import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString+import Data.ByteString.Lazy.Char8 () import qualified DBus.UUID as UUID : 

@@ -190,7 +190,7 @@ value must be converted from host order using {\tt Data.Binary}.  :d connection imports-import qualified Text.Parsec as P+import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be)@@ -202,7 +202,10 @@ 		P.eof 		let value = read chars :: Integer 		unless (value > 0 && value <= 65535) $-			P.parserFail "bad port" >> return ()+			-- Calling 'fail' is acceptable here, because Parsec 2+			-- offers no other error reporting mechanism, and+			-- implements 'fail'.+			fail "bad port" 		let word = fromIntegral value 		return $ runGet getWord16host (runPut (putWord16be word)) :

@@ -25,18 +25,18 @@ <!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"          "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"> <node name="/org/example/example">-	<interface name="org.example.ExampleInterface">-		<method name="Echo">-			<arg name="text" type="s" direction="in"/>-			<arg type="s" direction="out"/>-		</method>-		<signal name="Echoed">-			<arg type="s"/>-		</signal>-		<property name="EchoCount" type="u" access="read"/>-	</interface>-	<node name="child_a"/>-	<node name="child/b"/>+    <interface name="org.example.ExampleInterface">+        <method name="Echo">+            <arg name="text" type="s" direction="in"/>+            <arg type="s" direction="out"/>+        </method>+        <signal name="Echoed">+            <arg type="s"/>+        </signal>+        <property name="EchoCount" type="u" access="read"/>+    </interface>+    <node name="child_a"/>+    <node name="child/b"/> </node> \end{verbatim} @@ -59,13 +59,6 @@ import qualified DBus.Types as T : -HaXml is used to do the heavy lifting of XML parsing because HXT cannot-be combined with Parsec 3.--:d introspection imports-import qualified Text.XML.HaXml as H-:- \subsection{Data types}  :f DBus/Introspection.hs@@ -93,37 +86,71 @@  \subsection{Parsing XML} -The root {\tt node} is special, in that it's the only {\tt node} which is-not required to have a {\tt name} attribute. If the root has no {\tt name},-its path will default to the path of the introspected object.- If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the elements directly accessed by the parser, no effort is made to check the document's validity because there is no DTD as of yet. -:d introspection imports-import Text.XML.HaXml.Parse (xmlParse')-import DBus.Util (eitherToMaybe)-:- :f DBus/Introspection.hs fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do-	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text-	let (H.Document _ _ root _) = doc+	root <- parseElement text 	parseRoot path root : +LibXML's event-based parsing is used to convert the input into a list of+events. DBus's introspection format doesn't use any character data, so only+the element attributes and nesting are preserved.++:d introspection imports+import qualified Data.XML.Types as X+import qualified Text.XML.LibXML.SAX as SAX+import Control.Monad.ST (runST)+import qualified Data.STRef as ST+import Data.Text.Encoding (encodeUtf8)+:++:f DBus/Introspection.hs+parseElement :: Text -> Maybe X.Element+parseElement text = runST $ do+	stackRef <- ST.newSTRef [([], [])]+	let callbacks = SAX.ParserCallbacks+		{ SAX.parsedBeginElement = \_ attrs -> do+			ST.modifySTRef stackRef ((attrs, []):)+		, SAX.parsedEndElement = \name -> do+			stack <- ST.readSTRef stackRef+			let (attrs, children'):stack' = stack+			let e = X.Element name attrs (map X.NodeElement (reverse children'))+			let (pAttrs, pChildren):stack'' = stack'+			let parent = (pAttrs, e:pChildren)+			ST.writeSTRef stackRef (parent:stack'')+		, SAX.parsedCharacters = \_ -> return ()+		, SAX.parsedComment = \_ -> return ()+		, SAX.parsedProcessingInstruction = \_ -> return ()+		}+	let onError _ = ST.writeSTRef stackRef []+	p <- SAX.newParser callbacks onError Nothing+	mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text+	SAX.parseComplete p+	stack <- ST.readSTRef stackRef+	return $ case stack of+		[] -> Nothing+		(_, children'):_ -> Just $ head children'+:++The root {\tt node} is special, in that it's the only {\tt node} which is+not required to have a {\tt name} attribute. If the root has no {\tt name},+its path will default to the path of the introspected object.+ Even though the root object's {\tt name} is optional, if present, it must still be a valid object path.  :f DBus/Introspection.hs-parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object+parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do-	path <- case getAttr "name" e of+	path <- case getattrM "name" e of 		Nothing -> Just defaultPath 		Just x  -> T.mkObjectPath x-	parseObject' path e+	parseObject path e :  Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}@@ -131,37 +158,37 @@ the root object's path.  :f DBus/Introspection.hs-parseChild :: T.ObjectPath -> H.Element a -> Maybe Object+parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do 	let parentPath' = case T.strObjectPath parentPath of 		"/" -> "/" 		x   -> TL.append x "/"-	pathSegment <- getAttr "name" e+	pathSegment <- getattrM "name" e 	path <- T.mkObjectPath $ TL.append parentPath' pathSegment-	parseObject' path e+	parseObject path e :  Other than the name, both root and non-root {\tt nodes} have identical contents.  They may contain interface definitions, and child {\tt node}s.  :f DBus/Introspection.hs-parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object-parseObject' path e@(H.Elem "node" _ _)  = do-	interfaces <- children parseInterface (H.tag "interface") e-	children' <- children (parseChild path) (H.tag "node") e+parseObject :: T.ObjectPath -> X.Element -> Maybe Object+parseObject path e | X.elementName e == toName "node" = do+	interfaces <- children parseInterface (named "interface") e+	children' <- children (parseChild path) (named "node") e 	return $ Object path interfaces children'-parseObject' _ _ = Nothing+parseObject _ _ = Nothing :  Interfaces may contain methods, signals, and properties.  :f DBus/Introspection.hs-parseInterface :: H.Element a -> Maybe Interface+parseInterface :: X.Element -> Maybe Interface parseInterface e = do-	name <- T.mkInterfaceName =<< getAttr "name" e-	methods <- children parseMethod (H.tag "method") e-	signals <- children parseSignal (H.tag "signal") e-	properties <- children parseProperty (H.tag "property") e+	name <- T.mkInterfaceName =<< getattrM "name" e+	methods <- children parseMethod (named "method") e+	signals <- children parseSignal (named "signal") e+	properties <- children parseProperty (named "property") e 	return $ Interface name methods signals properties : @@ -169,9 +196,9 @@ if no direction is specified.  :f DBus/Introspection.hs-parseMethod :: H.Element a -> Maybe Method+parseMethod :: X.Element -> Maybe Method parseMethod e = do-	name <- T.mkMemberName =<< getAttr "name" e+	name <- T.mkMemberName =<< getattrM "name" e 	paramsIn <- children parseParameter (isParam ["in", ""]) e 	paramsOut <- children parseParameter (isParam ["out"]) e 	return $ Method name paramsIn paramsOut@@ -180,9 +207,9 @@ Signals are similar to methods, except they have no ``in'' parameters.  :f DBus/Introspection.hs-parseSignal :: H.Element a -> Maybe Signal+parseSignal :: X.Element -> Maybe Signal parseSignal e = do-	name <- T.mkMemberName =<< getAttr "name" e+	name <- T.mkMemberName =<< getattrM "name" e 	params <- children parseParameter (isParam ["out", ""]) e 	return $ Signal name params :@@ -190,17 +217,17 @@ A parameter has a free-form name, and a single valid type.  :f DBus/Introspection.hs-parseParameter :: H.Element a -> Maybe Parameter+parseParameter :: X.Element -> Maybe Parameter parseParameter e = do-	let name = getAttr' "name" e+	let name = getattr "name" e 	sig <- parseType e 	return $ Parameter name sig :  :f DBus/Introspection.hs-parseType :: H.Element a -> Maybe T.Signature+parseType :: X.Element -> Maybe T.Signature parseType e = do-	sig <- T.mkSignature =<< getAttr "type" e+	sig <- T.mkSignature =<< getattrM "type" e 	case T.signatureTypes sig of 		[_] -> Just sig 		_   -> Nothing@@ -210,11 +237,11 @@ Each property may be read, written, or both, and has an associated type.  :f DBus/Introspection.hs-parseProperty :: H.Element a -> Maybe Property+parseProperty :: X.Element -> Maybe Property parseProperty e = do-	let name = getAttr' "name" e+	let name = getattr "name" e 	sig <- parseType e-	access <- case getAttr' "access" e of+	access <- case getattr "access" e of 		""          -> Just [] 		"read"      -> Just [Read] 		"write"     -> Just [Write]@@ -223,182 +250,191 @@ 	return $ Property name sig access : -HaXml doesn't seem to have any way to retrieve the ``real'' value of an-attribute, so {\tt attrValue} implements this.- :d introspection imports-import Data.Char (chr)+import Control.Monad ((>=>))+import Data.Maybe (fromMaybe, listToMaybe) :  :f DBus/Introspection.hs-attrValue :: H.AttValue -> Maybe Text-attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where-	(H.AttValue parts) = attr-	-	unescape (Left x) = Just x-	unescape (Right (H.RefEntity x)) = lookup x namedRefs-	unescape (Right (H.RefChar x)) = Just [chr x]-	-	namedRefs =-		[ ("lt", "<")-		, ("gt", ">")-		, ("amp", "&")-		, ("apos", "'")-		, ("quot", "\"")-		]-:--Some helper functions for dealing with HaXml filters+getattrM :: Text -> X.Element -> Maybe Text+getattrM name = fmap attrText . listToMaybe . attrs where+	attrText = textContent . X.attributeContent+	attrs = X.elementAttributes >=> X.isNamed (toName name)+	textContent cs = TL.concat [t | X.ContentText t <- cs] -:d introspection imports-import Data.Maybe (fromMaybe)-:+getattr :: Text -> X.Element -> Text+getattr = (fromMaybe "" .) . getattrM -:f DBus/Introspection.hs-getAttr :: String -> H.Element a -> Maybe Text-getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue+isParam :: [Text] -> X.Element -> [X.Element]+isParam dirs = named "arg" >=> checkDir where+	checkDir e = [e | getattr "direction" e `elem` dirs] -getAttr' :: String -> H.Element a -> Text-getAttr' = (fromMaybe "" .) . getAttr+children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b]+children f p = mapM f . concatMap p . X.elementChildren -isParam :: [Text] -> H.CFilter a-isParam dirs content = do-	arg@(H.CElem e _) <- H.tag "arg" content-	let direction = getAttr' "direction" e-	[arg | direction `elem` dirs]+named :: X.Named a => Text -> a -> [a]+named = X.isNamed . toName -children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]-children f filt (H.Elem _ _ contents) =-	mapM f [x | (H.CElem x _) <- concatMap filt contents]+toName :: Text -> X.Name+toName t = X.Name t Nothing Nothing :  \subsection{Generating XML} -:f DBus/Introspection.hs-dtdPublicID, dtdSystemID :: String-dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"-:+Generating XML can fail; if a child object's path is not a sub-path of the+parent, {\tt toXML} will return {\tt Nothing}. -HaXml punts to the {\tt pretty} package for serialising XML.+To simplify XML serialization, a variant of {\tt Writer} is used to combine+text fragments with optional failure. This would be {\tt WriterT Text Maybe},+except I didn't want to drag in a dependency on {\tt transformers} for such+a little thing. -:d introspection imports-import Text.XML.HaXml.Pretty (document)-import Text.PrettyPrint.HughesPJ (render)+:f DBus/Introspection.hs+newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) }++instance Monad XmlWriter where+	return a = XmlWriter $ Just (a, TL.empty)+	m >>= f = XmlWriter $ do+		(a, w) <- runXmlWriter m+		(b, w') <- runXmlWriter (f a)+		return (b, TL.append w w') : -Generating XML can fail; if a child object's path is not a sub-path of the-parent, {\tt toXML} will return {\tt Nothing}.+:f DBus/Introspection.hs+tell :: Text -> XmlWriter ()+tell t = XmlWriter $ Just ((), t)+:  :f DBus/Introspection.hs toXML :: Object -> Maybe Text-toXML obj = fmap (TL.pack . render . document) doc where-	prolog = H.Prolog Nothing [] (Just doctype) []-	doctype = H.DTD "node" (Just (H.PUBLIC-		(H.PubidLiteral dtdPublicID)-		(H.SystemLiteral dtdSystemID))) []-	doc = do-		root <- xmlRoot obj-		return $ H.Document prolog H.emptyST root []+toXML obj = do+	(_, text) <- runXmlWriter (writeRoot obj)+	return text : -When writing objects to {\tt node}s, the root object must have an absolute-path, and children must have paths relative to their parent.- :f DBus/Introspection.hs-xmlRoot :: Object -> Maybe (H.Element a)-xmlRoot obj@(Object path _ _) = do-	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-	return root+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.strObjectPath path) obj :  :f DBus/Introspection.hs-xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)-xmlObject parentPath obj@(Object path _ _) = do-	let path' = T.strObjectPath path-	    parent' = T.strObjectPath parentPath-	relpath <- if TL.isPrefixOf parent' path'+writeChild :: T.ObjectPath -> Object -> XmlWriter ()+writeChild parentPath obj@(Object path _ _) = write where+	path' = T.strObjectPath path+	parent' = T.strObjectPath parentPath+	relpathM = if TL.isPrefixOf parent' path' 		then Just $ if parent' == "/" 			then TL.drop 1 path' 			else TL.drop (TL.length parent' + 1) path' 		else Nothing-	xmlObject' relpath obj+	+	write = case relpathM of+		Just relpath -> writeObject relpath obj+		Nothing -> XmlWriter Nothing :  :f DBus/Introspection.hs-xmlObject' :: Text -> Object -> Maybe (H.Content a)-xmlObject' path (Object fullPath interfaces children') = do-	children'' <- mapM (xmlObject fullPath) children'-	return $ mkElement "node"-		[mkAttr "name" $ TL.unpack path]-		$ concat-			[ map xmlInterface interfaces-			, children''-			]+writeObject :: Text -> Object -> XmlWriter ()+writeObject path (Object fullPath interfaces children') = writeElement "node"+	[("name", path)] $ do+		mapM_ writeInterface interfaces+		mapM_ (writeChild fullPath) children' :  :f DBus/Introspection.hs-xmlInterface :: Interface -> H.Content a-xmlInterface (Interface name methods signals properties) =-	mkElement "interface"-		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]-		$ concat-			[ map xmlMethod methods-			, map xmlSignal signals-			, map xmlProperty properties-			]+writeInterface :: Interface -> XmlWriter ()+writeInterface (Interface name methods signals properties) = writeElement "interface"+	[("name", T.strInterfaceName name)] $ do+		mapM_ writeMethod methods+		mapM_ writeSignal signals+		mapM_ writeProperty properties :  :f DBus/Introspection.hs-xmlMethod :: Method -> H.Content a-xmlMethod (Method name inParams outParams) = mkElement "method"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ concat-		[ map (xmlParameter "in") inParams-		, map (xmlParameter "out") outParams-		]+writeMethod :: Method -> XmlWriter ()+writeMethod (Method name inParams outParams) = writeElement "method"+	[("name", T.strMemberName name)] $ do+		mapM_ (writeParameter "in") inParams+		mapM_ (writeParameter "out") outParams :  :f DBus/Introspection.hs-xmlSignal :: Signal -> H.Content a-xmlSignal (Signal name params) = mkElement "signal"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ map (xmlParameter "out") params+writeSignal :: Signal -> XmlWriter ()+writeSignal (Signal name params) = writeElement "signal"+	[("name", T.strMemberName name)] $ do+		mapM_ (writeParameter "out") params :  :f DBus/Introspection.hs-xmlParameter :: String -> Parameter -> H.Content a-xmlParameter direction (Parameter name sig) = mkElement "arg"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "direction" direction-	] []+writeParameter :: Text -> Parameter -> XmlWriter ()+writeParameter direction (Parameter name sig) = writeEmptyElement "arg"+	[ ("name", name)+	, ("type", T.strSignature sig)+	, ("direction", direction)+	] :  :f DBus/Introspection.hs-xmlProperty :: Property -> H.Content a-xmlProperty (Property name sig access) = mkElement "property"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "access" $ xmlAccess access-	] []+writeProperty :: Property -> XmlWriter ()+writeProperty (Property name sig access) = writeEmptyElement "property"+	[ ("name", name)+	, ("type", T.strSignature sig)+	, ("access", strAccess access)+	] :  :f DBus/Introspection.hs-xmlAccess :: [PropertyAccess] -> String-xmlAccess access = readS ++ writeS where+strAccess :: [PropertyAccess] -> Text+strAccess access = TL.append readS writeS where 	readS = if elem Read access then "read" else "" 	writeS = if elem Write access then "write" else "" :  :f DBus/Introspection.hs-mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a-mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined+writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter ()+writeElement name attrs content = do+	tell "<"+	tell name+	mapM_ writeAttribute attrs+	tell ">"+	content+	tell "</"+	tell name+	tell ">"+: -mkAttr :: String -> String -> H.Attribute-mkAttr name value = (name, H.AttValue [Left escaped]) where-	raw = H.CString True value ()-	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]+:f DBus/Introspection.hs+writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter ()+writeEmptyElement name attrs = do+	tell "<"+	tell name+	mapM_ writeAttribute attrs+	tell "/>"+:++:f DBus/Introspection.hs+writeAttribute :: (Text, Text) -> XmlWriter ()+writeAttribute (name, content) = do+	tell " "+	tell name+	tell "='"+	tell (escape content)+	tell "'"+:++:f DBus/Introspection.hs+escape :: Text -> Text+escape = TL.concatMap escapeChar where+	escapeChar c = case c of+		'&' -> "&amp;"+		'<' -> "&lt;"+		'>' -> "&gt;"+		'"' -> "&quot;"+		'\'' -> "&apos;"+		_ -> TL.singleton c :  \subsection{Test support}

@@ -16,17 +16,28 @@ \section{Types}  The {\tt DBus.Types module} defines interfaces for storing, building, and-deconstructing D-Bus values.+deconstructing D-Bus values. Everything is defined in an internal module, and+then exported via the public interface. -:f DBus/Types.cpphs+:f DBus/Types.hs |copyright|-|text extensions|-|type extensions| module DBus.Types ( 	|type exports| 	) where+import DBus.Types.Internal+:++:f DBus/Types/Internal.cpphs+|copyright|+|text extensions|+|type extensions|+module DBus.Types.Internal where |text imports| |type imports|+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BL8 :  D-Bus types are divided into two categories, ``atomic'' and ``container''@@ -37,7 +48,7 @@  Internally, types are represented using an enumeration. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs data Type 	= DBusBoolean 	| DBusByte@@ -58,7 +69,7 @@ 	deriving (Show, Eq) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs |apidoc isAtomicType| isAtomicType :: Type -> Bool isAtomicType DBusBoolean    = True@@ -79,7 +90,7 @@ Each type can be converted to a textual representation, used in ``type signatures'' or for debugging. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs |apidoc typeCode| typeCode :: Type -> Text |type codes|@@ -135,7 +146,7 @@ outside of this module, {\tt Variant}s can only be constructed from pre-defined types. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs |apidoc Variant| data Variant 	= VarBoxBool Bool@@ -171,7 +182,7 @@ be parsed or inspected or anything like that, since the output format might change drastically. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Show Variant where 	showsPrec d var = showParen (d > 10) full where 		full = s "Variant " . shows code . s " " . valueStr@@ -203,7 +214,7 @@ {\tt variantType} is used to retrieve which type is actually stored within a {\tt Variant}. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs |apidoc variantType| variantType :: Variant -> Type variantType var = case var of@@ -228,6 +239,9 @@ 	(VarBoxStructure x) -> let 		Structure items = x 		in DBusStructure (map variantType items)++variantSignature :: Variant -> Maybe Signature+variantSignature = mkBytesSignature . typeCodeB . variantType :  :d type exports@@ -237,7 +251,7 @@ A macro is useful for reducing verbosity in simple {\tt Variable} instances. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs #define INSTANCE_VARIABLE(TYPE) \ 	instance Variable TYPE where \ 		{ toVariant = VarBox/**/TYPE \@@ -248,7 +262,7 @@  Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Variant) : @@ -312,7 +326,7 @@ import Data.Int (Int16, Int32, Int64) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Bool) INSTANCE_VARIABLE(Word8) INSTANCE_VARIABLE(Int16)@@ -330,7 +344,7 @@ inefficent. To provide better performance for large strings, packed Unicode strings defined in {\tt Data.Text} are used internally. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Variable TL.Text where 	toVariant = VarBoxString 	fromVariant (VarBoxString x) = Just x@@ -345,7 +359,7 @@ import qualified Data.Text as T : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Variable T.Text where 	toVariant = toVariant . TL.fromChunks . (:[]) 	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant@@ -358,7 +372,7 @@ {-# LANGUAGE TypeSynonymInstances #-} : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Variable String where 	toVariant = toVariant . TL.pack 	fromVariant = fmap TL.unpack . fromVariant@@ -391,7 +405,7 @@ one requires using the {\tt mkSignature} function, which will convert a valid D-Bus signature string into a {\tt Signature}. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Signature) data Signature = Signature { signatureTypes :: [Type] } 	deriving (Eq)@@ -404,7 +418,10 @@ Signatures can also be converted back into text, by concatenating the type codes of their contained types. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs+bytesSignature :: Signature -> B.ByteString+bytesSignature (Signature ts) = B.concat $ map typeCodeB ts+ strSignature :: Signature -> Text strSignature (Signature ts) = TL.concat $ map typeCode ts :@@ -416,7 +433,7 @@ import Data.Ord (comparing) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Ord Signature where 	compare = comparing strSignature :@@ -433,34 +450,41 @@ For atomic types, the type code is a single letter. Arrays, structures, and dictionary types are multiple characters. +:d type imports+import Data.Text.Encoding (decodeUtf8)+:+ :d type codes-typeCode DBusBoolean    = "b"-typeCode DBusByte       = "y"-typeCode DBusInt16      = "n"-typeCode DBusInt32      = "i"-typeCode DBusInt64      = "x"-typeCode DBusWord16     = "q"-typeCode DBusWord32     = "u"-typeCode DBusWord64     = "t"-typeCode DBusDouble     = "d"-typeCode DBusString     = "s"-typeCode DBusSignature  = "g"-typeCode DBusObjectPath = "o"-typeCode DBusVariant    = "v"+typeCode t = TL.fromChunks [decodeUtf8 $ typeCodeB t]++typeCodeB :: Type -> B.ByteString+typeCodeB DBusBoolean    = "b"+typeCodeB DBusByte       = "y"+typeCodeB DBusInt16      = "n"+typeCodeB DBusInt32      = "i"+typeCodeB DBusInt64      = "x"+typeCodeB DBusWord16     = "q"+typeCodeB DBusWord32     = "u"+typeCodeB DBusWord64     = "t"+typeCodeB DBusDouble     = "d"+typeCodeB DBusString     = "s"+typeCodeB DBusSignature  = "g"+typeCodeB DBusObjectPath = "o"+typeCodeB DBusVariant    = "v" :  An array's type code is ``a'' followed by the type it contains. For example, an array of booleans would have the type string ``ab''.  :d type codes-typeCode (DBusArray t) = TL.cons 'a' $ typeCode t+typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t :  A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example, a dictionary of bytes to booleans would have the type string ``a\{yb\}''.  :d type codes-typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]+typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"] :  A structure's type code is the concatenation of its contained types,@@ -468,112 +492,201 @@ type code is simply ``()''.  :d type codes-typeCode (DBusStructure ts) = TL.concat $-	["("] ++ map typeCode ts ++ [")"]+typeCodeB (DBusStructure ts) = B.concat $+	["("] ++ map typeCodeB ts ++ [")"] :  \subsubsection{Parsing}  When parsing, additional restrictions apply which are not inherent to the-D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is-valid according to D-Bus rules.+D-Bus type system. The signature parsing functions guarantee that any+{\tt Signature} is valid according to D-Bus rules. -:f DBus/Types.cpphs-mkSignature :: Text -> Maybe Signature-mkSignature text = parsed where-	|fast signature parser|-	|slow signature parser|-	parsed = case TL.length text of-		0 -> Just $ Signature []-		1 -> fast-		_ -> slow+Signature parsing is the most common operation when unmarshaling messages;+therefore, an efficient parsing implementation is essential.++Since all valid signatures as entirely ASCII, it's possible to parse them+using byte-based parsers for better performance. These aren't exported from+the public interface, but are still used within {\tt DBus.Wire} modules.++:d type imports+import qualified Data.ByteString.Unsafe as B+import qualified Foreign as F+import System.IO.Unsafe (unsafePerformIO) : -Since single-type and empty signatures are very common, they are-special-cased for performance.+There are three special cases which can be optimized: -:d fast signature parser-just t = Just $ Signature [t]-fast = case TL.head text of-	'b' -> just DBusBoolean-	'y' -> just DBusByte-	'n' -> just DBusInt16-	'i' -> just DBusInt32-	'x' -> just DBusInt64-	'q' -> just DBusWord16-	'u' -> just DBusWord32-	't' -> just DBusWord64-	'd' -> just DBusDouble-	's' -> just DBusString-	'g' -> just DBusSignature-	'o' -> just DBusObjectPath-	'v' -> just DBusVariant-	_   -> Nothing+\begin{enumerate}+\item Empty signatures occur when messages have no body, and can use a constant+      result.+\item Single-character signatures occur when parsing variants, and can use a+      faster atom-only parser.+\item Signatures larger than 255 characters are invalid.+\end{enumerate}++:f DBus/Types/Internal.cpphs+mkBytesSignature :: B.ByteString -> Maybe Signature+mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where+	|fast signature parser|+	|slow signature parser|+	+	io (cstr, len) = case len of+		0 -> return $ Just $ Signature []+		1 -> fmap fast $ F.peek cstr+		_ | len <= 255 -> slow (F.castPtr cstr) len+		_ -> return Nothing : -Parsec is used to parse more complex signatures.+:d fast signature parser+parseAtom c yes no = case c of+	0x62 -> yes DBusBoolean+	0x79 -> yes DBusByte+	0x6E -> yes DBusInt16+	0x69 -> yes DBusInt32+	0x78 -> yes DBusInt64+	0x71 -> yes DBusWord16+	0x75 -> yes DBusWord32+	0x74 -> yes DBusWord64+	0x64 -> yes DBusDouble+	0x73 -> yes DBusString+	0x67 -> yes DBusSignature+	0x6F -> yes DBusObjectPath+	_ -> no -:d type imports-import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import DBus.Util (checkLength, parseMaybe)+fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of+	0x76 -> Just (Signature [DBusVariant])+	_ -> Nothing :  :d slow signature parser-slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text-sigParser = do-	types <- P.many parseType-	P.eof-	return $ Signature types+slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature)+slow buf len = loop [] 0 where+	loop acc ii | ii >= len = return . Just . Signature $ reverse acc+	loop acc ii = do+		c <- F.peekElemOff buf ii+		let next t = loop (t : acc) (ii + 1)+		parseAtom c next $ case c of+			0x76 -> next DBusVariant+			+			-- '('+			0x28 -> do+				mt <- structure buf len (ii + 1)+				case mt of+					Just (ii', t) -> loop (t : acc) ii'+					Nothing -> return Nothing+			+			-- 'a'+			0x61 -> do+				mt <- array buf len (ii + 1)+				case mt of+					Just (ii', t) -> loop (t : acc) ii'+					Nothing -> return Nothing+			+			_ -> return Nothing : -Types may be either containers or atoms. Containers can't be dictionary-keys.+:d slow signature parser+structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+structure buf len = loop [] where+	loop _ ii | ii >= len = return Nothing+	loop acc ii = do+		c <- F.peekElemOff buf ii+		let next t = loop (t : acc) (ii + 1)+		parseAtom c next $ case c of+			0x76 -> next DBusVariant+			+			-- '('+			0x28 -> do+				mt <- structure buf len (ii + 1)+				case mt of+					Just (ii', t) -> loop (t : acc) ii'+					Nothing -> return Nothing+			+			-- ')'+			0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc))+			+			-- 'a'+			0x61 -> do+				mt <- array buf len (ii + 1)+				case mt of+					Just (ii', t) -> loop (t : acc) ii'+					Nothing -> return Nothing+			+			_ -> return Nothing+:  :d slow signature parser-parseType = parseAtom <|> parseContainer-parseContainer =-	    parseArray-	<|> parseStruct-	<|> (P.char 'v' >> return DBusVariant)+array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+array _   len ii | ii >= len = return Nothing+array buf len ii = do+	c <- F.peekElemOff buf ii+	let next t = return $ Just (ii + 1, DBusArray t)+	parseAtom c next $ case c of+		0x76 -> next DBusVariant+		+		-- '('+		0x28 -> do+			mt <- structure buf len (ii + 1)+			case mt of+				Just (ii', t) -> return $ Just (ii', DBusArray t)+				Nothing -> return Nothing+		+		-- '{'+		0x7B -> dict buf len (ii + 1)+		+		-- 'a'+		0x61 -> do+			mt <- array buf len (ii + 1)+			case mt of+				Just (ii', t) -> return $ Just (ii', DBusArray t)+				Nothing -> return Nothing+		+		_ -> return Nothing :  :d slow signature parser-parseArray = do-	P.char 'a'-	parseDict <|> fmap DBusArray parseType-parseDict = do-	P.char '{'-	keyType <- parseAtom-	valueType <- parseType-	P.char '}'-	return $ DBusDictionary keyType valueType+dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))+dict _   len ii | ii + 1 >= len = return Nothing+dict buf len ii = do+	c1 <- F.peekElemOff buf ii+	c2 <- F.peekElemOff buf (ii + 1)+	+	let mt1 = parseAtom c1 Just Nothing+	+	let next t = return $ Just (ii + 2, t)+	mt2 <- parseAtom c2 next $ case c2 of+		0x76 -> next DBusVariant+		+		-- '('+		0x28 -> structure buf len (ii + 2)+		+		-- 'a'+		0x61 -> array buf len (ii + 2)+		+		_ -> return Nothing+	+	case mt2 of+		Nothing -> return Nothing+		Just (ii', t2) -> if ii' >= len+			then return Nothing+			else do+				c3 <- F.peekElemOff buf ii'+				return $ do+					if c3 == 0x7D then Just () else Nothing+					t1 <- mt1+					Just (ii' + 1, DBusDictionary t1 t2) : -Structures can contain any types.+The public interface for building signatures is {\tt Text}-based. -:d slow signature parser-parseStruct = do-	P.char '('-	types <- P.many parseType-	P.char ')'-	return $ DBusStructure types+:d type imports+import Data.Text.Lazy.Encoding (encodeUtf8) : -:d slow signature parser-parseAtom =-	    (P.char 'b' >> return DBusBoolean)-	<|> (P.char 'y' >> return DBusByte)-	<|> (P.char 'n' >> return DBusInt16)-	<|> (P.char 'i' >> return DBusInt32)-	<|> (P.char 'x' >> return DBusInt64)-	<|> (P.char 'q' >> return DBusWord16)-	<|> (P.char 'u' >> return DBusWord32)-	<|> (P.char 't' >> return DBusWord64)-	<|> (P.char 'd' >> return DBusDouble)-	<|> (P.char 's' >> return DBusString)-	<|> (P.char 'g' >> return DBusSignature)-	<|> (P.char 'o' >> return DBusObjectPath)+:f DBus/Types/Internal.cpphs+mkSignature :: Text -> Maybe Signature+mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8 :  Since many signatures are defined as string literals, it's useful to@@ -585,12 +698,12 @@ import qualified Data.String as String : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature  instance String.IsString Signature where-	fromString = mkSignature_ . TL.pack+	fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack :  Most signature-related functions are exposed to clients, except the@@ -602,6 +715,18 @@ , mkSignature_ : +Checking if a type is valid according to signature rules is common, and if+performed through the signature parser, slow. Since such types are already+guaranteed to be structurally valid, the only test needed is whether their+size is within bounds.++:f DBus/Types/Internal.cpphs+maybeValidType :: Type -> Maybe ()+maybeValidType t = if B.length (typeCodeB t) > 255+	then Nothing+	else Just ()+:+ :f Tests.hs instance Arbitrary Signature where 	arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary@@ -616,7 +741,7 @@  \subsection{Object paths} -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath 	{ strObjectPath :: Text@@ -643,7 +768,13 @@ Element names are separated by {\tt '/'}, and the path may not end in {\tt '/'} unless it is the root path. -:f DBus/Types.cpphs+:d type imports+import Text.ParserCombinators.Parsec ((<|>))+import qualified Text.ParserCombinators.Parsec as P+import DBus.Util (checkLength, parseMaybe)+:++:f DBus/Types/Internal.cpphs mkObjectPath :: Text -> Maybe ObjectPath mkObjectPath s = parseMaybe path' (TL.unpack s) where 	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"@@ -687,16 +818,11 @@ Many D-Bus APIs represent binary data using an array of bytes; therefore, there is a special constructor for {\tt ByteString}-based arrays. -:d type imports-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as ByteString-:--:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Array) data Array 	= VariantArray Type [Variant]-	| ByteArray ByteString+	| ByteArray BL.ByteString 	deriving (Eq)  |apidoc arrayType|@@ -706,7 +832,7 @@  arrayItems :: Array -> [Variant] arrayItems (VariantArray _ xs) = xs-arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs+arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs :  :d type exports@@ -719,7 +845,7 @@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly just useful for debugging. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Show Array where 	showsPrec d array = showParen (d > 10) $ 		s "Array " . showSig . s " [" . s valueString . s "]" where@@ -733,12 +859,12 @@ will be checked for validity. Every item in the array will be checked against the item type, to ensure the array is homogenous. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)+arrayFromItems DBusByte vs = fmap (ByteArray . BL.pack) (mapM fromVariant vs)  arrayFromItems t vs = do-	mkSignature (typeCode t)+	maybeValidType t 	if all (\x -> variantType x == t) vs 		then Just $ VariantArray t vs 		else Nothing@@ -747,7 +873,7 @@ Additionally, for ease of use, an {\tt Array} can be converted directly to/from lists of {\tt Variable} values. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs toArray :: Variable a => Type -> [a] -> Maybe Array toArray t = arrayFromItems t . map toVariant @@ -764,12 +890,12 @@ To provide a more efficient interface for byte array literals, these functions bypass the conversions in {\tt toArray} and {\tt fromArray} -:f DBus/Types.cpphs-arrayToBytes :: Array -> Maybe ByteString+:f DBus/Types/Internal.cpphs+arrayToBytes :: Array -> Maybe BL.ByteString arrayToBytes (ByteArray x) = Just x arrayToBytes _             = Nothing -arrayFromBytes :: ByteString -> Array+arrayFromBytes :: BL.ByteString -> Array arrayFromBytes = ByteArray : @@ -781,22 +907,16 @@ And to simplify inclusion of {\tt ByteString}s in message, instances of {\tt Variable} exist for both strict and lazy {\tt ByteString}. -:f DBus/Types.cpphs-instance Variable ByteString where+:f DBus/Types/Internal.cpphs+instance Variable BL.ByteString where 	toVariant = toVariant . arrayFromBytes 	fromVariant x = fromVariant x >>= arrayToBytes : -:d type imports-import qualified Data.ByteString as StrictByteString-:--:f DBus/Types.cpphs-instance Variable StrictByteString.ByteString where-	toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]-	fromVariant x = do-		chunks <- ByteString.toChunks `fmap` fromVariant x-		return $ StrictByteString.concat chunks+:f DBus/Types/Internal.cpphs+instance Variable B.ByteString where+	toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x]+	fromVariant = fmap (B.concat . BL.toChunks) . fromVariant :  When generating random arrays for testing, only atomic values are used.@@ -832,8 +952,9 @@ key type must be atomic. Values may be of any valid D-Bus type. Like {\tt Array}, {\tt Dictionary} stores its contained types. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Dictionary)+ data Dictionary = Dictionary 	{ dictionaryKeyType   :: Type 	, dictionaryValueType :: Type@@ -857,7 +978,7 @@ import Data.List (intercalate) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs instance Show Dictionary where 	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ 		s "Dictionary " . showSig . s " {" . s valueString . s "}" where@@ -874,12 +995,12 @@ import Control.Monad (unless) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary dictionaryFromItems kt vt pairs = do 	unless (isAtomicType kt) Nothing-	mkSignature (typeCode kt)-	mkSignature (typeCode vt)+	maybeValidType kt+	maybeValidType vt 	 	let sameType (k, v) = variantType k == kt && 	                      variantType v == vt@@ -897,7 +1018,7 @@ import qualified Data.Map as Map : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b              -> Maybe Dictionary toDictionary kt vt = dictionaryFromItems kt vt . pairs where@@ -908,7 +1029,7 @@ import Control.Monad (forM) : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary                -> Maybe (Map.Map a b) fromDictionary (Dictionary _ _ vs) = do@@ -968,7 +1089,7 @@ (un)marshaling -- dictionaries can be thought of as arrays of two-element structures, much as a {\tt Map} is a list of pairs. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs dictionaryToArray :: Dictionary -> Array dictionaryToArray (Dictionary kt vt items) = array where 	Just array = toArray itemType structs@@ -976,7 +1097,7 @@ 	structs = [Structure [k, v] | (k, v) <- items] : -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs arrayToDictionary :: Array -> Maybe Dictionary arrayToDictionary array = do 	let toPair x = do@@ -1001,8 +1122,9 @@ A heterogeneous, fixed-length container; equivalent in purpose to a Haskell tuple. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Structure)+ data Structure = Structure [Variant] 	deriving (Show, Eq) :@@ -1027,7 +1149,7 @@ declaration and some helper functions), I define a macro to automate the definitions. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs #define NAME_TYPE(TYPE, NAME) \ 	newtype TYPE = TYPE {str/**/TYPE :: Text} \ 		deriving (Eq, Ord); \@@ -1064,7 +1186,7 @@ element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must not start with a digit. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs NAME_TYPE(BusName, "bus name")  mkBusName :: Text -> Maybe BusName@@ -1119,7 +1241,7 @@ element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not start with a digit, and must have at least one character. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs NAME_TYPE(InterfaceName, "interface name")  mkInterfaceName :: Text -> Maybe InterfaceName@@ -1165,7 +1287,7 @@ Error names have the same format as interface names, so the parser logic can just be re-purposed. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs NAME_TYPE(ErrorName, "error name")  mkErrorName :: Text -> Maybe ErrorName@@ -1197,7 +1319,7 @@ Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]}, may not begin with a digit, and must be at least one character long. -:f DBus/Types.cpphs+:f DBus/Types/Internal.cpphs NAME_TYPE(MemberName, "member name")  mkMemberName :: Text -> Maybe MemberName

@@ -57,7 +57,7 @@ :f DBus/Util.hs |copyright| module DBus.Util where-import Text.Parsec (Parsec, parse)+import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt) import Data.List (isPrefixOf) @@ -65,7 +65,7 @@ checkLength length' s | length s <= length' = Just s checkLength _ _ = Nothing -parseMaybe :: Parsec String () a -> String -> Maybe a+parseMaybe :: Parser a -> String -> Maybe a parseMaybe p = either (const Nothing) Just . parse p ""  mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b@@ -115,20 +115,30 @@  :f DBus/Util/MonadError.hs |copyright|-{-# LANGUAGE TypeFamilies #-} module DBus.Util.MonadError-	( ErrorT (..)-	, throwError+	( ErrorM (..)+	, ErrorT (..)+	, throwErrorM+	, throwErrorT 	) where-import Control.Monad.Trans.Class-import Control.Monad.State-import Control.Monad.Error.Class+newtype ErrorM e a = ErrorM { runErrorM :: Either e a } -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }+instance Functor (ErrorM e) where+	fmap f m = ErrorM $ case runErrorM m of+		Left err -> Left err+		Right x -> Right $ f x -instance Functor m => Functor (ErrorT e m) where-	fmap f = ErrorT . fmap (fmap f) . runErrorT+instance Monad (ErrorM e) where+	return = ErrorM . Right+	(>>=) m k = case runErrorM m of+		Left err -> ErrorM $ Left err+		Right x -> k x +throwErrorM :: e -> ErrorM e a+throwErrorM = ErrorM . Left++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }+ instance Monad m => Monad (ErrorT e m) where 	return = ErrorT . return . Right 	(>>=) m k = ErrorT $ do@@ -137,22 +147,8 @@ 			Left l -> return $ Left l 			Right r -> runErrorT $ k r -instance MonadTrans (ErrorT e) where-	lift = ErrorT . liftM Right--instance Monad m => MonadError (ErrorT e m) where-	type ErrorType (ErrorT e m) = e-	throwError = ErrorT . return . Left-	catchError m h = ErrorT $ do-		x <- runErrorT m-		case x of-			Left l -> runErrorT $ h l-			Right r -> return $ Right r--instance MonadState m => MonadState (ErrorT e m) where-	type StateType (ErrorT e m) = StateType m-	get = lift get-	put = lift . put+throwErrorT :: Monad m => e -> ErrorT e m a+throwErrorT = ErrorT . return . Left :  \subsection{Extra test support}

@@ -95,22 +95,50 @@ import Control.Monad (when) import Data.Maybe (fromJust) import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)+import Data.Int (Int64)  import qualified DBus.Types as T+import qualified DBus.Types.Internal as T :  :d marshal imports-import qualified Control.Monad.State as State-import qualified DBus.Util.MonadError as E+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B :  :f DBus/Wire/Marshal.hs-data MarshalState = MarshalState Endianness B.Builder !Word64-type MarshalM = E.ErrorT MarshalError (State.State MarshalState)+data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64++data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState+ type Marshal = MarshalM ()+newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a }++instance Monad MarshalM where+	{-# INLINE return #-}+	return a = MarshalM $ \_ s -> MarshalRR a s+	+	{-# INLINE (>>=) #-}+	m >>= k = MarshalM $ \e s -> case unMarshalM m e s of+		MarshalRL err -> MarshalRL err+		MarshalRR a s' -> unMarshalM (k a) e s'+	+	{-# INLINE (>>) #-}+	m >> k = MarshalM $ \e s -> case unMarshalM m e s of+		MarshalRL err -> MarshalRL err+		MarshalRR _ s' -> unMarshalM k e s'++throwError :: MarshalError -> MarshalM a+throwError err = MarshalM $ \_ _ -> MarshalRL err++{-# INLINE getState #-}+getState :: MarshalM MarshalState+getState = MarshalM $ \_ s -> MarshalRR s s++{-# INLINE putState #-}+putState :: MarshalState -> MarshalM ()+putState s = MarshalM $ \_ _ -> MarshalRR () s :  Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},@@ -118,38 +146,41 @@  :f DBus/Wire/Marshal.hs runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal m e = case State.runState (E.runErrorT m) initialState of-	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)-	(Left  x, _) -> Left x-	where initialState = MarshalState e B.empty 0+runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of+	MarshalRL err -> Left err+	MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder :  :f DBus/Wire/Marshal.hs marshal :: T.Variant -> Marshal-marshal v = marshalType (T.variantType v) where-	x :: T.Variable a => a-	x = fromJust . T.fromVariant $ v-	marshalType :: T.Type -> Marshal+marshal v = case v of 	|marshalers| :  TODO: describe these functions  :f DBus/Wire/Marshal.hs-append :: L.ByteString -> Marshal-append bytes = do-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ B.fromLazyByteString bytes-	    count' = count + fromIntegral (L.length bytes)-	State.put $ MarshalState e builder' count'+appendS :: BS.ByteString -> Marshal+appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.fromByteString bytes+	count' = count + fromIntegral (BS.length bytes)+	in MarshalRR () (MarshalState builder' count') :  :f DBus/Wire/Marshal.hs+appendL :: L.ByteString -> Marshal+appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.fromLazyByteString bytes+	count' = count + fromIntegral (L.length bytes)+	in MarshalRR () (MarshalState builder' count')+:++:f DBus/Wire/Marshal.hs pad :: Word8 -> Marshal-pad count = do-	(MarshalState _ _ existing) <- State.get-	let padding' = fromIntegral $ padding existing count-	append $ L.replicate padding' 0+pad count = MarshalM $ \e s@(MarshalState _ existing) -> let+	padding' = fromIntegral $ padding existing count+	bytes = BS.replicate padding' 0+	in unMarshalM (appendS bytes) e s :  Most numeric values already have marshalers implemented in the@@ -159,12 +190,12 @@ marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do 	pad size-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ case e of-		BigEndian -> be x-		LittleEndian -> le x-	let count' = count + fromIntegral size-	State.put $ MarshalState e builder' count'+	MarshalM $ \e (MarshalState builder count) -> let+		builder' = B.append builder $ case e of+			BigEndian -> be x+			LittleEndian -> le x+		size' = fromIntegral size+		in MarshalRR () (MarshalState builder' (count + size')) :  \subsubsection{Errors}@@ -218,31 +249,63 @@ module DBus.Wire.Unmarshal where |text imports| |unmarshal imports|-import Control.Monad (when, unless, liftM)+import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64)  import DBus.Wire.Internal-import qualified DBus.Types as T+import qualified DBus.Types.Internal as T :  :d unmarshal imports-import qualified Control.Monad.State as State-import Control.Monad.Trans.Class (lift)+import Control.Monad (liftM) import qualified DBus.Util.MonadError as E-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL : +A specialised, state-like monad is used for performance reasons. This is+equivalent to {\tt State.StateT UnmarshalState (E.ErrorM UnmarshalError)}.+ :f DBus/Wire/Unmarshal.hs-data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState)+data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64++data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState++newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a }++instance Monad Unmarshal where+	{-# INLINE return #-}+	return a = Unmarshal $ \_ s -> UnmarshalRR a s+	+	{-# INLINE (>>=) #-}+	m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of+		UnmarshalRL err -> UnmarshalRL err+		UnmarshalRR a s' -> unUnmarshal (k a) e s'+	+	{-# INLINE (>>) #-}+	m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of+		UnmarshalRL err -> UnmarshalRL err+		UnmarshalRR _ s' -> unUnmarshal k e s'++throwError :: UnmarshalError -> Unmarshal a+throwError err = Unmarshal $ \_ _ -> UnmarshalRL err++{-# INLINE getState #-}+getState :: Unmarshal UnmarshalState+getState = Unmarshal $ \_ s -> UnmarshalRR s s++{-# INLINE putState #-}+putState :: UnmarshalState -> Unmarshal ()+putState s = Unmarshal $ \_ _ -> UnmarshalRR () s :  :f DBus/Wire/Unmarshal.hs-runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where-	state = UnmarshalState e bytes 0+runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a+runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of+	UnmarshalRL err -> Left err+	UnmarshalRR a _ -> Right a :  :f DBus/Wire/Unmarshal.hs@@ -256,40 +319,39 @@ TODO: describe these functions  :f DBus/Wire/Unmarshal.hs-consume :: Word64 -> Unmarshal L.ByteString-consume count = do-	(UnmarshalState e bytes offset) <- State.get-	let (x, bytes') = L.splitAt (fromIntegral count) bytes-	unless (L.length x == fromIntegral count) $-		E.throwError $ UnexpectedEOF offset-	-	State.put $ UnmarshalState e bytes' (offset + count)-	return x+{-# INLINE consume #-}+consume :: Word64 -> Unmarshal BL.ByteString+consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let+	count' = fromIntegral count+	(x, bytes') = BL.splitAt count' bytes+	in if BL.length x == count'+		then UnmarshalRR x (UnmarshalState bytes' (offset + count))+		else UnmarshalRL $ UnexpectedEOF offset :  :f DBus/Wire/Unmarshal.hs skipPadding :: Word8 -> Unmarshal () skipPadding count = do-	(UnmarshalState _ _ offset) <- State.get+	(UnmarshalState _ offset) <- getState 	bytes <- consume $ padding offset count-	unless (L.all (== 0) bytes) $-		E.throwError $ InvalidPadding offset+	unless (BL.all (== 0) bytes) $+		throwError $ InvalidPadding offset :  :f DBus/Wire/Unmarshal.hs skipTerminator :: Unmarshal () skipTerminator = do-	(UnmarshalState _ _ offset) <- State.get+	(UnmarshalState _ offset) <- getState 	bytes <- consume 1-	unless (L.all (== 0) bytes) $-		E.throwError $ MissingTerminator offset+	unless (BL.all (== 0) bytes) $+		throwError $ MissingTerminator offset :  :f DBus/Wire/Unmarshal.hs fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of 	Just x' -> return x'-	Nothing -> E.throwError . Invalid label . TL.pack . show $ x+	Nothing -> throwError . Invalid label . TL.pack . show $ x  fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a            -> Unmarshal T.Variant@@ -306,16 +368,17 @@ unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do 	skipPadding count-	(UnmarshalState e _ _) <- State.get 	bs <- consume . fromIntegral $ count-	let get' = case e of-		BigEndian -> be-		LittleEndian -> le-	return $ G.runGet get' bs+	+	Unmarshal $ \e s -> let+		get = case e of+			BigEndian -> be+			LittleEndian -> le+		in UnmarshalRR (G.runGet get bs) s  unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a               -> Unmarshal T.Variant-unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le+unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le :  :f DBus/Wire/Unmarshal.hs@@ -395,31 +458,39 @@ alignment T.DBusDouble  = 8 : -Because {\tt Word32}s are often used for other types, there's-separate functions for handling them.+Because some integral types are often used as components of other values,+there's separate functions for handling them.  :f DBus/Wire/Marshal.hs marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le : +:f DBus/Wire/Marshal.hs+{-# INLINE marshalWord8 #-}+marshalWord8 :: Word8 -> Marshal+marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let+	builder' = B.append builder $ B.singleton x+	in MarshalRR () (MarshalState builder' (count + 1))+:+ :f DBus/Wire/Unmarshal.hs unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le :  :d marshalers-marshalType T.DBusByte   = append $ L.singleton x-marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x-marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x-marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x-marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)-marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)-marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)+T.VarBoxWord8  x -> marshalWord8 x+T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x+T.VarBoxWord32 x -> marshalWord32 x+T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x+T.VarBoxInt16  x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x+T.VarBoxInt32  x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x+T.VarBoxInt64  x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x :  :d unmarshalers-unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1+unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le@@ -449,14 +520,19 @@ :  :d marshalers-marshalType T.DBusDouble = do+T.VarBoxDouble x -> marshalDouble x+:++:f DBus/Wire/Marshal.hs+marshalDouble :: Double -> Marshal+marshalDouble x = do 	pad 8-	(MarshalState e _ _) <- State.get-	let put = case e of-		BigEndian -> IEEE.putFloat64be-		LittleEndian -> IEEE.putFloat64le-	let bytes = runPut $ put x-	append bytes+	MarshalM $ \e s -> let+		put = case e of+			BigEndian -> IEEE.putFloat64be+			LittleEndian -> IEEE.putFloat64le+		bytes = runPut $ put x+		in unMarshalM (appendL bytes) e s :  :d unmarshalers@@ -473,7 +549,7 @@ :  :d marshalers-marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0+T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0 :  :d unmarshalers@@ -528,12 +604,12 @@ marshalText x = do 	bytes <- case maybeEncodeUtf8 x of 		Just x' -> return x'-		Nothing -> E.throwError $ InvalidText x+		Nothing -> throwError $ InvalidText x 	when (L.any (== 0) bytes) $-		E.throwError $ InvalidText x+		throwError $ InvalidText x 	marshalWord32 . fromIntegral . L.length $ bytes-	append bytes-	append (L.singleton 0)+	appendL bytes+	marshalWord8 0 :  :d unmarshal imports@@ -555,12 +631,12 @@ :  :d marshalers-marshalType T.DBusString = marshalText x-marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x+T.VarBoxString x -> marshalText x+T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x :  :d unmarshalers-unmarshalType T.DBusString = fmap T.toVariant unmarshalText+unmarshalType T.DBusString = liftM T.toVariant unmarshalText  unmarshalType T.DBusObjectPath = unmarshalText >>= 	fromMaybeU' "object path" T.mkObjectPath@@ -571,28 +647,24 @@ Signatures are similar to strings, except their length is limited to 255 characters and is therefore stored as a single byte. -:d marshal imports-import Data.Text.Lazy.Encoding (encodeUtf8)-:- :f DBus/Wire/Marshal.hs marshalSignature :: T.Signature -> Marshal marshalSignature x = do-	let bytes = encodeUtf8 . T.strSignature $ x-	let size = fromIntegral . L.length $ bytes-	append (L.singleton size)-	append bytes-	append (L.singleton 0)+	let bytes = T.bytesSignature x+	let size = fromIntegral . BS.length $ bytes+	marshalWord8 size+	appendS bytes+	marshalWord8 0 :  :f DBus/Wire/Unmarshal.hs unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do-	byteCount <- L.head `fmap` consume 1-	bytes <- consume $ fromIntegral byteCount-	sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes+	byteCount <- BL.head `liftM` consume 1+	lazy <- consume $ fromIntegral byteCount 	skipTerminator-	fromMaybeU "signature" T.mkSignature sigText+	let bytes = B.concat $ BL.toChunks lazy+	fromMaybeU "signature" T.mkBytesSignature bytes :  :d alignments@@ -600,11 +672,11 @@ :  :d marshalers-marshalType T.DBusSignature = marshalSignature x+T.VarBoxSignature x -> marshalSignature x :  :d unmarshalers-unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature+unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature :  \subsection{Containers}@@ -616,11 +688,11 @@ :  :d marshalers-marshalType (T.DBusArray _) = marshalArray x+T.VarBoxArray x -> marshalArray x :  :d unmarshalers-unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t+unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t :  Marshaling arrays is complicated, because the array body must be marshaled@@ -637,10 +709,10 @@ 	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x 	let arrayLen = L.length arrayBytes 	when (arrayLen > fromIntegral C.arrayMaximumLength)-		(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)+		(throwError $ ArrayTooLong $ fromIntegral arrayLen) 	marshalWord32 $ fromIntegral arrayLen-	append $ L.replicate arrayPadding 0-	append arrayBytes+	appendL $ L.replicate arrayPadding 0+	appendL arrayBytes :  :f DBus/Wire/Marshal.hs@@ -652,17 +724,17 @@ :f DBus/Wire/Marshal.hs getArrayBytes itemType x = do 	let vs = T.arrayItems x-	s <- State.get-	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get-	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get+	s <- getState+	(MarshalState _ afterLength) <- marshalWord32 0 >> getState+	(MarshalState _ afterPadding) <- pad (alignment itemType) >> getState 	-	State.put $ MarshalState e B.empty afterPadding-	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get+	putState $ MarshalState B.empty afterPadding+	(MarshalState itemBuilder _) <- mapM_ marshal vs >> getState 	 	let itemBytes = B.toLazyByteString itemBuilder 	    paddingSize = fromIntegral $ afterPadding - afterLength 	-	State.put s+	putState s 	return (paddingSize, itemBytes) : @@ -672,22 +744,22 @@ unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do 	byteCount <- unmarshalWord32-	T.arrayFromBytes `fmap` consume (fromIntegral byteCount)+	T.arrayFromBytes `liftM` consume (fromIntegral byteCount) :  :f DBus/Wire/Unmarshal.hs unmarshalArray itemType = do 	let getOffset = do-		(UnmarshalState _ _ o) <- State.get+		(UnmarshalState _ o) <- getState 		return o 	byteCount <- unmarshalWord32 	skipPadding (alignment itemType) 	start <- getOffset 	let end = start + fromIntegral byteCount-	vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)+	vs <- untilM (liftM (>= end) getOffset) (unmarshalType itemType) 	end' <- getOffset 	when (end' > end) $-		E.throwError ArraySizeMismatch+		throwError ArraySizeMismatch 	fromMaybeU "array" (T.arrayFromItems itemType) vs : @@ -698,7 +770,7 @@ :  :d marshalers-marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)+T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x) :  :d unmarshalers@@ -715,8 +787,7 @@ :  :d marshalers-marshalType (T.DBusStructure _) = do-	let T.Structure vs = x+T.VarBoxStructure (T.Structure vs) -> do 	pad 8 	mapM_ marshal vs :@@ -724,7 +795,7 @@ :d unmarshalers unmarshalType (T.DBusStructure ts) = do 	skipPadding 8-	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts+	liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts :  \subsubsection{Variants}@@ -734,11 +805,11 @@ :  :d marshalers-marshalType T.DBusVariant = do-	let rawSig = T.typeCode . T.variantType $ x-	sig <- case T.mkSignature rawSig of+T.VarBoxVariant x -> do+	let textSig = T.typeCode . T.variantType $ x+	sig <- case T.variantSignature x of 		Just x' -> return x'-		Nothing -> E.throwError $ InvalidVariantSignature rawSig+		Nothing -> throwError $ InvalidVariantSignature textSig 	marshalSignature sig 	marshal x :@@ -750,7 +821,7 @@ 		_   -> Nothing 	 	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature-	T.toVariant `fmap` unmarshalType t+	T.toVariant `liftM` unmarshalType t :  \subsection{Messages}@@ -812,8 +883,8 @@ :  :f DBus/Wire/Unmarshal.hs-decodeField :: Monad m => T.Structure-            -> E.ErrorT UnmarshalError m [M.HeaderField]+decodeField :: T.Structure+            -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of 	(1, x) -> decodeField' x M.Path "path" 	(2, x) -> decodeField' x M.Interface "interface"@@ -825,11 +896,11 @@ 	(8, x) -> decodeField' x M.Signature "signature" 	_      -> return [] -decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text-             -> E.ErrorT UnmarshalError m [b]+decodeField' :: T.Variable a => T.Variant -> (a -> b) -> Text+             -> E.ErrorM UnmarshalError [b] decodeField' x f label = case T.fromVariant x of 	Just x' -> return [f x']-	Nothing -> E.throwError $ InvalidHeaderField label x+	Nothing -> E.throwErrorM $ InvalidHeaderField label x :  :f DBus/Wire/Unmarshal.hs@@ -858,25 +929,26 @@ 	body = M.messageBody msg 	marshaler = do 		sig <- checkBodySig body-		empty <- State.get+		empty <- getState 		mapM_ marshal body-		(MarshalState _ bodyBytesB _) <- State.get-		State.put empty+		(MarshalState bodyBytesB _) <- getState+		putState empty 		marshalEndianness e 		let bodyBytes = B.toLazyByteString bodyBytesB 		marshalHeader msg serial sig 			$ fromIntegral . L.length $ bodyBytes 		pad 8-		append bodyBytes+		appendL bodyBytes 		checkMaximumSize :  :f DBus/Wire/Marshal.hs checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let-	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs-	invalid = E.throwError $ InvalidBodySignature sigStr-	in case T.mkSignature sigStr of+	textSig = TL.concat . map (T.typeCode . T.variantType) $ vs+	bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs+	invalid = throwError $ InvalidBodySignature textSig+	in case T.mkBytesSignature bytesSig of 		Just x -> return x 		Nothing -> invalid :@@ -886,13 +958,13 @@               -> Marshal marshalHeader msg serial bodySig bodyLength = do 	let fields = M.Signature bodySig : M.messageHeaderFields msg-	marshal . T.toVariant . M.messageTypeCode $ msg-	marshal . T.toVariant . encodeFlags . M.messageFlags $ msg-	marshal . T.toVariant $ C.protocolVersion+	marshalWord8 . M.messageTypeCode $ msg+	marshalWord8 . encodeFlags . M.messageFlags $ msg+	marshalWord8 C.protocolVersion 	marshalWord32 bodyLength-	marshal . T.toVariant $ serial+	marshalWord32 . M.serialValue $ serial 	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]-	marshal . T.toVariant . fromJust . T.toArray fieldType+	marshalArray . fromJust . T.toArray fieldType 	        $ map encodeField fields : @@ -904,9 +976,9 @@ :f DBus/Wire/Marshal.hs checkMaximumSize :: Marshal checkMaximumSize = do-	(MarshalState _ _ messageLength) <- State.get+	(MarshalState _ messageLength) <- getState 	when (messageLength > fromIntegral C.messageMaximumLength)-		(E.throwError $ MessageTooLong $ fromIntegral messageLength)+		(throwError $ MessageTooLong $ fromIntegral messageLength) :  \subsubsection{Unmarshaling}@@ -921,10 +993,10 @@  :f DBus/Wire/Unmarshal.hs |apidoc unmarshalMessage|-unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)+unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do-	let getBytes = lift . getBytes'+	let getBytes = E.ErrorT . liftM Right . getBytes' 	 	|read fixed-length header| 	|read full header|@@ -945,18 +1017,18 @@ parsed.  :d read fixed-length header-let messageVersion = L.index fixedBytes 3+let messageVersion = BL.index fixedBytes 3 when (messageVersion /= C.protocolVersion) $-	E.throwError $ UnsupportedProtocolVersion messageVersion+	E.throwErrorT $ UnsupportedProtocolVersion messageVersion :  Next is the endianness, used for parsing pretty much every other field.  :d read fixed-length header-let eByte = L.index fixedBytes 0+let eByte = BL.index fixedBytes 0 endianness <- case decodeEndianness eByte of 	Just x' -> return x'-	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte+	Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte :  With the endianness out of the way, the rest of the fixed header@@ -965,7 +1037,7 @@ :d read fixed-length header let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of 	Right x' -> return x'-	Left  e  -> E.throwError e+	Left  e  -> E.throwErrorT e fixed <- unmarshal' fixedSig fixedBytes let typeCode = fromJust . T.fromVariant $ fixed !! 1 let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2@@ -987,7 +1059,7 @@ :d read full header let headerSig  = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount-let headerBytes = L.append fixedBytes fieldBytes+let headerBytes = BL.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes : @@ -996,7 +1068,9 @@ :d read full header let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray-fields <- concat `liftM` mapM decodeField fieldStructures+fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of+	Left err -> E.throwErrorT err+	Right x -> return x :  The body is always aligned to 8 bytes, so pull out the padding before@@ -1027,29 +1101,17 @@ Even if the received message was structurally valid, building the {\tt ReceivedMessage} can still fail due to missing header fields. -Slightly ugly; to avoid orphan instances of either {\tt Text} or-{\tt Either}, a newtype is used to turn {\tt Either} into a monad.--:f DBus/Wire/Unmarshal.hs-newtype EitherM a b = EitherM (Either a b)--instance Monad (EitherM a) where-	return = EitherM . Right-	(EitherM (Left x)) >>= _ = EitherM (Left x)-	(EitherM (Right x)) >>= k = k x-:- :d build message-y <- case buildReceivedMessage typeCode fields of-	EitherM (Right x) -> return x-	EitherM (Left x) -> E.throwError $ MissingHeaderField x+y <- case E.runErrorM $ buildReceivedMessage typeCode fields of+	Right x -> return x+	Left err -> E.throwErrorT $ MissingHeaderField err return $ y serial flags body :  This really belongs in the Message section...  :f DBus/Wire/Unmarshal.hs-buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text+buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage) :@@ -1117,9 +1179,9 @@ :  :f DBus/Wire/Unmarshal.hs-require :: Text -> [a] -> EitherM Text a+require :: Text -> [a] -> E.ErrorM Text a require _     (x:_) = return x-require label _     = EitherM $ Left label+require label _     = E.throwErrorM label :  :f Tests.hs