diff --git a/DBus/TH.hs b/DBus/TH.hs deleted file mode 100644 --- a/DBus/TH.hs +++ /dev/null @@ -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) |] - diff --git a/DBus/TH/EDSL.hs b/DBus/TH/EDSL.hs new file mode 100644 --- /dev/null +++ b/DBus/TH/EDSL.hs @@ -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) |] + diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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] 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.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,