dbus-core 0.8.4 → 0.8.5
raw patch · 4 files changed
+64/−66 lines, 4 filesdep ~libxml-saxPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: libxml-sax
API changes (from Hackage documentation)
Files
- dbus-core.cabal +2/−2
- hs/DBus/Introspection.hs +44/−45
- hs/Tests.hs +2/−2
- src/introspection.anansi +16/−17
dbus-core.cabal view
@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8.4+version: 0.8.5 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -42,7 +42,7 @@ , containers >= 0.1 && < 0.4 , unix >= 2.2 && < 2.5 , network >= 2.2 && < 2.3- , libxml-sax >= 0.5 && < 0.6+ , libxml-sax >= 0.6 && < 0.7 , xml-types >= 0.1 && < 0.2 exposed-modules:
hs/DBus/Introspection.hs view
@@ -46,9 +46,8 @@ import qualified Text.XML.LibXML.SAX as SAX import Control.Monad.ST (runST) import qualified Data.STRef as ST-import Data.Text.Encoding (encodeUtf8) -#line 254 "src/introspection.anansi"+#line 253 "src/introspection.anansi" import Control.Monad ((>=>)) import Data.Maybe (fromMaybe, listToMaybe) @@ -83,34 +82,34 @@ root <- parseElement text parseRoot path root -#line 113 "src/introspection.anansi"+#line 112 "src/introspection.anansi" parseElement :: Text -> Maybe X.Element parseElement text = runST $ do stackRef <- ST.newSTRef [([], [])]- let callbacks = SAX.ParserCallbacks- { SAX.parsedBeginElement = \_ attrs -> do- ST.modifySTRef stackRef ((attrs, []):)- , SAX.parsedEndElement = \name -> do- stack <- ST.readSTRef stackRef- let (attrs, children'):stack' = stack- let e = X.Element name attrs (map X.NodeElement (reverse children'))- let (pAttrs, pChildren):stack'' = stack'- let parent = (pAttrs, e:pChildren)- ST.writeSTRef stackRef (parent:stack'')- , SAX.parsedCharacters = \_ -> return ()- , SAX.parsedComment = \_ -> return ()- , SAX.parsedProcessingInstruction = \_ -> return ()- } let onError _ = ST.writeSTRef stackRef []- p <- SAX.newParser callbacks onError Nothing- mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text+ 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+ + p <- SAX.newParserST onError Nothing+ SAX.setCallback p SAX.parsedBeginElement onBegin+ SAX.setCallback p SAX.parsedEndElement onEnd+ SAX.parseLazyText p text SAX.parseComplete p stack <- ST.readSTRef stackRef return $ case stack of [] -> Nothing (_, children'):_ -> Just $ head children' -#line 148 "src/introspection.anansi"+#line 147 "src/introspection.anansi" parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do path <- case getattrM "name" e of@@ -118,7 +117,7 @@ Just x -> T.mkObjectPath x parseObject path e -#line 161 "src/introspection.anansi"+#line 160 "src/introspection.anansi" parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do let parentPath' = case T.strObjectPath parentPath of@@ -128,7 +127,7 @@ path <- T.mkObjectPath $ TL.append parentPath' pathSegment parseObject path e -#line 175 "src/introspection.anansi"+#line 174 "src/introspection.anansi" parseObject :: T.ObjectPath -> X.Element -> Maybe Object parseObject path e | X.elementName e == toName "node" = do interfaces <- children parseInterface (named "interface") e@@ -136,7 +135,7 @@ return $ Object path interfaces children' parseObject _ _ = Nothing -#line 186 "src/introspection.anansi"+#line 185 "src/introspection.anansi" parseInterface :: X.Element -> Maybe Interface parseInterface e = do name <- T.mkInterfaceName =<< getattrM "name" e@@ -145,7 +144,7 @@ properties <- children parseProperty (named "property") e return $ Interface name methods signals properties -#line 199 "src/introspection.anansi"+#line 198 "src/introspection.anansi" parseMethod :: X.Element -> Maybe Method parseMethod e = do name <- T.mkMemberName =<< getattrM "name" e@@ -153,21 +152,21 @@ paramsOut <- children parseParameter (isParam ["out"]) e return $ Method name paramsIn paramsOut -#line 210 "src/introspection.anansi"+#line 209 "src/introspection.anansi" parseSignal :: X.Element -> Maybe Signal parseSignal e = do name <- T.mkMemberName =<< getattrM "name" e params <- children parseParameter (isParam ["out", ""]) e return $ Signal name params -#line 220 "src/introspection.anansi"+#line 219 "src/introspection.anansi" parseParameter :: X.Element -> Maybe Parameter parseParameter e = do let name = getattr "name" e sig <- parseType e return $ Parameter name sig -#line 228 "src/introspection.anansi"+#line 227 "src/introspection.anansi" parseType :: X.Element -> Maybe T.Signature parseType e = do sig <- T.mkSignature =<< getattrM "type" e@@ -175,7 +174,7 @@ [_] -> Just sig _ -> Nothing -#line 240 "src/introspection.anansi"+#line 239 "src/introspection.anansi" parseProperty :: X.Element -> Maybe Property parseProperty e = do let name = getattr "name" e@@ -188,7 +187,7 @@ _ -> Nothing return $ Property name sig access -#line 259 "src/introspection.anansi"+#line 258 "src/introspection.anansi" getattrM :: Text -> X.Element -> Maybe Text getattrM name = fmap attrText . listToMaybe . attrs where attrText = textContent . X.attributeContent@@ -211,7 +210,7 @@ toName :: Text -> X.Name toName t = X.Name t Nothing Nothing -#line 293 "src/introspection.anansi"+#line 292 "src/introspection.anansi" newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) } instance Monad XmlWriter where@@ -221,24 +220,24 @@ (b, w') <- runXmlWriter (f a) return (b, TL.append w w') -#line 304 "src/introspection.anansi"+#line 303 "src/introspection.anansi" tell :: Text -> XmlWriter () tell t = XmlWriter $ Just ((), t) -#line 309 "src/introspection.anansi"+#line 308 "src/introspection.anansi" toXML :: Object -> Maybe Text toXML obj = do (_, text) <- runXmlWriter (writeRoot obj) return text -#line 316 "src/introspection.anansi"+#line 315 "src/introspection.anansi" writeRoot :: Object -> XmlWriter () writeRoot obj@(Object path _ _) = do tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'" tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n" writeObject (T.strObjectPath path) obj -#line 324 "src/introspection.anansi"+#line 323 "src/introspection.anansi" writeChild :: T.ObjectPath -> Object -> XmlWriter () writeChild parentPath obj@(Object path _ _) = write where path' = T.strObjectPath path@@ -253,14 +252,14 @@ Just relpath -> writeObject relpath obj Nothing -> XmlWriter Nothing -#line 340 "src/introspection.anansi"+#line 339 "src/introspection.anansi" writeObject :: Text -> Object -> XmlWriter () writeObject path (Object fullPath interfaces children') = writeElement "node" [("name", path)] $ do mapM_ writeInterface interfaces mapM_ (writeChild fullPath) children' -#line 348 "src/introspection.anansi"+#line 347 "src/introspection.anansi" writeInterface :: Interface -> XmlWriter () writeInterface (Interface name methods signals properties) = writeElement "interface" [("name", T.strInterfaceName name)] $ do@@ -268,20 +267,20 @@ mapM_ writeSignal signals mapM_ writeProperty properties -#line 357 "src/introspection.anansi"+#line 356 "src/introspection.anansi" writeMethod :: Method -> XmlWriter () writeMethod (Method name inParams outParams) = writeElement "method" [("name", T.strMemberName name)] $ do mapM_ (writeParameter "in") inParams mapM_ (writeParameter "out") outParams -#line 365 "src/introspection.anansi"+#line 364 "src/introspection.anansi" writeSignal :: Signal -> XmlWriter () writeSignal (Signal name params) = writeElement "signal" [("name", T.strMemberName name)] $ do mapM_ (writeParameter "out") params -#line 372 "src/introspection.anansi"+#line 371 "src/introspection.anansi" writeParameter :: Text -> Parameter -> XmlWriter () writeParameter direction (Parameter name sig) = writeEmptyElement "arg" [ ("name", name)@@ -289,7 +288,7 @@ , ("direction", direction) ] -#line 381 "src/introspection.anansi"+#line 380 "src/introspection.anansi" writeProperty :: Property -> XmlWriter () writeProperty (Property name sig access) = writeEmptyElement "property" [ ("name", name)@@ -297,13 +296,13 @@ , ("access", strAccess access) ] -#line 390 "src/introspection.anansi"+#line 389 "src/introspection.anansi" strAccess :: [PropertyAccess] -> Text strAccess access = TL.append readS writeS where readS = if elem Read access then "read" else "" writeS = if elem Write access then "write" else "" -#line 397 "src/introspection.anansi"+#line 396 "src/introspection.anansi" writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do tell "<"@@ -315,7 +314,7 @@ tell name tell ">" -#line 410 "src/introspection.anansi"+#line 409 "src/introspection.anansi" writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter () writeEmptyElement name attrs = do tell "<"@@ -323,7 +322,7 @@ mapM_ writeAttribute attrs tell "/>" -#line 419 "src/introspection.anansi"+#line 418 "src/introspection.anansi" writeAttribute :: (Text, Text) -> XmlWriter () writeAttribute (name, content) = do tell " "@@ -332,7 +331,7 @@ tell (escape content) tell "'" -#line 429 "src/introspection.anansi"+#line 428 "src/introspection.anansi" escape :: Text -> Text escape = TL.concatMap escapeChar where escapeChar c = case c of
hs/Tests.hs view
@@ -174,7 +174,7 @@ ] ] -#line 508 "src/introspection.anansi"+#line 507 "src/introspection.anansi" , F.testGroup "Introspection" [ testProperty "Generate -> Parse" $ \x@(I.Object path _ _) -> let@@ -462,7 +462,7 @@ let Just [addr] = mkAddresses $ TL.pack addrStr return addr -#line 443 "src/introspection.anansi"+#line 442 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do
src/introspection.anansi view
@@ -106,30 +106,29 @@ import qualified Text.XML.LibXML.SAX as SAX import Control.Monad.ST (runST) import qualified Data.STRef as ST-import Data.Text.Encoding (encodeUtf8) : :f DBus/Introspection.hs parseElement :: Text -> Maybe X.Element parseElement text = runST $ do stackRef <- ST.newSTRef [([], [])]- let callbacks = SAX.ParserCallbacks- { SAX.parsedBeginElement = \_ attrs -> do- ST.modifySTRef stackRef ((attrs, []):)- , SAX.parsedEndElement = \name -> do- stack <- ST.readSTRef stackRef- let (attrs, children'):stack' = stack- let e = X.Element name attrs (map X.NodeElement (reverse children'))- let (pAttrs, pChildren):stack'' = stack'- let parent = (pAttrs, e:pChildren)- ST.writeSTRef stackRef (parent:stack'')- , SAX.parsedCharacters = \_ -> return ()- , SAX.parsedComment = \_ -> return ()- , SAX.parsedProcessingInstruction = \_ -> return ()- } let onError _ = ST.writeSTRef stackRef []- p <- SAX.newParser callbacks onError Nothing- mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text+ 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+ + p <- SAX.newParserST onError Nothing+ SAX.setCallback p SAX.parsedBeginElement onBegin+ SAX.setCallback p SAX.parsedEndElement onEnd+ SAX.parseLazyText p text SAX.parseComplete p stack <- ST.readSTRef stackRef return $ case stack of