diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,5 +1,5 @@ name: dbus-core -version: 0.8.3 +version: 0.8.3.1 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt diff --git a/hs/DBus/Address.hs b/hs/DBus/Address.hs --- a/hs/DBus/Address.hs +++ b/hs/DBus/Address.hs @@ -1,7 +1,3 @@ - -#line 19 "src/addresses.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 20 "src/addresses.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 21 "src/addresses.anansi" module DBus.Address ( Address , addressMethod @@ -30,25 +20,17 @@ , 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 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 @@ -57,8 +39,6 @@ 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 @@ -83,8 +63,6 @@ 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 diff --git a/hs/DBus/Authentication.hs b/hs/DBus/Authentication.hs --- a/hs/DBus/Authentication.hs +++ b/hs/DBus/Authentication.hs @@ -1,7 +1,3 @@ - -#line 27 "src/authentication.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 28 "src/authentication.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 29 "src/authentication.anansi" {-# LANGUAGE DeriveDataTypeable #-} module DBus.Authentication ( Command @@ -31,53 +21,31 @@ , 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 qualified DBus.UUID as UUID - -#line 60 "src/authentication.anansi" import Data.Typeable (Typeable) import qualified Control.Exception as E - -#line 77 "src/authentication.anansi" import Data.Word (Word8) - -#line 93 "src/authentication.anansi" import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd) - -#line 114 "src/authentication.anansi" import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) - -#line 135 "src/authentication.anansi" import Data.Maybe (isJust) - -#line 51 "src/authentication.anansi" type Command = Text newtype Mechanism = Mechanism { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID } - -#line 65 "src/authentication.anansi" data AuthenticationError = AuthenticationError Text deriving (Show, Typeable) instance E.Exception AuthenticationError - -#line 81 "src/authentication.anansi" authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 -> IO UUID.UUID authenticate mech put getByte = do @@ -85,16 +53,12 @@ uuid <- mechanismRun mech (putCommand put getByte) put "BEGIN\r\n" return uuid - -#line 100 "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 120 "src/authentication.anansi" realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do uid <- getRealUserID @@ -104,8 +68,6 @@ case eitherUUID of Right uuid -> return uuid Left err -> E.throwIO $ AuthenticationError err - -#line 139 "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 diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs --- a/hs/DBus/Bus.hs +++ b/hs/DBus/Bus.hs @@ -1,7 +1,3 @@ - -#line 19 "src/bus.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 20 "src/bus.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 21 "src/bus.anansi" module DBus.Bus ( getBus , getFirstBus @@ -30,13 +20,9 @@ , 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) @@ -50,64 +36,36 @@ 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 @@ -115,8 +73,6 @@ 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" @@ -124,8 +80,6 @@ (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 @@ -138,8 +92,6 @@ 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 diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs --- a/hs/DBus/Connection.hs +++ b/hs/DBus/Connection.hs @@ -1,7 +1,3 @@ - -#line 19 "src/connections.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,83 +12,39 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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 285 "src/connections.anansi" , ConnectionError (..) - -#line 324 "src/connections.anansi" , connect , connectFirst - -#line 337 "src/connections.anansi" , connectionClose - -#line 367 "src/connections.anansi" , send - -#line 391 "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 - -#line 193 "src/connections.anansi" import qualified Text.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) - -#line 252 "src/connections.anansi" import qualified System.IO as I - -#line 269 "src/connections.anansi" import qualified Control.Exception as E import Data.Typeable (Typeable) - -#line 294 "src/connections.anansi" import qualified DBus.Authentication as Auth - -#line 350 "src/connections.anansi" import qualified DBus.Wire as W - -#line 43 "src/connections.anansi" data Connection = Connection { connectionAddress :: A.Address , connectionTransport :: Transport @@ -100,35 +52,23 @@ , 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 "" 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 @@ -146,8 +86,6 @@ (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 @@ -157,19 +95,13 @@ 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 @@ -177,8 +109,6 @@ 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 @@ -187,8 +117,6 @@ P.parserFail "bad port" >> return () let word = fromIntegral value return $ runGet getWord16host (runPut (putWord16be word)) - -#line 211 "src/connections.anansi" getAddresses family = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] @@ -196,13 +124,9 @@ , NS.addrSocketType = NS.Stream } NS.getAddrInfo (Just hints) (Just hostname) Nothing - -#line 225 "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 235 "src/connections.anansi" openSocket _ [] = E.throwIO $ NoWorkingAddress [a] openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ \(E.SomeException _) -> openSocket port addrs @@ -212,15 +136,11 @@ (NS.addrProtocol addr) NS.connect sock . setPort port . NS.addrAddress $ addr return sock - -#line 256 "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 274 "src/connections.anansi" data ConnectionError = InvalidAddress Text | BadParameters A.Address Text @@ -229,14 +149,8 @@ deriving (Show, Typeable) instance E.Exception ConnectionError - -#line 298 "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 299 "src/connections.anansi" connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do t <- connectTransport a @@ -245,34 +159,18 @@ readLock <- C.newMVar () serialMVar <- C.newMVar M.firstSerial return $ Connection a t serialMVar readLock uuid - -#line 314 "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 315 "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 331 "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 332 "src/connections.anansi" connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport - -#line 354 "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 @@ -281,8 +179,6 @@ -- 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 355 "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 -> @@ -292,8 +188,6 @@ transportSend t bytes return $ Right x Left err -> return $ Left err - -#line 371 "src/connections.anansi" withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do s <- C.takeMVar m @@ -301,18 +195,12 @@ x <- E.unblock (io s) `E.onException` C.putMVar m s' C.putMVar m s' return x - -#line 384 "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 385 "src/connections.anansi" receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> W.unmarshalMessage $ transportRecv t diff --git a/hs/DBus/Constants.hs b/hs/DBus/Constants.hs --- a/hs/DBus/Constants.hs +++ b/hs/DBus/Constants.hs @@ -1,7 +1,3 @@ - -#line 19 "src/constants.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,8 +12,6 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 20 "src/constants.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T @@ -31,8 +25,6 @@ arrayMaximumLength :: Word32 arrayMaximumLength = 67108864 - -#line 38 "src/constants.anansi" dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -41,8 +33,6 @@ dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus" - -#line 51 "src/constants.anansi" interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -51,8 +41,6 @@ interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer" - -#line 64 "src/constants.anansi" errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed" diff --git a/hs/DBus/Introspection.hs b/hs/DBus/Introspection.hs --- a/hs/DBus/Introspection.hs +++ b/hs/DBus/Introspection.hs @@ -1,7 +1,3 @@ - -#line 44 "src/introspection.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 45 "src/introspection.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 46 "src/introspection.anansi" module DBus.Introspection ( Object (..) , Interface (..) @@ -34,34 +24,16 @@ , toXML , fromXML ) where - -#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL - -#line 58 "src/introspection.anansi" - -#line 66 "src/introspection.anansi" import qualified Text.XML.HaXml as H - -#line 105 "src/introspection.anansi" import Text.XML.HaXml.Parse (xmlParse') import DBus.Util (eitherToMaybe) - -#line 230 "src/introspection.anansi" import Data.Char (chr) - -#line 254 "src/introspection.anansi" import Data.Maybe (fromMaybe) - -#line 286 "src/introspection.anansi" import Text.XML.HaXml.Pretty (document) import Text.PrettyPrint.HughesPJ (render) - -#line 59 "src/introspection.anansi" import qualified DBus.Types as T - -#line 72 "src/introspection.anansi" data Object = Object T.ObjectPath [Interface] [Object] deriving (Show, Eq) @@ -82,23 +54,17 @@ data PropertyAccess = Read | Write deriving (Show, Eq) - -#line 110 "src/introspection.anansi" fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text let (H.Document _ _ root _) = doc parseRoot path root - -#line 121 "src/introspection.anansi" parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object parseRoot defaultPath e = do path <- case getAttr "name" e of Nothing -> Just defaultPath Just x -> T.mkObjectPath x parseObject' path e - -#line 134 "src/introspection.anansi" parseChild :: T.ObjectPath -> H.Element a -> Maybe Object parseChild parentPath e = do let parentPath' = case T.strObjectPath parentPath of @@ -107,16 +73,12 @@ pathSegment <- getAttr "name" e path <- T.mkObjectPath $ TL.append parentPath' pathSegment parseObject' path e - -#line 148 "src/introspection.anansi" 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 return $ Object path interfaces children' parseObject' _ _ = Nothing - -#line 159 "src/introspection.anansi" parseInterface :: H.Element a -> Maybe Interface parseInterface e = do name <- T.mkInterfaceName =<< getAttr "name" e @@ -124,38 +86,28 @@ signals <- children parseSignal (H.tag "signal") e properties <- children parseProperty (H.tag "property") e return $ Interface name methods signals properties - -#line 172 "src/introspection.anansi" parseMethod :: H.Element a -> Maybe Method parseMethod e = do name <- T.mkMemberName =<< getAttr "name" e paramsIn <- children parseParameter (isParam ["in", ""]) e paramsOut <- children parseParameter (isParam ["out"]) e return $ Method name paramsIn paramsOut - -#line 183 "src/introspection.anansi" parseSignal :: H.Element a -> Maybe Signal parseSignal e = do name <- T.mkMemberName =<< getAttr "name" e params <- children parseParameter (isParam ["out", ""]) e return $ Signal name params - -#line 193 "src/introspection.anansi" parseParameter :: H.Element a -> Maybe Parameter parseParameter e = do let name = getAttr' "name" e sig <- parseType e return $ Parameter name sig - -#line 201 "src/introspection.anansi" parseType :: H.Element a -> Maybe T.Signature parseType e = do sig <- T.mkSignature =<< getAttr "type" e case T.signatureTypes sig of [_] -> Just sig _ -> Nothing - -#line 213 "src/introspection.anansi" parseProperty :: H.Element a -> Maybe Property parseProperty e = do let name = getAttr' "name" e @@ -167,8 +119,6 @@ "readwrite" -> Just [Read, Write] _ -> Nothing return $ Property name sig access - -#line 234 "src/introspection.anansi" attrValue :: H.AttValue -> Maybe Text attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where (H.AttValue parts) = attr @@ -184,8 +134,6 @@ , ("apos", "'") , ("quot", "\"") ] - -#line 258 "src/introspection.anansi" getAttr :: String -> H.Element a -> Maybe Text getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue @@ -201,13 +149,9 @@ 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] - -#line 278 "src/introspection.anansi" dtdPublicID, dtdSystemID :: String dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" - -#line 294 "src/introspection.anansi" toXML :: Object -> Maybe Text toXML obj = fmap (TL.pack . render . document) doc where prolog = H.Prolog Nothing [] (Just doctype) [] @@ -217,14 +161,10 @@ doc = do root <- xmlRoot obj return $ H.Document prolog H.emptyST root [] - -#line 309 "src/introspection.anansi" xmlRoot :: Object -> Maybe (H.Element a) xmlRoot obj@(Object path _ _) = do (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj return root - -#line 316 "src/introspection.anansi" xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) xmlObject parentPath obj@(Object path _ _) = do let path' = T.strObjectPath path @@ -235,8 +175,6 @@ else TL.drop (TL.length parent' + 1) path' else Nothing xmlObject' relpath obj - -#line 329 "src/introspection.anansi" xmlObject' :: Text -> Object -> Maybe (H.Content a) xmlObject' path (Object fullPath interfaces children') = do children'' <- mapM (xmlObject fullPath) children' @@ -246,8 +184,6 @@ [ map xmlInterface interfaces , children'' ] - -#line 341 "src/introspection.anansi" xmlInterface :: Interface -> H.Content a xmlInterface (Interface name methods signals properties) = mkElement "interface" @@ -257,8 +193,6 @@ , map xmlSignal signals , map xmlProperty properties ] - -#line 353 "src/introspection.anansi" xmlMethod :: Method -> H.Content a xmlMethod (Method name inParams outParams) = mkElement "method" [mkAttr "name" . TL.unpack . T.strMemberName $ name] @@ -266,36 +200,26 @@ [ map (xmlParameter "in") inParams , map (xmlParameter "out") outParams ] - -#line 363 "src/introspection.anansi" xmlSignal :: Signal -> H.Content a xmlSignal (Signal name params) = mkElement "signal" [mkAttr "name" . TL.unpack . T.strMemberName $ name] $ map (xmlParameter "out") params - -#line 370 "src/introspection.anansi" 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 ] [] - -#line 379 "src/introspection.anansi" 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 ] [] - -#line 388 "src/introspection.anansi" xmlAccess :: [PropertyAccess] -> String xmlAccess access = readS ++ writeS where readS = if elem Read access then "read" else "" writeS = if elem Write access then "write" else "" - -#line 395 "src/introspection.anansi" mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined diff --git a/hs/DBus/MatchRule.hs b/hs/DBus/MatchRule.hs --- a/hs/DBus/MatchRule.hs +++ b/hs/DBus/MatchRule.hs @@ -1,7 +1,3 @@ - -#line 23 "src/match-rules.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 24 "src/match-rules.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 25 "src/match-rules.anansi" module DBus.MatchRule ( MatchRule (..) , MessageType (..) @@ -32,12 +22,8 @@ , 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 @@ -45,8 +31,6 @@ 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. @@ -61,8 +45,6 @@ , 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. -- @@ -74,8 +56,6 @@ = 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. @@ -86,14 +66,8 @@ | 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 @@ -107,16 +81,12 @@ , ("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, "'"] @@ -125,13 +95,7 @@ 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 @@ -140,13 +104,7 @@ (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 @@ -157,14 +115,8 @@ , 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 @@ -175,44 +127,32 @@ , 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 @@ -223,8 +163,6 @@ 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 diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs --- a/hs/DBus/Message.hs +++ b/hs/DBus/Message.hs @@ -1,7 +1,3 @@ - -#line 23 "src/messages.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,46 +12,24 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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 diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs --- a/hs/DBus/Message/Internal.hs +++ b/hs/DBus/Message/Internal.hs @@ -1,7 +1,3 @@ - -#line 31 "src/messages.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,40 +12,24 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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 @@ -60,14 +40,8 @@ | 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) @@ -77,19 +51,13 @@ 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 @@ -111,8 +79,6 @@ , maybe' Interface . methodCallInterface $ m , maybe' Destination . methodCallDestination $ m ] - -#line 187 "src/messages.anansi" data MethodReturn = MethodReturn { methodReturnSerial :: Serial , methodReturnDestination :: Maybe T.BusName @@ -129,8 +95,6 @@ ] , maybe' Destination . methodReturnDestination $ m ] - -#line 221 "src/messages.anansi" data Error = Error { errorName :: T.ErrorName , errorSerial :: Serial @@ -149,8 +113,6 @@ ] , maybe' Destination . errorDestination $ m ] - -#line 246 "src/messages.anansi" errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do field <- maybeIndex (errorBody msg) 0 @@ -158,8 +120,6 @@ if TL.null text then Nothing else return text - -#line 273 "src/messages.anansi" data Signal = Signal { signalPath :: T.ObjectPath , signalMember :: T.MemberName @@ -180,23 +140,15 @@ ] , 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 @@ -204,24 +156,18 @@ | 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 diff --git a/hs/DBus/NameReservation.hs b/hs/DBus/NameReservation.hs --- a/hs/DBus/NameReservation.hs +++ b/hs/DBus/NameReservation.hs @@ -1,7 +1,3 @@ - -#line 22 "src/name-reservation.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,8 +12,6 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 23 "src/name-reservation.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation ( RequestNameFlag (..) @@ -35,27 +29,17 @@ 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 @@ -67,36 +51,24 @@ [ 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 @@ -106,22 +78,16 @@ , 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 diff --git a/hs/DBus/Types.cpphs b/hs/DBus/Types.cpphs --- a/hs/DBus/Types.cpphs +++ b/hs/DBus/Types.cpphs @@ -1,7 +1,3 @@ - -#line 22 "src/types.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,165 +12,89 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 23 "src/types.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 24 "src/types.anansi" - -#line 358 "src/types.anansi" {-# LANGUAGE TypeSynonymInstances #-} - -#line 25 "src/types.anansi" module DBus.Types ( - -#line 89 "src/types.anansi" -- * Available types Type (..) , typeCode - -#line 165 "src/types.anansi" -- * Variants , Variant , Variable (..) - -#line 234 "src/types.anansi" , variantType - -#line 425 "src/types.anansi" -- * Signatures , Signature , signatureTypes , strSignature - -#line 601 "src/types.anansi" , mkSignature , mkSignature_ - -#line 658 "src/types.anansi" -- * Object paths , ObjectPath , strObjectPath , mkObjectPath , mkObjectPath_ - -#line 713 "src/types.anansi" -- * Arrays , Array , arrayType , arrayItems - -#line 759 "src/types.anansi" , toArray , fromArray , arrayFromItems - -#line 777 "src/types.anansi" , arrayToBytes , arrayFromBytes - -#line 846 "src/types.anansi" -- * Dictionaries , Dictionary , dictionaryItems , dictionaryKeyType , dictionaryValueType - -#line 923 "src/types.anansi" , toDictionary , fromDictionary , dictionaryFromItems - -#line 995 "src/types.anansi" , dictionaryToArray , arrayToDictionary - -#line 1011 "src/types.anansi" -- * Structures , Structure (..) - -#line 1052 "src/types.anansi" -- * Names - -#line 1082 "src/types.anansi" -- ** Bus names , BusName , strBusName , mkBusName , mkBusName_ - -#line 1135 "src/types.anansi" -- ** Interface names , InterfaceName , strInterfaceName , mkInterfaceName , mkInterfaceName_ - -#line 1176 "src/types.anansi" -- ** Error names , ErrorName , strErrorName , mkErrorName , mkErrorName_ - -#line 1212 "src/types.anansi" -- ** Member names , MemberName , strMemberName , mkMemberName , mkMemberName_ - -#line 27 "src/types.anansi" ) where - -#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL - -#line 29 "src/types.anansi" - -#line 311 "src/types.anansi" import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int16, Int32, Int64) - -#line 345 "src/types.anansi" import qualified Data.Text as T - -#line 416 "src/types.anansi" import Data.Ord (comparing) - -#line 517 "src/types.anansi" import Text.Parsec ((<|>)) import qualified Text.Parsec as P import DBus.Util (checkLength, parseMaybe) - -#line 584 "src/types.anansi" import DBus.Util (mkUnsafe) import qualified Data.String as String - -#line 691 "src/types.anansi" import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString - -#line 791 "src/types.anansi" import qualified Data.ByteString as StrictByteString - -#line 857 "src/types.anansi" import Data.List (intercalate) - -#line 874 "src/types.anansi" import Control.Monad (unless) - -#line 896 "src/types.anansi" import Control.Arrow ((***)) import qualified Data.Map as Map - -#line 908 "src/types.anansi" import Control.Monad (forM) - -#line 41 "src/types.anansi" data Type = DBusBoolean | DBusByte @@ -193,14 +113,8 @@ | DBusDictionary Type Type | DBusStructure [Type] deriving (Show, Eq) - -#line 62 "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 63 "src/types.anansi" isAtomicType :: Type -> Bool isAtomicType DBusBoolean = True isAtomicType DBusByte = True @@ -215,17 +129,9 @@ isAtomicType DBusSignature = True isAtomicType DBusObjectPath = True isAtomicType _ = False - -#line 83 "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 84 "src/types.anansi" typeCode :: Type -> Text - -#line 437 "src/types.anansi" typeCode DBusBoolean = "b" typeCode DBusByte = "y" typeCode DBusInt16 = "n" @@ -239,25 +145,13 @@ typeCode DBusSignature = "g" typeCode DBusObjectPath = "o" typeCode DBusVariant = "v" - -#line 456 "src/types.anansi" typeCode (DBusArray t) = TL.cons 'a' $ typeCode t - -#line 463 "src/types.anansi" typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] - -#line 471 "src/types.anansi" typeCode (DBusStructure ts) = TL.concat $ ["("] ++ map typeCode ts ++ [")"] - -#line 139 "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 140 "src/types.anansi" data Variant = VarBoxBool Bool | VarBoxWord8 Word8 @@ -280,8 +174,6 @@ class Variable a where toVariant :: a -> Variant fromVariant :: Variant -> Maybe a - -#line 175 "src/types.anansi" instance Show Variant where showsPrec d var = showParen (d > 10) full where full = s "Variant " . shows code . s " " . valueStr @@ -307,15 +199,9 @@ (VarBoxArray x) -> showsPrec d x (VarBoxDictionary x) -> showsPrec d x (VarBoxStructure x) -> showsPrec d x - -#line 207 "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 208 "src/types.anansi" variantType :: Variant -> Type variantType var = case var of (VarBoxBool _) -> DBusBoolean @@ -339,19 +225,13 @@ (VarBoxStructure x) -> let Structure items = x in DBusStructure (map variantType items) - -#line 241 "src/types.anansi" #define INSTANCE_VARIABLE(TYPE) \ instance Variable TYPE where \ { toVariant = VarBox/**/TYPE \ ; fromVariant (VarBox/**/TYPE x) = Just x \ ; fromVariant _ = Nothing \ } - -#line 252 "src/types.anansi" INSTANCE_VARIABLE(Variant) - -#line 316 "src/types.anansi" INSTANCE_VARIABLE(Bool) INSTANCE_VARIABLE(Word8) INSTANCE_VARIABLE(Int16) @@ -361,24 +241,16 @@ INSTANCE_VARIABLE(Word32) INSTANCE_VARIABLE(Word64) INSTANCE_VARIABLE(Double) - -#line 334 "src/types.anansi" instance Variable TL.Text where toVariant = VarBoxString fromVariant (VarBoxString x) = Just x fromVariant _ = Nothing - -#line 349 "src/types.anansi" instance Variable T.Text where toVariant = toVariant . TL.fromChunks . (:[]) fromVariant = fmap (T.concat . TL.toChunks) . fromVariant - -#line 362 "src/types.anansi" instance Variable String where toVariant = toVariant . TL.pack fromVariant = fmap TL.unpack . fromVariant - -#line 395 "src/types.anansi" INSTANCE_VARIABLE(Signature) data Signature = Signature { signatureTypes :: [Type] } deriving (Eq) @@ -386,20 +258,12 @@ instance Show Signature where showsPrec d x = showParen (d > 10) $ showString "Signature " . shows (strSignature x) - -#line 408 "src/types.anansi" strSignature :: Signature -> Text strSignature (Signature ts) = TL.concat $ map typeCode ts - -#line 420 "src/types.anansi" instance Ord Signature where compare = comparing strSignature - -#line 482 "src/types.anansi" mkSignature :: Text -> Maybe Signature mkSignature text = parsed where - -#line 496 "src/types.anansi" just t = Just $ Signature [t] fast = case TL.head text of 'b' -> just DBusBoolean @@ -416,24 +280,16 @@ 'o' -> just DBusObjectPath 'v' -> just DBusVariant _ -> Nothing - -#line 485 "src/types.anansi" - -#line 523 "src/types.anansi" slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text sigParser = do types <- P.many parseType P.eof return $ Signature types - -#line 534 "src/types.anansi" parseType = parseAtom <|> parseContainer parseContainer = parseArray <|> parseStruct <|> (P.char 'v' >> return DBusVariant) - -#line 542 "src/types.anansi" parseArray = do P.char 'a' parseDict <|> fmap DBusArray parseType @@ -443,15 +299,11 @@ valueType <- parseType P.char '}' return $ DBusDictionary keyType valueType - -#line 556 "src/types.anansi" parseStruct = do P.char '(' types <- P.many parseType P.char ')' return $ DBusStructure types - -#line 564 "src/types.anansi" parseAtom = (P.char 'b' >> return DBusBoolean) <|> (P.char 'y' >> return DBusByte) @@ -465,21 +317,15 @@ <|> (P.char 's' >> return DBusString) <|> (P.char 'g' >> return DBusSignature) <|> (P.char 'o' >> return DBusObjectPath) - -#line 486 "src/types.anansi" parsed = case TL.length text of 0 -> Just $ Signature [] 1 -> fast _ -> slow - -#line 589 "src/types.anansi" mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature instance String.IsString Signature where fromString = mkSignature_ . TL.pack - -#line 620 "src/types.anansi" INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath { strObjectPath :: Text @@ -492,8 +338,6 @@ instance String.IsString ObjectPath where fromString = mkObjectPath_ . TL.pack - -#line 647 "src/types.anansi" mkObjectPath :: Text -> Maybe ObjectPath mkObjectPath s = parseMaybe path' (TL.unpack s) where c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" @@ -502,20 +346,14 @@ mkObjectPath_ :: Text -> ObjectPath mkObjectPath_ = mkUnsafe "object path" mkObjectPath - -#line 696 "src/types.anansi" INSTANCE_VARIABLE(Array) data Array = VariantArray Type [Variant] | ByteArray 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 703 "src/types.anansi" arrayType :: Array -> Type arrayType (VariantArray t _) = t arrayType (ByteArray _) = DBusByte @@ -523,8 +361,6 @@ arrayItems :: Array -> [Variant] arrayItems (VariantArray _ xs) = xs arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs - -#line 723 "src/types.anansi" instance Show Array where showsPrec d array = showParen (d > 10) $ s "Array " . showSig . s " [" . s valueString . s "]" where @@ -532,8 +368,6 @@ showSig = shows . typeCode . arrayType $ array showVar var = showsPrecVar 0 var "" valueString = intercalate ", " $ map showVar $ arrayItems array - -#line 737 "src/types.anansi" arrayFromItems :: Type -> [Variant] -> Maybe Array arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) @@ -542,35 +376,25 @@ if all (\x -> variantType x == t) vs then Just $ VariantArray t vs else Nothing - -#line 751 "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 768 "src/types.anansi" arrayToBytes :: Array -> Maybe ByteString arrayToBytes (ByteArray x) = Just x arrayToBytes _ = Nothing arrayFromBytes :: ByteString -> Array arrayFromBytes = ByteArray - -#line 785 "src/types.anansi" instance Variable ByteString where toVariant = toVariant . arrayFromBytes fromVariant x = fromVariant x >>= arrayToBytes - -#line 795 "src/types.anansi" 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 - -#line 836 "src/types.anansi" INSTANCE_VARIABLE(Dictionary) data Dictionary = Dictionary { dictionaryKeyType :: Type @@ -578,8 +402,6 @@ , dictionaryItems :: [(Variant, Variant)] } deriving (Eq) - -#line 861 "src/types.anansi" instance Show Dictionary where showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ s "Dictionary " . showSig . s " {" . s valueString . s "}" where @@ -587,8 +409,6 @@ showSig = shows $ TL.append (typeCode kt) (typeCode vt) valueString = intercalate ", " $ map showPair pairs showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" - -#line 878 "src/types.anansi" dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary dictionaryFromItems kt vt pairs = do unless (isAtomicType kt) Nothing @@ -600,14 +420,10 @@ if all sameType pairs then Just $ Dictionary kt vt pairs else Nothing - -#line 901 "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 912 "src/types.anansi" fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary -> Maybe (Map.Map a b) fromDictionary (Dictionary _ _ vs) = do @@ -616,15 +432,11 @@ v' <- fromVariant v return (k', v') return $ Map.fromList pairs - -#line 972 "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 980 "src/types.anansi" arrayToDictionary :: Array -> Maybe Dictionary arrayToDictionary array = do let toPair x = do @@ -637,13 +449,9 @@ _ -> Nothing pairs <- mapM toPair $ arrayItems array dictionaryFromItems kt vt pairs - -#line 1005 "src/types.anansi" INSTANCE_VARIABLE(Structure) data Structure = Structure [Variant] deriving (Show, Eq) - -#line 1031 "src/types.anansi" #define NAME_TYPE(TYPE, NAME) \ newtype TYPE = TYPE {str/**/TYPE :: Text} \ deriving (Eq, Ord); \ @@ -662,8 +470,6 @@ \ mk/**/TYPE/**/_ :: Text -> TYPE; \ mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE - -#line 1068 "src/types.anansi" NAME_TYPE(BusName, "bus name") mkBusName :: Text -> Maybe BusName @@ -675,8 +481,6 @@ wellKnown = elems c elems start = elem' start >> P.many1 (P.char '.' >> elem' start) elem' start = P.oneOf start >> P.many (P.oneOf c') - -#line 1123 "src/types.anansi" NAME_TYPE(InterfaceName, "interface name") mkInterfaceName :: Text -> Maybe InterfaceName @@ -686,14 +490,10 @@ element = P.oneOf c >> P.many (P.oneOf c') name = element >> P.many1 (P.char '.' >> element) parser = name >> P.eof >> return (InterfaceName s) - -#line 1169 "src/types.anansi" NAME_TYPE(ErrorName, "error name") mkErrorName :: Text -> Maybe ErrorName mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName - -#line 1201 "src/types.anansi" NAME_TYPE(MemberName, "member name") mkMemberName :: Text -> Maybe MemberName diff --git a/hs/DBus/UUID.hs b/hs/DBus/UUID.hs --- a/hs/DBus/UUID.hs +++ b/hs/DBus/UUID.hs @@ -1,7 +1,3 @@ - -#line 22 "src/util.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,19 +12,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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) diff --git a/hs/DBus/Util.hs b/hs/DBus/Util.hs --- a/hs/DBus/Util.hs +++ b/hs/DBus/Util.hs @@ -1,7 +1,3 @@ - -#line 58 "src/util.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,8 +12,6 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 59 "src/util.anansi" module DBus.Util where import Text.Parsec (Parsec, parse) import Data.Char (digitToInt) diff --git a/hs/DBus/Util/MonadError.hs b/hs/DBus/Util/MonadError.hs --- a/hs/DBus/Util/MonadError.hs +++ b/hs/DBus/Util/MonadError.hs @@ -1,7 +1,3 @@ - -#line 117 "src/util.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,8 +12,6 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 118 "src/util.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Util.MonadError ( ErrorT (..) diff --git a/hs/DBus/Wire.hs b/hs/DBus/Wire.hs --- a/hs/DBus/Wire.hs +++ b/hs/DBus/Wire.hs @@ -1,7 +1,3 @@ - -#line 21 "src/wire.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,26 +12,12 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 22 "src/wire.anansi" module DBus.Wire ( - -#line 54 "src/wire.anansi" Endianness (..) - -#line 207 "src/wire.anansi" , MarshalError (..) - -#line 379 "src/wire.anansi" , UnmarshalError (..) - -#line 850 "src/wire.anansi" , marshalMessage - -#line 919 "src/wire.anansi" , unmarshalMessage - -#line 24 "src/wire.anansi" ) where import DBus.Wire.Internal import DBus.Wire.Marshal diff --git a/hs/DBus/Wire/Internal.hs b/hs/DBus/Wire/Internal.hs --- a/hs/DBus/Wire/Internal.hs +++ b/hs/DBus/Wire/Internal.hs @@ -1,7 +1,3 @@ - -#line 31 "src/wire.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,13 +12,9 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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) @@ -34,11 +26,7 @@ decodeEndianness 108 = Just LittleEndian decodeEndianness 66 = Just BigEndian decodeEndianness _ = Nothing - -#line 69 "src/wire.anansi" alignment :: T.Type -> Word8 - -#line 388 "src/wire.anansi" alignment T.DBusByte = 1 alignment T.DBusWord16 = 2 alignment T.DBusWord32 = 4 @@ -47,30 +35,14 @@ alignment T.DBusInt32 = 4 alignment T.DBusInt64 = 8 alignment T.DBusDouble = 8 - -#line 472 "src/wire.anansi" alignment T.DBusBoolean = 4 - -#line 553 "src/wire.anansi" alignment T.DBusString = 4 alignment T.DBusObjectPath = 4 - -#line 599 "src/wire.anansi" alignment T.DBusSignature = 1 - -#line 615 "src/wire.anansi" alignment (T.DBusArray _) = 4 - -#line 697 "src/wire.anansi" alignment (T.DBusDictionary _ _) = 4 - -#line 714 "src/wire.anansi" alignment (T.DBusStructure _) = 8 - -#line 733 "src/wire.anansi" alignment T.DBusVariant = 1 - -#line 71 "src/wire.anansi" padding :: Word64 -> Word8 -> Word64 padding current count = required where diff --git a/hs/DBus/Wire/Marshal.hs b/hs/DBus/Wire/Marshal.hs --- a/hs/DBus/Wire/Marshal.hs +++ b/hs/DBus/Wire/Marshal.hs @@ -1,7 +1,3 @@ - -#line 89 "src/wire.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,44 +12,22 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#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 - -#line 93 "src/wire.anansi" - -#line 104 "src/wire.anansi" import qualified Control.Monad.State as State import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B - -#line 443 "src/wire.anansi" import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE - -#line 523 "src/wire.anansi" import DBus.Wire.Unicode (maybeEncodeUtf8) - -#line 575 "src/wire.anansi" import Data.Text.Lazy.Encoding (encodeUtf8) - -#line 631 "src/wire.anansi" import qualified DBus.Constants as C - -#line 759 "src/wire.anansi" import qualified DBus.Message.Internal as M - -#line 774 "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) @@ -61,27 +35,19 @@ import Data.Int (Int16, Int32, Int64) import qualified DBus.Types as T - -#line 111 "src/wire.anansi" data MarshalState = MarshalState Endianness B.Builder !Word64 type MarshalM = E.ErrorT MarshalError (State.State MarshalState) type Marshal = MarshalM () - -#line 120 "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 - -#line 128 "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 - -#line 412 "src/wire.anansi" 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 @@ -89,8 +55,6 @@ 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) - -#line 452 "src/wire.anansi" marshalType T.DBusDouble = do pad 8 (MarshalState e _ _) <- State.get @@ -99,30 +63,16 @@ LittleEndian -> IEEE.putFloat64le let bytes = runPut $ put x append bytes - -#line 476 "src/wire.anansi" marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 - -#line 558 "src/wire.anansi" marshalType T.DBusString = marshalText x marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x - -#line 603 "src/wire.anansi" marshalType T.DBusSignature = marshalSignature x - -#line 619 "src/wire.anansi" marshalType (T.DBusArray _) = marshalArray x - -#line 701 "src/wire.anansi" marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) - -#line 718 "src/wire.anansi" marshalType (T.DBusStructure _) = do let T.Structure vs = x pad 8 mapM_ marshal vs - -#line 737 "src/wire.anansi" marshalType T.DBusVariant = do let rawSig = T.typeCode . T.variantType $ x sig <- case T.mkSignature rawSig of @@ -130,23 +80,17 @@ Nothing -> E.throwError $ InvalidVariantSignature rawSig marshalSignature sig marshal x - -#line 139 "src/wire.anansi" 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 148 "src/wire.anansi" pad :: Word8 -> Marshal pad count = do (MarshalState _ _ existing) <- State.get let padding' = fromIntegral $ padding existing count append $ L.replicate padding' 0 - -#line 159 "src/wire.anansi" marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do pad size @@ -156,8 +100,6 @@ LittleEndian -> le x let count' = count + fromIntegral size State.put $ MarshalState e builder' count' - -#line 185 "src/wire.anansi" data MarshalError = MessageTooLong Word64 | ArrayTooLong Word64 @@ -177,12 +119,8 @@ ["Invalid variant signature: ", show x] show (InvalidText x) = concat ["Text cannot be marshaled: ", show x] - -#line 402 "src/wire.anansi" marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le - -#line 527 "src/wire.anansi" marshalText :: Text -> Marshal marshalText x = do bytes <- case maybeEncodeUtf8 x of @@ -193,8 +131,6 @@ marshalWord32 . fromIntegral . L.length $ bytes append bytes append (L.singleton 0) - -#line 579 "src/wire.anansi" marshalSignature :: T.Signature -> Marshal marshalSignature x = do let bytes = encodeUtf8 . T.strSignature $ x @@ -202,8 +138,6 @@ append (L.singleton size) append bytes append (L.singleton 0) - -#line 635 "src/wire.anansi" marshalArray :: T.Array -> Marshal marshalArray x = do (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x @@ -213,13 +147,9 @@ marshalWord32 $ fromIntegral arrayLen append $ L.replicate arrayPadding 0 append arrayBytes - -#line 647 "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 653 "src/wire.anansi" getArrayBytes itemType x = do let vs = T.arrayItems x s <- State.get @@ -234,14 +164,10 @@ State.put s return (paddingSize, itemBytes) - -#line 779 "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 797 "src/wire.anansi" encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x) = encodeField' 1 x encodeField (M.Interface x) = encodeField' 2 x @@ -257,15 +183,9 @@ [ T.toVariant code , T.toVariant $ T.toVariant x ] - -#line 854 "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 855 "src/wire.anansi" marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where @@ -283,8 +203,6 @@ pad 8 append bodyBytes checkMaximumSize - -#line 875 "src/wire.anansi" checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs @@ -292,8 +210,6 @@ in case T.mkSignature sigStr of Just x -> return x Nothing -> invalid - -#line 885 "src/wire.anansi" marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 -> Marshal marshalHeader msg serial bodySig bodyLength = do @@ -306,12 +222,8 @@ let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] marshal . T.toVariant . fromJust . T.toArray fieldType $ map encodeField fields - -#line 900 "src/wire.anansi" marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness - -#line 905 "src/wire.anansi" checkMaximumSize :: Marshal checkMaximumSize = do (MarshalState _ _ messageLength) <- State.get diff --git a/hs/DBus/Wire/Unicode.hs b/hs/DBus/Wire/Unicode.hs --- a/hs/DBus/Wire/Unicode.hs +++ b/hs/DBus/Wire/Unicode.hs @@ -1,7 +1,3 @@ - -#line 498 "src/wire.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,8 +12,6 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 499 "src/wire.anansi" module DBus.Wire.Unicode ( maybeEncodeUtf8 , maybeDecodeUtf8) where diff --git a/hs/DBus/Wire/Unmarshal.hs b/hs/DBus/Wire/Unmarshal.hs --- a/hs/DBus/Wire/Unmarshal.hs +++ b/hs/DBus/Wire/Unmarshal.hs @@ -1,7 +1,3 @@ - -#line 215 "src/wire.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,48 +12,22 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 216 "src/wire.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 217 "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 - -#line 220 "src/wire.anansi" - -#line 231 "src/wire.anansi" import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L - -#line 302 "src/wire.anansi" import qualified Data.Binary.Get as G - -#line 448 "src/wire.anansi" import qualified Data.Binary.IEEE754 as IEEE - -#line 540 "src/wire.anansi" import DBus.Wire.Unicode (maybeDecodeUtf8) - -#line 763 "src/wire.anansi" import qualified DBus.Message.Internal as M - -#line 769 "src/wire.anansi" import Data.Bits ((.&.)) import qualified Data.Set as Set - -#line 915 "src/wire.anansi" import qualified DBus.Constants as C - -#line 221 "src/wire.anansi" import Control.Monad (when, unless, liftM) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) @@ -65,23 +35,15 @@ import DBus.Wire.Internal import qualified DBus.Types as T - -#line 238 "src/wire.anansi" data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) - -#line 243 "src/wire.anansi" 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 - -#line 249 "src/wire.anansi" unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes unmarshalType :: T.Type -> Unmarshal T.Variant - -#line 422 "src/wire.anansi" unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le @@ -98,41 +60,25 @@ unmarshalType T.DBusInt64 = do x <- unmarshalGet 8 G.getWord64be G.getWord64le return . T.toVariant $ (fromIntegral x :: Int64) - -#line 463 "src/wire.anansi" unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le - -#line 480 "src/wire.anansi" unmarshalType T.DBusBoolean = unmarshalWord32 >>= fromMaybeU' "boolean" (\x -> case x of 0 -> Just False 1 -> Just True _ -> Nothing) - -#line 563 "src/wire.anansi" unmarshalType T.DBusString = fmap T.toVariant unmarshalText unmarshalType T.DBusObjectPath = unmarshalText >>= fromMaybeU' "object path" T.mkObjectPath - -#line 607 "src/wire.anansi" unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature - -#line 623 "src/wire.anansi" unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t - -#line 705 "src/wire.anansi" unmarshalType (T.DBusDictionary kt vt) = do let pairType = T.DBusStructure [kt, vt] array <- unmarshalArray pairType fromMaybeU' "dictionary" T.arrayToDictionary array - -#line 725 "src/wire.anansi" unmarshalType (T.DBusStructure ts) = do skipPadding 8 fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts - -#line 747 "src/wire.anansi" unmarshalType T.DBusVariant = do let getType sig = case T.signatureTypes sig of [t] -> Just t @@ -140,8 +86,6 @@ t <- fromMaybeU "variant signature" getType =<< unmarshalSignature T.toVariant `fmap` unmarshalType t - -#line 259 "src/wire.anansi" consume :: Word64 -> Unmarshal L.ByteString consume count = do (UnmarshalState e bytes offset) <- State.get @@ -151,24 +95,18 @@ State.put $ UnmarshalState e bytes' (offset + count) return x - -#line 271 "src/wire.anansi" skipPadding :: Word8 -> Unmarshal () skipPadding count = do (UnmarshalState _ _ offset) <- State.get bytes <- consume $ padding offset count unless (L.all (== 0) bytes) $ E.throwError $ InvalidPadding offset - -#line 280 "src/wire.anansi" skipTerminator :: Unmarshal () skipTerminator = do (UnmarshalState _ _ offset) <- State.get bytes <- consume 1 unless (L.all (== 0) bytes) $ E.throwError $ MissingTerminator offset - -#line 289 "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' @@ -179,8 +117,6 @@ fromMaybeU' label f x = do x' <- fromMaybeU label f x return $ T.toVariant x' - -#line 306 "src/wire.anansi" unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do skipPadding count @@ -194,8 +130,6 @@ 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 - -#line 322 "src/wire.anansi" untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do done <- test @@ -205,8 +139,6 @@ x <- comp xs <- untilM test comp return $ x:xs - -#line 349 "src/wire.anansi" data UnmarshalError = UnsupportedProtocolVersion Word8 | UnexpectedEOF Word64 @@ -234,20 +166,14 @@ show (MissingTerminator pos) = concat ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" - -#line 407 "src/wire.anansi" unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le - -#line 544 "src/wire.anansi" unmarshalText :: Unmarshal Text unmarshalText = do byteCount <- unmarshalWord32 bytes <- consume . fromIntegral $ byteCount skipTerminator fromMaybeU "text" maybeDecodeUtf8 bytes - -#line 589 "src/wire.anansi" unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do byteCount <- L.head `fmap` consume 1 @@ -255,14 +181,10 @@ sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes skipTerminator fromMaybeU "signature" T.mkSignature sigText - -#line 672 "src/wire.anansi" unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do byteCount <- unmarshalWord32 T.arrayFromBytes `fmap` consume (fromIntegral byteCount) - -#line 679 "src/wire.anansi" unmarshalArray itemType = do let getOffset = do (UnmarshalState _ _ o) <- State.get @@ -276,16 +198,12 @@ when (end' > end) $ E.throwError ArraySizeMismatch fromMaybeU "array" (T.arrayFromItems itemType) vs - -#line 786 "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] - -#line 815 "src/wire.anansi" decodeField :: Monad m => T.Structure -> E.ErrorT UnmarshalError m [M.HeaderField] decodeField struct = case unpackField struct of @@ -304,42 +222,26 @@ decodeField' x f label = case T.fromVariant x of Just x' -> return [f x'] Nothing -> E.throwError $ InvalidHeaderField label x - -#line 836 "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 923 "src/wire.anansi" - -#line 169 "src/api-docs.anansi" -- | Read bytes from a monad until a complete message has been received. - -#line 924 "src/wire.anansi" unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do let getBytes = lift . getBytes' - -#line 939 "src/wire.anansi" let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16 - -#line 948 "src/wire.anansi" let messageVersion = L.index fixedBytes 3 when (messageVersion /= C.protocolVersion) $ E.throwError $ UnsupportedProtocolVersion messageVersion - -#line 956 "src/wire.anansi" let eByte = L.index fixedBytes 0 endianness <- case decodeEndianness eByte of Just x' -> return x' Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte - -#line 966 "src/wire.anansi" let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of Right x' -> return x' Left e -> E.throwError e @@ -348,63 +250,35 @@ let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 let bodyLength = fromJust . T.fromVariant $ fixed !! 4 let serial = fromJust . T.fromVariant $ fixed !! 5 - -#line 981 "src/wire.anansi" let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 - -#line 930 "src/wire.anansi" - -#line 988 "src/wire.anansi" let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount let headerBytes = L.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes - -#line 997 "src/wire.anansi" let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray fields <- concat `liftM` mapM decodeField fieldStructures - -#line 931 "src/wire.anansi" - -#line 1006 "src/wire.anansi" let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 getBytes . fromIntegral $ bodyPadding - -#line 1017 "src/wire.anansi" let bodySig = findBodySignature fields - -#line 1023 "src/wire.anansi" bodyBytes <- getBytes bodyLength body <- unmarshal' bodySig bodyBytes - -#line 932 "src/wire.anansi" - -#line 1043 "src/wire.anansi" y <- case buildReceivedMessage typeCode fields of EitherM (Right x) -> return x EitherM (Left x) -> E.throwError $ MissingHeaderField x return $ y serial flags body - -#line 1011 "src/wire.anansi" findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where signature = listToMaybe [x | M.Signature x <- fields] - -#line 1034 "src/wire.anansi" 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 - -#line 1052 "src/wire.anansi" buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) - -#line 1060 "src/wire.anansi" buildReceivedMessage 1 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -414,8 +288,6 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodCall path member iface dest flags body in M.ReceivedMethodCall serial sender msg - -#line 1074 "src/wire.anansi" buildReceivedMessage 2 fields = do replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] return $ \serial _ body -> let @@ -423,8 +295,6 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodReturn replySerial dest body in M.ReceivedMethodReturn serial sender msg - -#line 1086 "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] @@ -433,8 +303,6 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Error name replySerial dest body in M.ReceivedError serial sender msg - -#line 1099 "src/wire.anansi" buildReceivedMessage 4 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -444,14 +312,10 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Signal path member iface dest body in M.ReceivedSignal serial sender msg - -#line 1113 "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 - -#line 1120 "src/wire.anansi" require :: Text -> [a] -> EitherM Text a require _ (x:_) = return x require label _ = EitherM $ Left label diff --git a/hs/Tests.hs b/hs/Tests.hs --- a/hs/Tests.hs +++ b/hs/Tests.hs @@ -1,7 +1,3 @@ - -#line 64 "src/introduction.anansi" - -#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -16,16 +12,8 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - -#line 65 "src/introduction.anansi" - -#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} - -#line 66 "src/introduction.anansi" module Main (tests, main) where - -#line 163 "src/util.anansi" import Test.QuickCheck import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -52,12 +40,8 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I -#line 68 "src/introduction.anansi" - tests :: [F.Test] tests = [ F.testGroup "dummy" [] - -#line 370 "src/types.anansi" , F.testGroup "String" [ testProperty "String -> strict Text" $ funEq (fromVariant . toVariant) (Just . T.pack) @@ -72,27 +56,19 @@ , testProperty "Strict Text <- lazy Text" $ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) ] - -#line 611 "src/types.anansi" , F.testGroup "Signature" [ testProperty "Signature identity" $ funEq (mkSignature . strSignature) Just ] - -#line 675 "src/types.anansi" , F.testGroup "ObjectPath" [ testProperty "ObjectPath identity" $ funEq (mkObjectPath . strObjectPath) Just ] - -#line 822 "src/types.anansi" , F.testGroup "Array" [ testProperty "Array identity" $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) , testProperty "Array homogeneity" prop_ArrayHomogeneous ] - -#line 950 "src/types.anansi" , F.testGroup "Dictionary" [ testProperty "Dictionary identity" $ \x -> Just x == dictionaryFromItems @@ -106,32 +82,22 @@ , testProperty "Dictionary <-> Array conversion" $ funEq (arrayToDictionary . dictionaryToArray) Just ] - -#line 1110 "src/types.anansi" , F.testGroup "BusName" [ testProperty "BusName identity" $ funEq (mkBusName . strBusName) Just ] - -#line 1157 "src/types.anansi" , F.testGroup "InterfaceName" [ testProperty "InterfaceName identity" $ funEq (mkInterfaceName . strInterfaceName) Just ] - -#line 1189 "src/types.anansi" , F.testGroup "ErrorName" [ testProperty "ErrorName identity" $ funEq (mkErrorName . strErrorName) Just ] - -#line 1232 "src/types.anansi" , F.testGroup "MemberName" [ testProperty "MemberName identity" $ funEq (mkMemberName . strMemberName) Just ] - -#line 1161 "src/wire.anansi" , F.testGroup "Wire format" [ testProperty "Marshal -> Ummarshal" prop_Unmarshal , F.testGroup "Messages" @@ -141,8 +107,6 @@ , testProperty "Signals" prop_WireSignal ] ] - -#line 177 "src/addresses.anansi" , F.testGroup "Addresses" [ testProperty "Address identity" $ \x -> mkAddresses (strAddress x) == Just [x] @@ -173,8 +137,6 @@ , test "no param" $ isNothing . mkAddresses $ "a:," ] ] - -#line 472 "src/introspection.anansi" , F.testGroup "Introspection" [ testProperty "Generate -> Parse" $ \x@(I.Object path _ _) -> let @@ -183,14 +145,10 @@ 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 95 "src/types.anansi" instance Arbitrary Type where arbitrary = oneof [atomicType, containerType] @@ -221,8 +179,6 @@ return $ DBusDictionary kt vt 2 -> fmap DBusStructure $ halfSized arbitrary 3 -> return DBusVariant - -#line 258 "src/types.anansi" instance Arbitrary Variant where arbitrary = arbitrary >>= genVariant @@ -244,20 +200,14 @@ (DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) (DBusStructure _) -> fmap toVariant (arbitrary :: Gen Structure) DBusVariant -> fmap toVariant (arbitrary :: Gen Variant) - -#line 606 "src/types.anansi" instance Arbitrary Signature where arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary - -#line 666 "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 806 "src/types.anansi" instance Arbitrary Array where arbitrary = do t <- atomicType @@ -271,8 +221,6 @@ firstType = if null types then DBusByte else head types - -#line 932 "src/types.anansi" instance Arbitrary Dictionary where arbitrary = do kt <- atomicType @@ -288,12 +236,8 @@ vType = dictionaryValueType x correctType (k, v) = variantType k == kType && variantType v == vType - -#line 1016 "src/types.anansi" instance Arbitrary Structure where arbitrary = fmap Structure $ halfSized arbitrary - -#line 1090 "src/types.anansi" instance Arbitrary BusName where arbitrary = sizedText 255 (oneof [unique, wellKnown]) where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" @@ -311,8 +255,6 @@ x <- elements start xs <- atLeast 0 (elements c') return (x:xs) - -#line 1143 "src/types.anansi" instance Arbitrary InterfaceName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -324,12 +266,8 @@ x <- elements c xs <- atLeast 0 (elements c') return (x:xs) - -#line 1184 "src/types.anansi" instance Arbitrary ErrorName where arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary - -#line 1220 "src/types.anansi" instance Arbitrary MemberName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -339,16 +277,10 @@ 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 @@ -358,16 +290,12 @@ 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 @@ -375,8 +303,6 @@ dest <- arbitrary Structure body <- arbitrary return $ Error name serial dest body - -#line 300 "src/messages.anansi" instance Arbitrary Signal where arbitrary = do path <- arbitrary @@ -385,12 +311,8 @@ 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 1126 "src/wire.anansi" prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where sig = mkSignature . typeCode . variantType $ x @@ -423,8 +345,6 @@ 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'] ++ "-_/\\*." @@ -461,8 +381,6 @@ let addrStr = concat [m, ":", params, extraSemicolon] let Just [addr] = mkAddresses $ TL.pack addrStr return addr - -#line 407 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do @@ -525,8 +443,6 @@ [[], [I.Read], [I.Write], [I.Read, I.Write]] return $ I.Property (TL.pack name) sig access - -#line 191 "src/util.anansi" halfSized :: Gen a -> Gen a halfSized gen = sized $ \n -> if n > 0 then resize (n `div` 2) gen @@ -550,13 +466,9 @@ isRight :: Either a b -> Bool isRight = either (const False) (const True) - -#line 220 "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 229 "src/util.anansi" instance Arbitrary Word8 where arbitrary = arbitraryBoundedIntegral shrink = shrinkIntegral