dbus-th 0.1.1.1 → 0.1.2.0

raw patch · 3 files changed

+89/−29 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DBus/TH.hs +77/−18
• Test.hs +10/−9
• dbus-th.cabal +2/−2

@@ -8,9 +8,11 @@    MemberName, Variant,    connectSession, connectSystem,    Signature (..),+   signatureResult,    Function (..),    (=::), as,-   interface+   function, interface,+   function', interface'   ) where  import Control.Monad@@ -60,25 +62,66 @@ firstLower [] = [] firstLower (x:xs) = toLower x: xs +-- | Return type name for signature+signatureResult :: Signature -> Name+signatureResult (Return name) = name+signatureResult (_ :-> sig) = signatureResult sig+ -- | Generate bindings for methods in specific DBus interface. -- If second argument is (Just prefix), then prefix will be -- added to the beginning of all DBus names and removed from all -- Haskell names. interface :: String       -- ^ Bus name-          -> String       -- ^ Interface name           -> String       -- ^ Object name+          -> String       -- ^ Interface name           -> Maybe String -- ^ Prefix           -> [Function]   -- ^ List of functions           -> Q [Dec]-interface busName objectName ifaceName mbPrefix fns = concat `fmap` mapM iface fns-  where-    iface :: Function -> Q [Dec]-    iface (Function name dbusName sig) =-        let name'     = strip name-            dbusName' = addPrefix dbusName-        in sequence [generateSignature name' sig,-                     generateImplementation name' dbusName' sig]+interface busName objectName ifaceName mbPrefix fns =+    interface' busName (Just objectName) ifaceName mbPrefix fns +-- | Generate bindings for methods in specific DBus interface.+-- If second argument is (Just prefix), then prefix will be+-- added to the beginning of all DBus names and removed from all+-- Haskell names.+interface' :: String      -- ^ Bus name+          -> Maybe String -- ^ Just name - use fixed object name; Nothing - object name will be 2nd argument of generated functions+          -> String       -- ^ Interface name+          -> Maybe String -- ^ Prefix+          -> [Function]   -- ^ List of functions+          -> Q [Dec]+interface' busName mbObjectName ifaceName mbPrefix fns =+    concat `fmap` mapM (function' busName mbObjectName ifaceName mbPrefix) fns++-- | Generate binding for one method in specific DBus interface.+-- If second argument is (Just prefix), then prefix will be+-- added to the beginning of all DBus names and removed from all+-- Haskell names.+function :: String       -- ^ Bus name+          -> String       -- ^ Object name+          -> String       -- ^ Interface name+          -> Maybe String -- ^ Prefix+          -> Function   -- ^ Function+          -> Q [Dec]+function busName objectName ifaceName mbPrefix fn =+    function' busName (Just objectName) ifaceName mbPrefix fn++-- | Generate binding for one method in specific DBus interface.+-- If second argument is (Just prefix), then prefix will be+-- added to the beginning of all DBus names and removed from all+-- Haskell names.+function' :: String       -- ^ Bus name+          -> Maybe String -- ^ Just name - use fixed object name; Nothing - object name will be 2nd argument of generated function+          -> String       -- ^ Interface name+          -> Maybe String -- ^ Prefix+          -> Function     -- ^ Function+          -> Q [Dec]+function' busName mbObjectName ifaceName mbPrefix (Function name dbusName sig) =+    let name'     = strip name+        dbusName' = addPrefix dbusName+    in sequence [generateSignature name' sig,+                 generateImplementation name' dbusName' sig]+  where     addPrefix :: String -> String     addPrefix s =       case mbPrefix of@@ -99,23 +142,36 @@         return $ SigD (mkName $ firstLower name) dbt      dbusType :: Type -> Q Type-    dbusType t = [t| Client -> $(return t) |]+    dbusType t =+      case mbObjectName of+        Just _ -> [t| Client -> $(return t) |]+        Nothing -> [t| Client -> String -> $(return t) |]      transformType :: Signature -> Type-    transformType (Return t) = AppT (ConT ''IO) (AppT (ConT ''Maybe) (ConT t))+    transformType (Return t) =+      if t == ''()+        then AppT (ConT ''IO) (ConT ''())+        else AppT (ConT ''IO) (AppT (ConT ''Maybe) (ConT t))     transformType (t :-> s)  = AppT (AppT ArrowT (ConT t)) (transformType s)      generateImplementation :: String -> String -> Signature -> Q Dec     generateImplementation name dbusName sig = do         let bus  = mkName "bus"+        objectName <- newName "object"         args <- replicateM (nArgs sig) (newName "x")-        body <- generateBody dbusName sig args-        return $ FunD (mkName $ firstLower name) [Clause (VarP bus: map VarP args) (NormalB body) []]+        body <- generateBody dbusName objectName sig args+        let varArgs = case mbObjectName of+                        Just _ -> VarP bus : map VarP args+                        Nothing -> VarP bus : VarP objectName : map VarP args+        return $ FunD (mkName $ firstLower name) [Clause varArgs (NormalB body) []] -    generateBody :: String -> Signature -> [Name] -> Q Exp-    generateBody name sig names = do+    generateBody :: String -> Name -> Signature -> [Name] -> Q Exp+    generateBody name objectName sig names = do         [| do-           let baseMethod = methodCall (objectPath_ objectName)+           let baseMethod = methodCall (objectPath_ $(case mbObjectName of+                                                        Just oname -> litE (StringL oname)+                                                        Nothing -> varE objectName+                                                      ))                                        (interfaceName_ ifaceName)                                        (memberName_ name)                method = baseMethod {@@ -124,7 +180,10 @@                         }                                   res <- call_ $(varE $ mkName "bus") method-           return $ fromVariant (methodReturnBody res !! 0)+           $(if signatureResult sig /= ''() +             then [| return $ fromVariant (methodReturnBody res !! 0) |]+             else [| return () |]+            )           |]      variant :: [Name] -> Q Exp

@@ -9,7 +9,7 @@  type Buddies = M.Map String Int32 -interface "im.pidgin.purple.PurpleInterface" (Just "Purple")+interface' "im.pidgin.purple.PurpleService" Nothing "im.pidgin.purple.PurpleInterface" (Just "Purple")     [ "Strreplace" =:: ''String :-> ''String :-> ''String :-> Return ''String `as` "replace"     , "AccountsFind" =:: ''String :-> ''String :-> Return ''Int32     , "AccountsGetAllActive" =:: Return ''Ints@@ -21,18 +21,19 @@  main = do   [account, buddy] <- getArgs+  let obj = "/im/pidgin/purple/PurpleObject"    dbus <- connectSession-  purple <- proxy dbus "im.pidgin.purple.PurpleService" "/im/pidgin/purple/PurpleObject"-  Just res <- replace purple "ab12cc 12 ee" "12" "ZZ"+  Just res <- replace dbus obj "ab12cc 12 ee" "12" "ZZ"   putStrLn res-  Just acc <- accountsFind purple account "prpl-jabber"-  Just buddiesL <- blistGetBuddies purple+  Just acc <- accountsFind dbus obj account "prpl-jabber"+  print acc+  Just buddiesL <- blistGetBuddies dbus obj   buddies <- forM buddiesL $ \buddy -> do-                    Just name <- buddyGetAlias purple buddy+                    Just name <- buddyGetAlias dbus obj buddy                     return (name, buddy)   let buddiesMap = M.fromList buddies   let Just juick = M.lookup buddy buddiesMap-  Just grp <- buddyGetGroup purple juick-  Just grpName <- groupGetName purple grp-  putStrLn $ buddy ++ "'s group: " ++ show grpName+  Just grp <- buddyGetGroup dbus obj juick+  Just grpName <- groupGetName dbus obj grp+  putStrLn $ buddy ++ "'s group: " ++ grpName 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                dbus-th-version:             0.1.1.1+version:             0.1.2.0 synopsis:            TemplateHaskell generator of DBus bindings description:         This package provides functions to easily generate bindings for                      DBus functions. See Test.hs for examples.@@ -26,5 +26,5 @@  Source-repository head   type:     git-  location: git://home.iportnov.ru/dbus-th.git+  location: https://github.com/portnov/dbus-th.git