{-# 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)
data Signature = Return Name
| Name :-> Signature
deriving (Eq, Show, Data, Typeable)
infixr 6 :->
data Function = Function {
fnName :: String
, fnDBusName :: String
, fnSignature :: Signature
}
deriving (Eq, Show, Data, Typeable)
(=::) :: String -> Signature -> Function
name =:: sig = Function name name sig
infixr 5 =::
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
signatureResult :: Signature -> Name
signatureResult (Return name) = name
signatureResult (_ :-> sig) = signatureResult sig
interface :: String
-> String
-> String
-> Maybe String
-> [Function]
-> Q [Dec]
interface busName objectName ifaceName mbPrefix fns =
interface' busName (Just objectName) ifaceName mbPrefix fns
interface' :: String
-> Maybe String
-> String
-> Maybe String
-> [Function]
-> Q [Dec]
interface' busName mbObjectName ifaceName mbPrefix fns =
concat `fmap` mapM (function' busName mbObjectName ifaceName mbPrefix) fns
function :: String
-> String
-> String
-> Maybe String
-> Function
-> Q [Dec]
function busName objectName ifaceName mbPrefix fn =
function' busName (Just objectName) ifaceName mbPrefix fn
function' :: String
-> Maybe String
-> String
-> Maybe String
-> 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) |]