dbus-th 0.1.2.0 → 0.1.3.0

raw patch · 4 files changed

+199/−199 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DBus/TH.hs +0/−196
• DBus/TH/EDSL.hs +196/−0
• Test.hs +1/−1
• dbus-th.cabal +2/−2

@@ -1,196 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, DeriveDataTypeable #-}--module DBus.TH-  (module Data.Int,-   module Data.Word,-   Client, BusName,-   ObjectPath, InterfaceName,-   MemberName, Variant,-   connectSession, connectSystem,-   Signature (..),-   signatureResult,-   Function (..),-   (=::), as,-   function, interface,-   function', 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 hiding (Type, Signature)-import DBus.Client 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---- | 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       -- ^ Object name-          -> String       -- ^ Interface name-          -> Maybe String -- ^ Prefix-          -> [Function]   -- ^ List of functions-          -> Q [Dec]-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-        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 =-      case mbObjectName of-        Just _ -> [t| Client -> $(return t) |]-        Nothing -> [t| Client -> String -> $(return t) |]--    transformType :: Signature -> Type-    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 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 -> Name -> Signature -> [Name] -> Q Exp-    generateBody name objectName sig names = do-        [| do-           let baseMethod = methodCall (objectPath_ $(case mbObjectName of-                                                        Just oname -> litE (StringL oname)-                                                        Nothing -> varE objectName-                                                      ))-                                       (interfaceName_ ifaceName)-                                       (memberName_ name)-               method = baseMethod {-                          methodCallDestination = Just (busName_ busName),-                          methodCallBody = $(variant names)-                        }-                      -           res <- call_ $(varE $ mkName "bus") method-           $(if signatureResult sig /= ''() -             then [| return $ fromVariant (methodReturnBody res !! 0) |]-             else [| return () |]-            )-          |]--    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,196 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, DeriveDataTypeable #-}++module DBus.TH.EDSL+  (module Data.Int,+   module Data.Word,+   Client, BusName,+   ObjectPath, InterfaceName,+   MemberName, Variant,+   connectSession, connectSystem,+   Signature (..),+   signatureResult,+   Function (..),+   (=::), as,+   function, interface,+   function', 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 hiding (Type, Signature)+import DBus.Client 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++-- | 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       -- ^ Object name+          -> String       -- ^ Interface name+          -> Maybe String -- ^ Prefix+          -> [Function]   -- ^ List of functions+          -> Q [Dec]+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+        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 =+      case mbObjectName of+        Just _ -> [t| Client -> $(return t) |]+        Nothing -> [t| Client -> String -> $(return t) |]++    transformType :: Signature -> Type+    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 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 -> Name -> Signature -> [Name] -> Q Exp+    generateBody name objectName sig names = do+        [| do+           let baseMethod = methodCall (objectPath_ $(case mbObjectName of+                                                        Just oname -> litE (StringL oname)+                                                        Nothing -> varE objectName+                                                      ))+                                       (interfaceName_ ifaceName)+                                       (memberName_ name)+               method = baseMethod {+                          methodCallDestination = Just (busName_ busName),+                          methodCallBody = $(variant names)+                        }+                      +           res <- call_ $(varE $ mkName "bus") method+           $(if signatureResult sig /= ''() +             then [| return $ fromVariant (methodReturnBody res !! 0) |]+             else [| return () |]+            )+          |]++    variant :: [Name] -> Q Exp+    variant names = do+      exs <- mapM variant1 names+      return $ ListE exs++    variant1 :: Name -> Q Exp+    variant1 name = [| toVariant $(varE name) |]+

@@ -2,7 +2,7 @@  import Control.Monad import qualified Data.Map as M-import DBus.TH+import DBus.TH.EDSL import System.Environment  type Ints = [Int32]

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                dbus-th-version:             0.1.2.0+version:             0.1.3.0 synopsis:            TemplateHaskell generator of DBus bindings description:         This package provides functions to easily generate bindings for                      DBus functions. See Test.hs for examples.@@ -17,7 +17,7 @@ extra-source-files:  Test.hs  library-  exposed-modules:     DBus.TH+  exposed-modules:     DBus.TH.EDSL   -- other-modules:          build-depends:       base > 4 && < 5, containers >= 0.4,                        syb >= 0.3.6,