module DBus.Scaffold where
import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Monoid
import Data.Singletons
import Data.Singletons.Prelude.List
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import DBus.Introspect
import DBus.Message
import DBus.Representable
import DBus.Types
import DBus.Property
liftObjectPath :: ObjectPath -> ExpQ
liftObjectPath op = [| objectPath $( liftText $ objectPathToText op) |]
liftArgDesc :: ArgumentDescription n -> ExpQ
liftArgDesc Done = [|Done|]
liftArgDesc (r :> rs) = [|$(liftText r) :> $(liftArgDesc rs)|]
toSomeMethodDescription :: Text
-> IInterface
-> IMethod
-> SomeMethodDescription
toSomeMethodDescription path iface imethod =
let iInArgs = filter ((/= Just Out) . iArgumentDirection)
(iMethodArguments imethod)
iOutArgs = filter ((== Just Out) . iArgumentDirection)
(iMethodArguments imethod)
inArgs = toSings iInArgs
outArgs = toSings iOutArgs
in case (inArgs, outArgs) of
( SSAD (is :: Sing args) inDescs
,SSAD (os :: Sing rets) outDescs)
-> withSingI is $ withSingI os $
SMD (MD { methodObjectPath = objectPath path
, methodInterface = iInterfaceName iface
, methodMember = iMethodName imethod
, methodArgs = inDescs
, methodResult = outDescs
} :: MethodDescription args rets)
interfacMethodDescriptions :: Text -> IInterface -> [SomeMethodDescription]
interfacMethodDescriptions path iface =
for (iInterfaceMethods iface) $ toSomeMethodDescription path iface
where for = flip map
mapIInterfaces :: (Text -> IInterface -> [a]) -> Text -> INode -> [a]
mapIInterfaces f path node =
let ifaceMembers = f path =<< nodeInterfaces node
subNodeMembers = nodeSubnodes node >>= \n ->
let subPath = path <> "/" <> nodeName n
in mapIInterfaces f subPath n
in ifaceMembers ++ subNodeMembers
nodeMethodDescriptions :: Text -> INode -> [SomeMethodDescription]
nodeMethodDescriptions = mapIInterfaces interfacMethodDescriptions
interfacPropertyDescriptions :: Text -> IInterface -> [PropertyDescription]
interfacPropertyDescriptions path iface =
for (iInterfaceProperties iface) $ \p ->
PD { pdObjectPath = path
, pdInterface = iInterfaceName iface
, pdName = iPropertyName p
, pdType = iPropertyType p
}
where for = flip map
data PropertyDescription = PD { pdObjectPath :: Text
, pdInterface :: Text
, pdName :: Text
, pdType :: DBusType
}
nodePropertyDescriptions :: Text -> INode -> [PropertyDescription]
nodePropertyDescriptions = mapIInterfaces interfacPropertyDescriptions
liftText t = [|Text.pack $(liftString (Text.unpack t))|]
promotedListT :: [TypeQ] -> TypeQ
promotedListT = foldr (\t ts -> appT (appT promotedConsT t) ts) promotedNilT
arrows :: [TypeQ] -> TypeQ -> TypeQ
arrows = flip $ foldr (\t ts -> appT (appT arrowT t) ts)
tupleType :: [TypeQ] -> TypeQ
tupleType xs = foldl (\ts t -> appT ts t) (tupleT (length xs)) xs
promoteSimpleType t = promotedT (mkName (show t))
promoteDBusType :: DBusType -> TypeQ
promoteDBusType (DBusSimpleType t) = [t|'DBusSimpleType $(promoteSimpleType t)|]
promoteDBusType (TypeArray t) = [t| TypeArray $(promoteDBusType t)|]
promoteDBusType (TypeStruct ts) =
let ts' = promotedListT $ promoteDBusType <$> ts
in [t| TypeStruct $ts'|]
promoteDBusType (TypeDict k v) =
[t| TypeDict $(promoteSimpleType k)
$(promoteDBusType v) |]
promoteDBusType (TypeDictEntry k v) =
[t| TypeDictEntry $(promoteSimpleType k)
$(promoteDBusType v) |]
promoteDBusType TypeVariant = [t| TypeVariant |]
promoteDBusType TypeUnit = [t| TypeUnit |]
readIntrospectXml :: FilePath -> Q INode
readIntrospectXml interfaceFile = do
qAddDependentFile interfaceFile
xml <- qRunIO $ BS.readFile interfaceFile
case xmlToNode xml of
Left e -> error $ "Could not parse introspection XML: " ++ show e
Right r -> return r
liftMethodDescription :: String
-> SomeMethodDescription
-> Q [Dec]
liftMethodDescription name smd = case smd of
(SMD (md :: MethodDescription args rets)) -> do
let ats = promotedListT . map promoteDBusType $
fromSing (sing :: Sing args)
rts = promotedListT . map promoteDBusType $
fromSing (sing :: Sing rets)
md' = [|MD{ methodObjectPath = $(liftObjectPath $ methodObjectPath md)
, methodInterface = $(liftText $ methodInterface md)
, methodMember = $(liftText $ methodMember md)
, methodArgs = $(liftArgDesc $ methodArgs md)
, methodResult = $(liftArgDesc $ methodResult md)
} |]
tp <- sigD (mkName name) [t|MethodDescription $(ats) $(rts)|]
cl <- valD (varP (mkName name)) (normalB md') []
return [tp, cl]
propertyFromDescription :: (PropertyDescription -> String)
-> Maybe Text
-> PropertyDescription
-> Q [Dec]
propertyFromDescription nameGen mbEntity pd = do
entName <- newName "entity"
let rp ent = [|RP{ rpEntity = $ent
, rpObject = objectPath $(liftText $ pdObjectPath pd)
, rpInterface = $(liftText $ pdInterface pd)
, rpName = $(liftText $ pdName pd)
} |]
name = mkName $ nameGen pd
entN = (mkName "entity")
typeName = mkName "t"
arg = case mbEntity of
Nothing -> [[t|Text|]]
Just _ -> []
t = promoteDBusType $ pdType pd
tp <- sigD name $ (arrows arg [t|RemoteProperty $(t)|])
cl <- case mbEntity of
Nothing -> funD name [clause [varP entN]
(normalB (rp (varE entN))) []]
Just e -> valD (varP name) (normalB . rp $ liftText e) []
return [tp, cl]
nodeSignals :: Text -> INode -> [SomeSignalDescription]
nodeSignals = mapIInterfaces interfaceSignalDs
interfaceSignalDs :: Text -> IInterface -> [SomeSignalDescription]
interfaceSignalDs ndName iface = signalDs (objectPath ndName)
(iInterfaceName iface)
<$> iInterfaceSignals iface
signalDs :: ObjectPath -> Text -> ISignal -> SomeSignalDescription
signalDs nPath iName iSig =
case toSings $ iSignalArguments iSig of
SSAD (s :: Sing ts) descs -> withSingI s $ (SSD
(SignalDescription { signalDPath = nPath
, signalDInterface = iName
, signalDMember = iSignalName iSig
, signalDArguments = descs
} :: SignalDescription (ts :: [DBusType])
))
data SomeArgumentDescription where
SSAD :: Sing (ts :: [DBusType])
-> ArgumentDescription (ArgParity ts)
-> SomeArgumentDescription
toSings :: [IArgument] -> SomeArgumentDescription
toSings [] = SSAD SNil Done
toSings (iarg : iargs) =
let t = iArgumentType iarg
desc = iArgumentName iarg
in case (toSing t, toSings iargs) of
(SomeSing s, SSAD ss descs)
-> SSAD (SCons s ss) (desc :> descs)
liftSignalDescription :: String -> SomeSignalDescription -> Q [Dec]
liftSignalDescription nameString ssigDesc@(SSD (sigDesc :: SignalDescription a))
= do
let name = mkName nameString
ts = fromSing (sing :: (Sing a))
t = [t| SignalDescription $(promotedListT $ promoteDBusType <$> ts)|]
e = [| SignalDescription
{ signalDPath = $(liftObjectPath $ signalDPath sigDesc)
, signalDInterface = $(liftText $ signalDInterface sigDesc)
, signalDMember = $(liftText $ signalDMember sigDesc)
, signalDArguments = $(liftArgDesc
$ signalDArguments sigDesc)
} |]
tpDecl <- sigD name t
decl <- valD (varP name) (normalB e) []
return [tpDecl, decl]
where