dbus 1.0.1 → 1.1.0

raw patch · 8 files changed

+244/−251 lines, 8 filesdep +conduitdep +exceptionsdep +xml-conduitdep −libxml-saxdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: conduit, exceptions, xml-conduit

Dependencies removed: libxml-sax

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• benchmarks/DBusBenchmarks.hs +6/−3
• dbus.cabal +4/−4
• lib/DBus/Generation.hs +1/−1
• lib/DBus/Internal/Types.hs +108/−128
• lib/DBus/Introspection.hs +119/−114
• lib/DBus/TH.hs +0/−1
• tests/DBusTests/Generation.hs +5/−0
• tests/DBusTests/Introspection.hs +1/−0

@@ -40,13 +40,16 @@ benchUnmarshal name msg = bench name (whnf unmarshal bytes) where     Right bytes = marshal LittleEndian (serial 0) msg +parseSig :: String -> Maybe Signature+parseSig = parseSignature+ benchmarks :: [Benchmark] benchmarks =     [  bgroup "Types"         [ bgroup "Signature"-            [ bench "parseSignature/small" (nf parseSignature "y")-            , bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)")-            , bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}")+            [ bench "parseSignature/small" (nf parseSig "y")+            , bench "parseSignature/medium" (nf parseSig "yyyyuua(yv)")+            , bench "parseSignature/large" (nf parseSig "a{s(asiiiiasa(siiia{s(iiiiv)}))}")             ]         , bgroup "ObjectPath"             [ bench "objectPath_/small" (nf objectPath_ "/")

@@ -1,5 +1,5 @@ name: dbus-version: 1.0.1+version: 1.1.0 license: Apache-2.0 license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -83,11 +83,12 @@       base >=4 && <5     , bytestring     , cereal+    , conduit     , containers     , deepseq+    , exceptions     , filepath     , lens-    , libxml-sax     , network     , parsec     , random@@ -98,6 +99,7 @@     , transformers     , unix     , vector+    , xml-conduit     , xml-types    exposed-modules:@@ -128,7 +130,6 @@     , directory     , extra     , filepath-    , libxml-sax     , network     , parsec     , process@@ -142,7 +143,6 @@     , transformers     , unix     , vector-    , xml-types    other-modules:     DBusTests.Address

@@ -356,7 +356,7 @@           buildSignature $ AppT (ConT ''IO) $                          AppT (AppT (ConT ''Either)                                       (ConT ''M.MethodError)) $ getArgType propType-        setterSigType = buildSignature $+        setterSigType = buildSignature $ addTypeArg (getArgType propType) $                         AppT (ConT ''IO) $ AppT (ConT ''Maybe) (ConT ''M.MethodError)         buildArgs rest = clientN:addArgIf takeBusArg busN                          (addArgIf takeObjectPathArg objectPathN rest)

@@ -1,15 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}  -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.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.@@ -25,13 +21,11 @@ module DBus.Internal.Types where  import           Control.DeepSeq-import           Control.Exception (Exception, handle, throwIO) import           Control.Monad (liftM, when, (>=>))-import qualified Data.ByteString-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as Char8-import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Unsafe+import           Control.Monad.Catch+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL import           Data.Char (ord) import           Data.Coerce import           Data.Int@@ -47,10 +41,8 @@ import qualified Data.Vector import           Data.Vector (Vector) import           Data.Word-import qualified Foreign import           GHC.Generics import qualified Language.Haskell.TH.Lift as THL-import           System.IO.Unsafe (unsafePerformIO) import           System.Posix.Types (Fd) import           Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Text.ParserCombinators.Parsec as Parsec@@ -188,29 +180,29 @@  -- | Parse a signature string into a valid signature. ----- Returns @Nothing@ if the given string is not a valid signature.-parseSignature :: String -> Maybe Signature+-- Throws if the given string is not a valid signature.+parseSignature :: MonadThrow m => String -> m Signature parseSignature s = do-    when (length s > 255) Nothing-    when (any (\c -> ord c > 0x7F) s) Nothing-    parseSignatureBytes (Char8.pack s)+    when (length s > 255) $ throwM $ userError "string too long"+    when (any (\c -> ord c > 0x7F) s) $ throwM $ userError "invalid signature"+    parseSignatureBytes (BS8.pack s) -parseSignatureBytes :: ByteString -> Maybe Signature+parseSignatureBytes :: MonadThrow m => BS.ByteString -> m Signature parseSignatureBytes bytes =-    case Data.ByteString.length bytes of-        0 -> Just (Signature [])+    case BS.length bytes of+        0 -> pure (Signature [])         1 -> parseSigFast bytes         len | len <= 255 -> parseSigFull bytes-        _ -> Nothing+        _ -> throwM $ userError "string too long" -parseSigFast :: ByteString -> Maybe Signature+parseSigFast :: MonadThrow m => BS.ByteString -> m Signature parseSigFast bytes =-    let byte = Data.ByteString.Unsafe.unsafeHead bytes in-    parseAtom (fromIntegral byte)-        (\t -> Just (Signature [t]))-        (case byte of-            0x76 -> Just (Signature [TypeVariant])-            _ -> Nothing)+    let byte = BS.head bytes+     in parseAtom (fromIntegral byte)+            (\t -> pure (Signature [t]))+            (case byte of+                0x76 -> pure (Signature [TypeVariant])+                _ -> throwM $ userError "invalid signature")  parseAtom :: Int -> (Type -> a) -> a -> a parseAtom byte yes no = case byte of@@ -235,94 +227,82 @@  instance Exception SigParseError -peekWord8AsInt :: Foreign.Ptr Word8 -> Int -> IO Int-peekWord8AsInt ptr off = do-    w <- Foreign.peekElemOff ptr off-    return (fromIntegral w)--parseSigFull :: ByteString -> Maybe Signature-parseSigFull bytes = unsafePerformIO io where-    io = handle-        (\SigParseError -> return Nothing)-        $ Data.ByteString.Unsafe.unsafeUseAsCStringLen bytes-        $ \(ptr, len) -> do-            ts <- parseSigBuf (Foreign.castPtr ptr, len)-            return (Just (Signature ts))+peekWord8AsInt :: BS.ByteString -> Int -> Int+peekWord8AsInt str i = fromIntegral $ BS.index str i -    parseSigBuf (buf, len) = mainLoop [] 0 where+parseSigFull :: MonadThrow m => BS.ByteString -> m Signature+parseSigFull bytes = Signature <$> mainLoop [] 0+  where+    len = BS.length bytes+    mainLoop acc ii | ii >= len = pure (reverse acc)+    mainLoop acc ii = do+        let c = peekWord8AsInt bytes ii+        let next t = mainLoop (t : acc) (ii + 1)+        parseAtom c next $ case c of+            0x76 -> next TypeVariant+            0x28 -> do -- '('+                (ii', t) <- structure (ii + 1)+                mainLoop (t : acc) ii'+            0x61 -> do -- 'a'+                (ii', t) <- array (ii + 1)+                mainLoop (t : acc) ii'+            _ -> throwM SigParseError -        mainLoop acc ii | ii >= len = return (reverse acc)-        mainLoop acc ii = do-            c <- peekWord8AsInt buf ii-            let next t = mainLoop (t : acc) (ii + 1)+    structure = loop [] where+        loop _ ii | ii >= len = throwM SigParseError+        loop acc ii = do+            let c = peekWord8AsInt bytes ii+            let next t = loop (t : acc) (ii + 1)             parseAtom c next $ case c of                 0x76 -> next TypeVariant                 0x28 -> do -- '('                     (ii', t) <- structure (ii + 1)-                    mainLoop (t : acc) ii'+                    loop (t : acc) ii'                 0x61 -> do -- 'a'                     (ii', t) <- array (ii + 1)-                    mainLoop (t : acc) ii'-                _ -> throwIO SigParseError--        structure :: Int -> IO (Int, Type)-        structure = loop [] where-            loop _ ii | ii >= len = throwIO SigParseError-            loop acc ii = do-                c <- peekWord8AsInt buf ii-                let next t = loop (t : acc) (ii + 1)-                parseAtom c next $ case c of-                    0x76 -> next TypeVariant-                    0x28 -> do -- '('-                        (ii', t) <- structure (ii + 1)-                        loop (t : acc) ii'-                    0x61 -> do -- 'a'-                        (ii', t) <- array (ii + 1)-                        loop (t : acc) ii'-                    -- ')'-                    0x29 -> case acc of-                        [] -> throwIO SigParseError-                        _ -> return (ii + 1, TypeStructure (reverse acc))-                    _ -> throwIO SigParseError+                    loop (t : acc) ii'+                -- ')'+                0x29 -> case acc of+                    [] -> throwM SigParseError+                    _ -> pure (ii + 1, TypeStructure (reverse acc))+                _ -> throwM SigParseError -        array :: Int -> IO (Int, Type)-        array ii | ii >= len = throwIO SigParseError-        array ii = do-            c <- peekWord8AsInt buf ii-            let next t = return (ii + 1, TypeArray t)-            parseAtom c next $ case c of-                0x76 -> next TypeVariant-                0x7B -> dict (ii + 1) -- '{'-                0x28 -> do -- '('-                    (ii', t) <- structure (ii + 1)-                    return (ii', TypeArray t)-                0x61 -> do -- 'a'-                    (ii', t) <- array (ii + 1)-                    return (ii', TypeArray t)-                _ -> throwIO SigParseError+    array ii | ii >= len = throwM SigParseError+    array ii = do+        let c = peekWord8AsInt bytes ii+        let next t = pure (ii + 1, TypeArray t)+        parseAtom c next $ case c of+            0x76 -> next TypeVariant+            0x7B -> dict (ii + 1) -- '{'+            0x28 -> do -- '('+                (ii', t) <- structure (ii + 1)+                pure (ii', TypeArray t)+            0x61 -> do -- 'a'+                (ii', t) <- array (ii + 1)+                pure (ii', TypeArray t)+            _ -> throwM SigParseError -        dict :: Int -> IO (Int, Type)-        dict ii | ii + 1 >= len = throwIO SigParseError-        dict ii = do-            c1 <- peekWord8AsInt buf ii-            c2 <- peekWord8AsInt buf (ii + 1)+    dict ii | ii + 1 >= len = throwM SigParseError+    dict ii = do+        let c1 = peekWord8AsInt bytes ii+        let c2 = peekWord8AsInt bytes (ii + 1) -            let next t = return (ii + 2, t)-            (ii', t2) <- parseAtom c2 next $ case c2 of-                0x76 -> next TypeVariant-                0x28 -> structure (ii + 2) -- '('-                0x61 -> array (ii + 2) -- 'a'-                _ -> throwIO SigParseError+        let next t = pure (ii + 2, t)+        (ii', t2) <- parseAtom c2 next $ case c2 of+            0x76 -> next TypeVariant+            0x28 -> structure (ii + 2) -- '('+            0x61 -> array (ii + 2) -- 'a'+            _ -> throwM SigParseError -            if ii' >= len-                then throwIO SigParseError-                else do-                    c3 <- peekWord8AsInt buf ii'-                    if c3 == 0x7D-                        then do-                            t1 <- parseAtom c1 return (throwIO SigParseError)-                            return (ii' + 1, TypeDictionary t1 t2)-                        else throwIO SigParseError+        if ii' >= len+            then throwM SigParseError+            else do+                let c3 = peekWord8AsInt bytes ii'+                if c3 == 0x7D+                    then do+                        t1 <- parseAtom c1 pure (throwM SigParseError)+                        pure (ii' + 1, TypeDictionary t1 t2)+                    else throwM SigParseError  extractFromVariant :: IsValue a => Variant -> Maybe a extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v@@ -359,7 +339,7 @@ data Value     = ValueAtom Atom     | ValueVariant Variant-    | ValueBytes ByteString+    | ValueBytes BS.ByteString     | ValueVector Type (Vector Value)     | ValueMap Type Type (Map Atom Value)     | ValueStructure [Value]@@ -427,8 +407,8 @@ showThings :: String -> (a -> String) -> String -> [a] -> String showThings a s z xs = a ++ intercalate ", " (map s xs) ++ z -vectorToBytes :: Vector Value -> ByteString-vectorToBytes = Data.ByteString.pack+vectorToBytes :: Vector Value -> BS.ByteString+vectorToBytes = BS.pack               . Data.Vector.toList               . Data.Vector.map (\(ValueAtom (AtomWord8 x)) -> x) @@ -556,26 +536,26 @@     toVariant = toVariant . Data.Vector.fromList     fromVariant = fmap Data.Vector.toList . fromVariant -instance IsValue ByteString where+instance IsValue BS.ByteString where     typeOf _ = TypeArray TypeWord8     toValue = ValueBytes     fromValue (ValueBytes bs) = Just bs     fromValue (ValueVector TypeWord8 v) = Just (vectorToBytes v)     fromValue _ = Nothing -instance IsVariant ByteString where+instance IsVariant BS.ByteString where     toVariant = Variant . toValue     fromVariant (Variant val) = fromValue val -instance IsValue Data.ByteString.Lazy.ByteString where+instance IsValue BL.ByteString where     typeOf _ = TypeArray TypeWord8     toValue = toValue-            . Data.ByteString.concat-            . Data.ByteString.Lazy.toChunks-    fromValue = fmap (\bs -> Data.ByteString.Lazy.fromChunks [bs])+            . BS.concat+            . BL.toChunks+    fromValue = fmap (\bs -> BL.fromChunks [bs])               . fromValue -instance IsVariant Data.ByteString.Lazy.ByteString where+instance IsVariant BL.ByteString where     toVariant = Variant . toValue     fromVariant (Variant val) = fromValue val @@ -663,7 +643,7 @@ formatObjectPath :: ObjectPath -> String formatObjectPath (ObjectPath s) = s -parseObjectPath :: String -> Maybe ObjectPath+parseObjectPath :: MonadThrow m => String -> m ObjectPath parseObjectPath s = do     maybeParseString parserObjectPath s     return (ObjectPath s)@@ -706,9 +686,9 @@ formatInterfaceName :: InterfaceName -> String formatInterfaceName (InterfaceName s) = s -parseInterfaceName :: String -> Maybe InterfaceName+parseInterfaceName :: MonadThrow m => String -> m InterfaceName parseInterfaceName s = do-    when (length s > 255) Nothing+    when (length s > 255) $ throwM $ userError "name too long"     maybeParseString parserInterfaceName s     return (InterfaceName s) @@ -746,9 +726,9 @@ formatMemberName :: MemberName -> String formatMemberName (MemberName s) = s -parseMemberName :: String -> Maybe MemberName+parseMemberName :: MonadThrow m => String -> m MemberName parseMemberName s = do-    when (length s > 255) Nothing+    when (length s > 255) $ throwM $ userError "name too long"     maybeParseString parserMemberName s     return (MemberName s) @@ -783,9 +763,9 @@ formatErrorName :: ErrorName -> String formatErrorName (ErrorName s) = s -parseErrorName :: String -> Maybe ErrorName+parseErrorName :: MonadThrow m => String -> m ErrorName parseErrorName s = do-    when (length s > 255) Nothing+    when (length s > 255) $ throwM $ userError "name too long"     maybeParseString parserInterfaceName s     return (ErrorName s) @@ -813,9 +793,9 @@ formatBusName :: BusName -> String formatBusName (BusName s) = s -parseBusName :: String -> Maybe BusName+parseBusName :: MonadThrow m => String -> m BusName parseBusName s = do-    when (length s > 255) Nothing+    when (length s > 255) $ throwM $ userError "name too long"     maybeParseString parserBusName s     return (BusName s) @@ -883,7 +863,7 @@ -- 'IsValue'. data Array     = Array Type (Vector Value)-    | ArrayBytes ByteString+    | ArrayBytes BS.ByteString  instance Show Array where     show (Array t xs) = showValue True (ValueVector t xs)@@ -904,7 +884,7 @@  arrayItems :: Array -> [Variant] arrayItems (Array _ xs) = map Variant (Data.Vector.toList xs)-arrayItems (ArrayBytes bs) = map toVariant (Data.ByteString.unpack bs)+arrayItems (ArrayBytes bs) = map toVariant (BS.unpack bs)  -- | A D-Bus Dictionary is a container type similar to Haskell maps, storing -- zero or more associations between keys and values.@@ -1365,9 +1345,9 @@     Just x -> x     Nothing -> error ("Invalid " ++ label ++ ": " ++ show str) -maybeParseString :: Parsec.Parser a -> String -> Maybe a+maybeParseString :: MonadThrow m => Parsec.Parser a -> String -> m a maybeParseString parser s = case Parsec.parse parser "" s of-    Left _ -> Nothing-    Right a -> Just a+    Left err -> throwM $ userError $ show err+    Right a -> pure a  THL.deriveLiftMany [''BusName, ''ObjectPath, ''InterfaceName, ''MemberName]

@@ -29,16 +29,15 @@     , Property(..)     ) where +import           Conduit import qualified Control.Applicative-import           Control.Monad ((>=>), ap, liftM)-import           Control.Monad.ST (runST)+import           Control.Monad (ap, liftM)+import qualified Data.ByteString.Lazy.Char8 as BL8 import           Data.List (isPrefixOf)-import qualified Data.STRef as ST-import qualified Data.Text-import           Data.Text (Text)-import qualified Data.Text.Encoding-import qualified Data.XML.Types as X-import qualified Text.XML.LibXML.SAX as SAX+import           Data.Maybe+import qualified Data.Text as Text+import           Data.XML.Types+import qualified Text.XML.Stream.Parse as X  import qualified DBus as T @@ -93,124 +92,130 @@     }     deriving (Show, Eq) -parseXML :: T.ObjectPath -> String -> Maybe Object-parseXML path xml = do-    root <- parseElement (Data.Text.pack xml)-    parseRoot path root+data ObjectChildren+    = InterfaceDefinition Interface+    | SubNode Object -parseElement :: Text -> Maybe X.Element-parseElement xml = runST $ do-    stackRef <- ST.newSTRef [([], [])]-    let onError _ = do-        ST.writeSTRef stackRef []-        return False-    let onBegin _ attrs = do-        ST.modifySTRef stackRef ((attrs, []):)-        return True-    let onEnd 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'')-        return True+data InterfaceChildren+    = MethodDefinition Method+    | SignalDefinition Signal+    | PropertyDefinition Property -    p <- SAX.newParserST Nothing-    SAX.setCallback p SAX.parsedBeginElement onBegin-    SAX.setCallback p SAX.parsedEndElement onEnd-    SAX.setCallback p SAX.reportError onError-    SAX.parseBytes p (Data.Text.Encoding.encodeUtf8 xml)-    SAX.parseComplete p-    stack <- ST.readSTRef stackRef-    return $ case stack of-        [] -> Nothing-        (_, children'):_ -> Just (head children')+parseXML :: T.ObjectPath -> String -> Maybe Object+parseXML path xml =+    runConduit $ X.parseLBS X.def (BL8.pack xml) .| X.force "parse error" (parseObject $ getRootName path) -parseRoot :: T.ObjectPath -> X.Element -> Maybe Object-parseRoot defaultPath e = do-    path <- case X.attributeText "name" e of-        Nothing -> Just defaultPath-        Just x  -> T.parseObjectPath (Data.Text.unpack x)-    parseObject path e+getRootName :: T.ObjectPath -> X.AttrParser T.ObjectPath+getRootName defaultPath = do+    nodeName <- X.attr "name"+    pure $ maybe defaultPath (T.objectPath_ . Text.unpack) nodeName -parseChild :: T.ObjectPath -> X.Element -> Maybe Object-parseChild parentPath e = do+getChildName :: T.ObjectPath -> X.AttrParser T.ObjectPath+getChildName parentPath = do+    nodeName <- X.requireAttr "name"     let parentPath' = case T.formatObjectPath parentPath of             "/" -> "/"             x   -> x ++ "/"-    pathSegment <- X.attributeText "name" e-    path <- T.parseObjectPath (parentPath' ++ Data.Text.unpack pathSegment)-    parseObject path e--parseObject :: T.ObjectPath -> X.Element -> Maybe Object-parseObject path e | X.elementName e == "node" = do-    interfaces <- children parseInterface (X.isNamed "interface") e-    children' <- children (parseChild path) (X.isNamed "node") e-    return (Object path interfaces children')-parseObject _ _ = Nothing--parseInterface :: X.Element -> Maybe Interface-parseInterface e = do-    name <- T.parseInterfaceName =<< attributeString "name" e-    methods <- children parseMethod (X.isNamed "method") e-    signals <- children parseSignal (X.isNamed "signal") e-    properties <- children parseProperty (X.isNamed "property") e-    return (Interface name methods signals properties)--parseMethod :: X.Element -> Maybe Method-parseMethod e = do-    name <- T.parseMemberName =<< attributeString "name" e-    args <- children parseMethodArg (isArg ["in", "out", ""]) e-    return (Method name args)--parseSignal :: X.Element -> Maybe Signal-parseSignal e = do-    name <- T.parseMemberName =<< attributeString "name" e-    args <- children parseSignalArg (isArg ["out", ""]) e-    return (Signal name args)+    pure $ T.objectPath_ (parentPath' ++ Text.unpack nodeName) -parseType :: X.Element -> Maybe T.Type-parseType e = do-    typeStr <- attributeString "type" e-    sig <- T.parseSignature typeStr-    case T.signatureTypes sig of-        [t] -> Just t-        _ -> Nothing+parseObject+    :: X.AttrParser T.ObjectPath+    -> ConduitT Event o Maybe (Maybe Object)+parseObject getPath = X.tag' "node" getPath parseContent+  where+    parseContent objPath = do+        elems <- X.many $ X.choose+            [ fmap SubNode <$> parseObject (getChildName objPath)+            , fmap InterfaceDefinition <$> parseInterface+            ]+        let base = Object objPath [] []+            addElem e (Object p is cs) = case e of+                InterfaceDefinition i -> Object p (i:is) cs+                SubNode c -> Object p is (c:cs)+        pure $ foldr addElem base elems -parseMethodArg :: X.Element -> Maybe MethodArg-parseMethodArg e = do-    t <- parseType e-    let dir = case getattr "direction" e of-            "out" -> Out-            _ -> In-    Just (MethodArg (getattr "name" e) t dir)+parseInterface+    :: ConduitT Event o Maybe (Maybe Interface)+parseInterface = X.tag' "interface" getName parseContent+  where+    getName = do+        ifName <- X.requireAttr "name"+        pure $ T.interfaceName_ (Text.unpack ifName)+    parseContent ifName = do+        elems <- X.many $ X.choose+            [ parseMethod+            , parseSignal+            , parseProperty+            ]+        let base = Interface ifName [] [] []+            addElem e (Interface n ms ss ps) = case e of+                MethodDefinition m -> Interface n (m:ms) ss ps+                SignalDefinition s -> Interface n ms (s:ss) ps+                PropertyDefinition p -> Interface n ms ss (p:ps)+        pure $ foldr addElem base elems -parseSignalArg :: X.Element -> Maybe SignalArg-parseSignalArg e = do-    t <- parseType e-    Just (SignalArg (getattr "name" e) t)+parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseMethod = X.tag' "method" getName parseArgs+  where+    getName = do+        ifName <- X.requireAttr "name"+        T.parseMemberName (Text.unpack ifName)+    parseArgs name = do+        args <- X.many $+            X.tag' "arg" getArg pure+        pure $ MethodDefinition $ Method name args+    getArg = do+        name <- fromMaybe "" <$> X.attr "name"+        typeStr <- X.requireAttr "type"+        dirStr <- fromMaybe "in" <$> X.attr "direction"+        X.ignoreAttrs+        typ <- parseType typeStr+        let dir = if dirStr == "in" then In else Out+        pure $ MethodArg (Text.unpack name) typ dir -isArg :: [String] -> X.Element -> [X.Element]-isArg dirs = X.isNamed "arg" >=> checkDir where-    checkDir e = [e | getattr "direction" e `elem` dirs]+parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseSignal = X.tag' "signal" getName parseArgs+  where+    getName = do+        ifName <- X.requireAttr "name"+        T.parseMemberName (Text.unpack ifName)+    parseArgs name = do+        args <- X.many $+            X.tag' "arg" getArg pure+        pure $ SignalDefinition $ Signal name args+    getArg = do+        name <- fromMaybe "" <$> X.attr "name"+        typeStr <- X.requireAttr "type"+        X.ignoreAttrs+        typ <- parseType typeStr+        pure $ SignalArg (Text.unpack name) typ -parseProperty :: X.Element -> Maybe Property-parseProperty e = do-    t <- parseType e-    (canRead, canWrite) <- case getattr "access" e of-        ""          -> Just (False, False)-        "read"      -> Just (True, False)-        "write"     -> Just (False, True)-        "readwrite" -> Just (True, True)-        _           -> Nothing-    Just (Property (getattr "name" e) t canRead canWrite)+parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseProperty = X.tag' "property" getProp $ \p -> do+    X.many_ X.ignoreAnyTreeContent+    pure p+  where+    getProp = do+        name <- Text.unpack <$> X.requireAttr "name"+        typeStr <- X.requireAttr "type"+        accessStr <- fromMaybe "" <$> X.attr "access"+        X.ignoreAttrs+        typ <- parseType typeStr+        (canRead, canWrite) <- case accessStr of+            ""          -> pure (False, False)+            "read"      -> pure (True, False)+            "write"     -> pure (False, True)+            "readwrite" -> pure (True, True)+            _           -> throwM $ userError "invalid access value" -getattr :: X.Name -> X.Element -> String-getattr name e = maybe "" Data.Text.unpack (X.attributeText name e)+        pure $ PropertyDefinition $ Property name typ canRead canWrite -children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b]-children f p = mapM f . concatMap p . X.elementChildren+parseType :: MonadThrow m => Text.Text -> m T.Type+parseType typeStr = do+    typ <- T.parseSignature (Text.unpack typeStr)+    case T.signatureTypes typ of+        [t] -> pure t+        _ -> throwM $ userError "invalid type sig"  newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, String) } @@ -317,8 +322,8 @@         , ("access", readS ++ writeS)         ] -attributeString :: X.Name -> X.Element -> Maybe String-attributeString name e = fmap Data.Text.unpack (X.attributeText name e)+--attributeString :: X.Name -> X.Element -> Maybe String+--attributeString name e = fmap Data.Text.unpack (X.attributeText name e)  writeElement :: String -> [(String, String)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do

@@ -6,7 +6,6 @@ import           DBus.Generation import           System.FilePath - generateSignalsFromInterface defaultGenerationParams $                              buildIntrospectionInterface $                              buildPropertiesInterface undefined

@@ -26,6 +26,11 @@ testInterface =   defaultInterface { interfaceMethods =                        [autoMethod "SampleMethod1" sampleMethod1]+                   , interfaceProperties =+                     [autoProperty "SampleWriteProperty"+                                     (Just $ return (1 :: Int32))+                                     (Just $ const $ return ())+                     ]                    , interfaceName = "org.TestInterface"                    , interfaceSignals = testSignals                    }

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-2012 John Millikin <john@john-millikin.com> -- -- Licensed under the Apache License, Version 2.0 (the "License");