dbus-th (empty) → 0.1.0.0

raw patch · 5 files changed

+231/−0 lines, 5 filesdep +basedep +containersdep +dbus-coresetup-changed

Dependencies added: base, containers, dbus-core, syb, template-haskell, text

Files

• DBus/TH.hs +131/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• Test.hs +38/−0
• dbus-th.cabal +30/−0

@@ -0,0 +1,131 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, DeriveDataTypeable #-}++module DBus.TH+  (module Data.Int,+   module Data.Word,+   Proxy,+   Client, BusName,+   ObjectPath, InterfaceName,+   MemberName, Variant,+   connectSession, connectSystem,+   proxy,+   Signature (..),+   Function (..),+   (=::), as,+   interface+  ) where++import Control.Monad+import Data.Int+import Data.Word+import Language.Haskell.TH+import qualified Data.Text as Text+import Data.Char+import Data.List+import Data.Generics+import DBus.Client.Simple hiding (Type, Signature)++-- | Function signature+data Signature = Return Name+               | Name :-> Signature+  deriving (Eq, Show, Data, Typeable)++infixr 6 :->++-- | Function with DBus name and Haskell name+data Function = Function {+    fnName      :: String    -- ^ Function name to use in Haskell+  , fnDBusName  :: String    -- ^ Function name to use in DBus+  , fnSignature :: Signature -- ^ Function signature+    }+  deriving (Eq, Show, Data, Typeable)++-- | Create a Function from it's name and Signature.+-- Sets fnDBusName == fnName.+(=::) :: String -> Signature -> Function+name =:: sig = Function name name sig++infixr 5 =::++-- | Set specific Haskell name for Function.+as :: Function -> String -> Function+fn `as` name = fn {fnName = name}++infixl 4 `as`++nArgs :: Signature -> Int+nArgs (Return _) = 0+nArgs (_ :-> s)  = 1 + nArgs s++firstLower :: String -> String+firstLower [] = []+firstLower (x:xs) = toLower x: xs++-- | 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       -- ^ Interface name+          -> Maybe String -- ^ Prefix+          -> [Function]   -- ^ List of functions+          -> Q [Dec]+interface 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]++    addPrefix :: String -> String+    addPrefix s =+      case mbPrefix of+        Nothing     -> s+        Just prefix -> prefix ++ s++    strip :: String -> String+    strip s =+      case mbPrefix of+        Nothing     -> s+        Just prefix -> if prefix `isPrefixOf` s+                         then drop (length prefix) s+                         else s++    generateSignature :: String -> Signature -> Q Dec+    generateSignature name sig = do+        dbt <- dbusType (transformType sig)+        return $ SigD (mkName $ firstLower name) dbt++    dbusType :: Type -> Q Type+    dbusType t = [t| Proxy -> $(return t) |]++    transformType :: Signature -> Type+    transformType (Return t) = 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"+        args <- replicateM (nArgs sig) (newName "x")+        body <- generateBody dbusName sig args+        return $ FunD (mkName $ firstLower name) [Clause (VarP bus: map VarP args) (NormalB body) []]++    generateBody :: String -> Signature -> [Name] -> Q Exp+    generateBody name sig names = do+        [| do+           res <- call $(varE $ mkName "bus")+                       (interfaceName_ $ Text.pack ifaceName)+                       (memberName_ $ Text.pack name)+                       $(variant names) +           return $ fromVariant (res !! 0)+          |]++    variant :: [Name] -> Q Exp+    variant names = do+      exs <- mapM variant1 names+      return $ ListE exs++    variant1 :: Name -> Q Exp+    variant1 name = [| toVariant $(varE name) |]+

@@ -0,0 +1,30 @@+Copyright (c) 2012, IlyaPortnov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of IlyaPortnov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, OverloadedStrings #-}++import Control.Monad+import qualified Data.Map as M+import DBus.TH+import System.Environment++type Ints = [Int32]++type Buddies = M.Map String Int32++interface "im.pidgin.purple.PurpleInterface" (Just "Purple")+    [ "Strreplace" =:: ''String :-> ''String :-> ''String :-> Return ''String `as` "replace"+    , "AccountsFind" =:: ''String :-> ''String :-> Return ''Int32+    , "AccountsGetAllActive" =:: Return ''Ints+    , "FindBuddy" =:: ''Int32 :-> ''String :-> Return ''Int32+    , "BuddyGetGroup" =:: ''Int32 :-> Return ''Int32+    , "GroupGetName"  =:: ''Int32 :-> Return ''String+    , "BlistGetBuddies" =:: Return ''Ints+    , "BuddyGetAlias" =:: ''Int32 :-> Return ''String ]++main = do+  [account, buddy] <- getArgs+  dbus <- connectSession+  purple <- proxy dbus "im.pidgin.purple.PurpleService" "/im/pidgin/purple/PurpleObject"+  Just res <- replace purple "ab12cc 12 ee" "12" "ZZ"+  putStrLn res+  Just acc <- accountsFind purple account "prpl-jabber"+  Just buddiesL <- blistGetBuddies purple+  buddies <- forM buddiesL $ \buddy -> do+                    Just name <- buddyGetAlias purple 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+

@@ -0,0 +1,30 @@+-- Initial dbus-th.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                dbus-th+version:             0.1.0.0+synopsis:            TemplateHaskell generator of DBus bindings+description:         This package provides functions to easily generate bindings for+                     DBus functions. See Test.hs for examples.+license:             BSD3+license-file:        LICENSE+author:              IlyaPortnov+maintainer:          portnov84@rambler.ru+-- copyright:           +category:            Network+build-type:          Simple+cabal-version:       >=1.8+extra-source-files:  Test.hs++library+  exposed-modules:     DBus.TH+  -- other-modules:       +  build-depends:       base > 4 && < 5, containers ==0.4.*,+                       syb >= 0.3.6,+                       dbus-core ==0.9.*,+                       template-haskell >=2.6, text ==0.11.*++Source-repository head+  type:     git+  location: git://home.iportnov.ru/dbus-th.git+