diff --git a/DBus/TH.hs b/DBus/TH.hs --- a/DBus/TH.hs +++ b/DBus/TH.hs @@ -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 diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/dbus-th.cabal b/dbus-th.cabal --- a/dbus-th.cabal +++ b/dbus-th.cabal @@ -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