{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module DBus.Generation where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import DBus.Client as C
import qualified DBus.Internal.Message as M
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection.Parse as I
import qualified DBus.Introspection.Types as I
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import Data.Coerce
import Data.Int
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.String
import qualified Data.Text.IO as Text
import Data.Traversable
import Data.Word
import Language.Haskell.TH
import Prelude hiding (mapM)
import System.Posix.Types (Fd(..))
mkTupE :: [Exp] -> Exp
mkTupE :: [Exp] -> Exp
mkTupE = [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
type ClientBusPathR a = ReaderT (Client, T.BusName, T.ObjectPath) IO a
dbusInvoke :: (Client -> T.BusName -> T.ObjectPath -> a) -> ClientBusPathR a
dbusInvoke :: forall a.
(Client -> BusName -> ObjectPath -> a) -> ClientBusPathR a
dbusInvoke Client -> BusName -> ObjectPath -> a
fn = (\(Client
c, BusName
b, ObjectPath
p) -> Client -> BusName -> ObjectPath -> a
fn Client
c BusName
b ObjectPath
p) ((Client, BusName, ObjectPath) -> a)
-> ReaderT
(Client, BusName, ObjectPath) IO (Client, BusName, ObjectPath)
-> ReaderT (Client, BusName, ObjectPath) IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
(Client, BusName, ObjectPath) IO (Client, BusName, ObjectPath)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
infixl 4 ??
(??) :: Functor f => f (a -> b) -> a -> f b
f (a -> b)
fab ?? :: forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? a
a = ((a -> b) -> b) -> f (a -> b) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) f (a -> b)
fab
{-# INLINE (??) #-}
infixl 4 ?/?
(?/?) :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b
ClientBusPathR (a -> IO b)
soFar ?/? :: forall a b. ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b
?/? a
arg = do
returnValue <- ((a -> IO b) -> IO b)
-> ClientBusPathR (a -> IO b)
-> ReaderT (Client, BusName, ObjectPath) IO (IO b)
forall a b.
(a -> b)
-> ReaderT (Client, BusName, ObjectPath) IO a
-> ReaderT (Client, BusName, ObjectPath) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> IO b) -> a -> IO b
forall a b. (a -> b) -> a -> b
$ a
arg) ClientBusPathR (a -> IO b)
soFar
lift returnValue
data GenerationParams = GenerationParams
{ GenerationParams -> Maybe BusName
genBusName :: Maybe T.BusName
, GenerationParams -> Maybe ObjectPath
genObjectPath :: Maybe T.ObjectPath
, GenerationParams -> InterfaceName
genInterfaceName :: T.InterfaceName
, GenerationParams -> Bool
genTakeSignalErrorHandler :: Bool
, GenerationParams -> Type -> Type
getTHType :: T.Type -> Type
}
defaultGetDictType :: Type -> Type -> Type
defaultGetDictType :: Type -> Type -> Type
defaultGetDictType Type
k =
Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Map.Map) Type
k)
defaultGetTHType :: T.Type -> Type
defaultGetTHType :: Type -> Type
defaultGetTHType = (Type -> Type) -> (Type -> Type -> Type) -> Type -> Type
buildGetTHType (Type -> Type -> Type
AppT Type
ListT) Type -> Type -> Type
defaultGetDictType
buildGetTHType ::
(Type -> Type) -> (Type -> Type -> Type) -> T.Type -> Type
buildGetTHType :: (Type -> Type) -> (Type -> Type -> Type) -> Type -> Type
buildGetTHType Type -> Type
arrayTypeBuilder Type -> Type -> Type
dictTypeBuilder = Type -> Type
fn
where fn :: Type -> Type
fn Type
t =
case Type
t of
T.TypeArray Type
T.TypeWord8 -> Name -> Type
ConT ''BS.ByteString
Type
T.TypeBoolean -> Name -> Type
ConT ''Bool
Type
T.TypeWord8 -> Name -> Type
ConT ''Word8
Type
T.TypeWord16 -> Name -> Type
ConT ''Word16
Type
T.TypeWord32 -> Name -> Type
ConT ''Word32
Type
T.TypeWord64 -> Name -> Type
ConT ''Word64
Type
T.TypeInt16 -> Name -> Type
ConT ''Int16
Type
T.TypeInt32 -> Name -> Type
ConT ''Int32
Type
T.TypeInt64 -> Name -> Type
ConT ''Int64
Type
T.TypeDouble -> Name -> Type
ConT ''Double
Type
T.TypeUnixFd -> Name -> Type
ConT ''Fd
Type
T.TypeString -> Name -> Type
ConT ''String
Type
T.TypeSignature -> Name -> Type
ConT ''T.Signature
Type
T.TypeObjectPath -> Name -> Type
ConT ''T.ObjectPath
Type
T.TypeVariant -> Name -> Type
ConT ''T.Variant
T.TypeArray Type
arrayType -> Type -> Type
arrayTypeBuilder (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
fn Type
arrayType
T.TypeDictionary Type
k Type
v -> Type -> Type -> Type
dictTypeBuilder (Type -> Type
fn Type
k) (Type -> Type
fn Type
v)
T.TypeStructure [Type]
ts -> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
fn [Type]
ts
newNameDef :: String -> Q Name
newNameDef :: String -> Q Name
newNameDef String
n =
case String
n of
String
"" -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
String
"data" -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
String
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
n
defaultGenerationParams :: GenerationParams
defaultGenerationParams :: GenerationParams
defaultGenerationParams =
GenerationParams
{ genBusName :: Maybe BusName
genBusName = Maybe BusName
forall a. Maybe a
Nothing
, genInterfaceName :: InterfaceName
genInterfaceName = String -> InterfaceName
forall a. IsString a => String -> a
fromString String
""
, getTHType :: Type -> Type
getTHType = Type -> Type
defaultGetTHType
, genObjectPath :: Maybe ObjectPath
genObjectPath = Maybe ObjectPath
forall a. Maybe a
Nothing
, genTakeSignalErrorHandler :: Bool
genTakeSignalErrorHandler = Bool
False
}
addTypeArg :: Type -> Type -> Type
addTypeArg :: Type -> Type -> Type
addTypeArg Type
argT = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
argT)
addTypeArgIf :: Bool -> Type -> Type -> Type
addTypeArgIf :: Bool -> Type -> Type -> Type
addTypeArgIf Bool
condition Type
theType = if Bool
condition then Type -> Type -> Type
addTypeArg Type
theType else Type -> Type
forall a. a -> a
id
unitIOType :: Type
unitIOType :: Type
unitIOType = Type -> Type -> Type
AppT (Name -> Type
ConT ''IO) (Int -> Type
TupleT Int
0)
addArgIf :: Bool -> a -> [a] -> [a]
addArgIf :: forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
condition a
name = if Bool
condition then (a
namea -> [a] -> [a]
forall a. a -> [a] -> [a]
:) else [a] -> [a]
forall a. a -> a
id
mkFunD :: Name -> [Name] -> Exp -> Dec
mkFunD :: Name -> [Name] -> Exp -> Dec
mkFunD Name
name [Name]
argNames Exp
body =
Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
Clause ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
argNames) (Exp -> Body
NormalB Exp
body) []]
generateClient :: GenerationParams -> I.Interface -> Q [Dec]
generateClient :: GenerationParams -> Interface -> Q [Dec]
generateClient GenerationParams
params
I.Interface{ interfaceName :: Interface -> InterfaceName
I.interfaceName = InterfaceName
name
, interfaceProperties :: Interface -> [Property]
I.interfaceProperties = [Property]
properties
, interfaceMethods :: Interface -> [Method]
I.interfaceMethods = [Method]
methods
} =
let params' :: GenerationParams
params' = GenerationParams
params { genInterfaceName = coerce name } in
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
(Method -> Q [Dec]) -> [Method] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (GenerationParams -> Method -> Q [Dec]
generateClientMethod GenerationParams
params') [Method]
methods
[Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. [a] -> [a] -> [a]
++
(Property -> Q [Dec]) -> [Property] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (GenerationParams -> Property -> Q [Dec]
generateClientProperty GenerationParams
params') [Property]
properties
maybeName :: a -> Bool -> Maybe a
maybeName :: forall a. a -> Bool -> Maybe a
maybeName a
name Bool
condition = if Bool
condition then a -> Maybe a
forall a. a -> Maybe a
Just a
name else Maybe a
forall a. Maybe a
Nothing
makeToVariantApp :: Name -> Exp
makeToVariantApp :: Name -> Exp
makeToVariantApp Name
name = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.toVariant) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
name
makeFromVariantApp :: Name -> Exp
makeFromVariantApp :: Name -> Exp
makeFromVariantApp Name
name = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.fromVariant) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
name
makeJustPattern :: Name -> Pat
makeJustPattern :: Name -> Pat
makeJustPattern Name
name = Name -> [Type] -> [Pat] -> Pat
ConP 'Just [] [Name -> Pat
VarP Name
name]
mapOrHead ::
(Num a, Eq a) => a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead :: forall a t b.
(Num a, Eq a) =>
a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead a
outputLength t -> b
fn [t]
names [b] -> b
cons =
case a
outputLength of
a
1 -> t -> b
fn (t -> b) -> t -> b
forall a b. (a -> b) -> a -> b
$ [t] -> t
forall a. HasCallStack => [a] -> a
head [t]
names
a
_ -> [b] -> b
cons ([b] -> b) -> [b] -> b
forall a b. (a -> b) -> a -> b
$ (t -> b) -> [t] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map t -> b
fn [t]
names
runGetFirst :: [Maybe a] -> Maybe a
runGetFirst :: forall a. [Maybe a] -> Maybe a
runGetFirst [Maybe a]
options = First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> First a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [First a] -> First a
forall a. Monoid a => [a] -> a
mconcat ([First a] -> First a) -> [First a] -> First a
forall a b. (a -> b) -> a -> b
$ (Maybe a -> First a) -> [Maybe a] -> [First a]
forall a b. (a -> b) -> [a] -> [b]
map Maybe a -> First a
forall a. Maybe a -> First a
First [Maybe a]
options
buildGeneratedSignature :: Bool -> Bool -> Type -> Type
buildGeneratedSignature :: Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
takeBusArg Bool
takeObjectPathArg =
Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''C.Client) (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Type -> Type -> Type
addTypeArgIf Bool
takeBusArg (Name -> Type
ConT ''T.BusName) (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Bool -> Type -> Type -> Type
addTypeArgIf Bool
takeObjectPathArg (Name -> Type
ConT ''T.ObjectPath)
getSetMethodCallParams ::
Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ
getSetMethodCallParams :: Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ
getSetMethodCallParams Name
methodCallN Maybe Name
mBusN Maybe Name
mObjectPathN ExpQ
variantsE =
case (Maybe Name
mBusN, Maybe Name
mObjectPathN) of
(Just Name
busN, Just Name
objectPathN) -> [|
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN )
{ M.methodCallDestination = Just $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
busN )
, M.methodCallPath = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
objectPathN )
, M.methodCallBody = $( ExpQ
variantsE )
}
|]
(Just Name
busN, Maybe Name
Nothing) -> [|
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN )
{ M.methodCallDestination = Just $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
busN )
, M.methodCallBody = $( ExpQ
variantsE )
}
|]
(Maybe Name
Nothing, Just Name
objectPathN) -> [|
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN )
{ M.methodCallPath = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
objectPathN )
, M.methodCallBody = $( ExpQ
variantsE )
}
|]
(Maybe Name
Nothing, Maybe Name
Nothing) -> [|
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN ) { M.methodCallBody = $( ExpQ
variantsE ) }
|]
clientArgumentUnpackingMessage :: String
clientArgumentUnpackingMessage :: String
clientArgumentUnpackingMessage =
String
"The client method could not unpack the message that was received."
clientArgumentUnpackingError :: [T.Variant] -> M.MethodError
clientArgumentUnpackingError :: [Variant] -> MethodError
clientArgumentUnpackingError [Variant]
variants =
M.MethodError
{ methodErrorName :: ErrorName
M.methodErrorName = ErrorName
C.errorFailed
, methodErrorSerial :: Serial
M.methodErrorSerial = Word32 -> Serial
T.Serial Word32
0
, methodErrorSender :: Maybe BusName
M.methodErrorSender = Maybe BusName
forall a. Maybe a
Nothing
, methodErrorDestination :: Maybe BusName
M.methodErrorDestination = Maybe BusName
forall a. Maybe a
Nothing
, methodErrorBody :: [Variant]
M.methodErrorBody = String -> Variant
forall a. IsVariant a => a -> Variant
T.toVariant String
clientArgumentUnpackingMessage Variant -> [Variant] -> [Variant]
forall a. a -> [a] -> [a]
: [Variant]
variants
}
generateClientMethod :: GenerationParams -> I.Method -> Q [Dec]
generateClientMethod :: GenerationParams -> Method -> Q [Dec]
generateClientMethod GenerationParams
{ getTHType :: GenerationParams -> Type -> Type
getTHType = Type -> Type
getArgType
, genInterfaceName :: GenerationParams -> InterfaceName
genInterfaceName = InterfaceName
methodInterface
, genObjectPath :: GenerationParams -> Maybe ObjectPath
genObjectPath = Maybe ObjectPath
objectPathM
, genBusName :: GenerationParams -> Maybe BusName
genBusName = Maybe BusName
busNameM
}
I.Method
{ methodArgs :: Method -> [MethodArg]
I.methodArgs = [MethodArg]
args
, methodName :: Method -> MemberName
I.methodName = MemberName
methodNameMN
} =
do
let ([MethodArg]
inputArgs, [MethodArg]
outputArgs) = (MethodArg -> Bool) -> [MethodArg] -> ([MethodArg], [MethodArg])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
I.In) (Direction -> Bool)
-> (MethodArg -> Direction) -> MethodArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodArg -> Direction
I.methodArgDirection) [MethodArg]
args
outputLength :: Int
outputLength = [MethodArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MethodArg]
outputArgs
buildArgNames :: Q [Name]
buildArgNames = (MethodArg -> Q Name) -> [MethodArg] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Q Name
newNameDef (String -> Q Name) -> (MethodArg -> String) -> MethodArg -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodArg -> String
I.methodArgName) [MethodArg]
inputArgs
buildOutputNames :: Q [Name]
buildOutputNames = (MethodArg -> Q Name) -> [MethodArg] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Q Name
newNameDef (String -> Q Name) -> (MethodArg -> String) -> MethodArg -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodArg -> String
I.methodArgName) [MethodArg]
outputArgs
takeBusArg :: Bool
takeBusArg = Maybe BusName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe BusName
busNameM
takeObjectPathArg :: Bool
takeObjectPathArg = Maybe ObjectPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ObjectPath
objectPathM
Char
functionNameFirst:String
functionNameRest = MemberName -> String
forall a b. Coercible a b => a -> b
coerce MemberName
methodNameMN
functionName :: String
functionName = Char -> Char
Char.toLower Char
functionNameFirstChar -> String -> String
forall a. a -> [a] -> [a]
:String
functionNameRest
functionN :: Name
functionN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
Char.toLower Char
functionNameFirstChar -> String -> String
forall a. a -> [a] -> [a]
:String
functionNameRest
methodCallDefN :: Name
methodCallDefN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
functionName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"MethodCall"
defObjectPath :: ObjectPath
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString String
"/") Maybe ObjectPath
objectPathM
clientN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"client"
busN <- newName "busName"
objectPathN <- newName "objectPath"
methodCallN <- newName "methodCall"
callResultN <- newName "callResult"
replySuccessN <- newName "replySuccess"
methodArgNames <- buildArgNames
fromVariantOutputNames <- buildOutputNames
finalOutputNames <- buildOutputNames
let variantListExp = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
makeToVariantApp [Name]
methodArgNames
mapOrHead' = Int -> (t -> b) -> [t] -> ([b] -> b) -> b
forall a t b.
(Num a, Eq a) =>
a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead Int
outputLength
fromVariantExp = (Name -> Exp) -> [Name] -> ([Exp] -> Exp) -> Exp
forall {t} {b}. (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead' Name -> Exp
makeFromVariantApp [Name]
fromVariantOutputNames [Exp] -> Exp
mkTupE
finalResultTuple = (Name -> Exp) -> [Name] -> ([Exp] -> Exp) -> Exp
forall {t} {b}. (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead' Name -> Exp
VarE [Name]
finalOutputNames [Exp] -> Exp
mkTupE
maybeExtractionPattern = (Name -> Pat) -> [Name] -> ([Pat] -> Pat) -> Pat
forall {t} {b}. (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead' Name -> Pat
makeJustPattern [Name]
finalOutputNames [Pat] -> Pat
TupP
getMethodCallDefDec = [d|
$( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodCallDefN ) =
M.MethodCall { M.methodCallPath = defObjectPath
, M.methodCallInterface = Just methodInterface
, M.methodCallMember = methodNameMN
, M.methodCallDestination = busNameM
, M.methodCallSender = Nothing
, M.methodCallReplyExpected = True
, M.methodCallAutoStart = True
, M.methodCallBody = []
}
|]
setMethodCallParamsE = Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ
getSetMethodCallParams Name
methodCallDefN
(Name -> Bool -> Maybe Name
forall a. a -> Bool -> Maybe a
maybeName Name
busN Bool
takeBusArg)
(Name -> Bool -> Maybe Name
forall a. a -> Bool -> Maybe a
maybeName Name
objectPathN Bool
takeObjectPathArg)
(Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
variantListExp)
handleReplySuccess =
if Int
outputLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then
[| Right () |]
else
[|
case M.methodReturnBody $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
replySuccessN ) of
$( Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fromVariantOutputNames ) ->
case $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fromVariantExp ) of
$( Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
maybeExtractionPattern ) -> Right $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
finalResultTuple )
_ -> Left $ clientArgumentUnpackingError $
M.methodReturnBody $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
replySuccessN )
_ -> Left $ clientArgumentUnpackingError $
M.methodReturnBody $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
replySuccessN )
|]
getFunctionBody = [|
do
let $( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodCallN ) = $( ExpQ
setMethodCallParamsE )
$( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
callResultN ) <- call $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
clientN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN )
return $ case $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
callResultN ) of
Right $( Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
rightPattern ) -> $( ExpQ
handleReplySuccess )
Left e -> Left e
|]
where rightPattern :: Pat
rightPattern = if Int
outputLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Pat
WildP
else Name -> Pat
VarP Name
replySuccessN
functionBody <- getFunctionBody
methodCallDef <- getMethodCallDefDec
let methodSignature = (MethodArg -> Type -> Type) -> Type -> [MethodArg] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MethodArg -> Type -> Type
addInArg Type
fullOutputSignature [MethodArg]
inputArgs
addInArg MethodArg
arg = Type -> Type -> Type
addTypeArg (Type -> Type -> Type) -> Type -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
getArgType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ MethodArg -> Type
I.methodArgType MethodArg
arg
fullOutputSignature = Type -> Type -> Type
AppT (Name -> Type
ConT ''IO) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Either)
(Name -> Type
ConT ''M.MethodError))
Type
outputSignature
outputSignature =
case Int
outputLength of
Int
1 -> Type -> Type
getArgType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ MethodArg -> Type
I.methodArgType (MethodArg -> Type) -> MethodArg -> Type
forall a b. (a -> b) -> a -> b
$ [MethodArg] -> MethodArg
forall a. HasCallStack => [a] -> a
head [MethodArg]
outputArgs
Int
_ -> (Type -> MethodArg -> Type) -> Type -> [MethodArg] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> MethodArg -> Type
addOutArg (Int -> Type
TupleT Int
outputLength) [MethodArg]
outputArgs
addOutArg Type
target MethodArg
arg = Type -> Type -> Type
AppT Type
target (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
getArgType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ MethodArg -> Type
I.methodArgType MethodArg
arg
fullSignature = Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
takeBusArg Bool
takeObjectPathArg Type
methodSignature
fullArgNames =
Name
clientNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeBusArg Name
busN
(Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeObjectPathArg Name
objectPathN [Name]
methodArgNames)
definitionDec = Name -> Type -> Dec
SigD Name
functionN Type
fullSignature
function = Name -> [Name] -> Exp -> Dec
mkFunD Name
functionN [Name]
fullArgNames Exp
functionBody
methodCallSignature = Name -> Type -> Dec
SigD Name
methodCallDefN (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''M.MethodCall
return $ methodCallSignature:methodCallDef ++ [definitionDec, function]
generateClientProperty :: GenerationParams -> I.Property -> Q [Dec]
generateClientProperty :: GenerationParams -> Property -> Q [Dec]
generateClientProperty GenerationParams
{ getTHType :: GenerationParams -> Type -> Type
getTHType = Type -> Type
getArgType
, genInterfaceName :: GenerationParams -> InterfaceName
genInterfaceName = InterfaceName
propertyInterface
, genObjectPath :: GenerationParams -> Maybe ObjectPath
genObjectPath = Maybe ObjectPath
objectPathM
, genBusName :: GenerationParams -> Maybe BusName
genBusName = Maybe BusName
busNameM
}
I.Property
{ propertyName :: Property -> String
I.propertyName = String
name
, propertyType :: Property -> Type
I.propertyType = Type
propType
, propertyRead :: Property -> Bool
I.propertyRead = Bool
readable
, propertyWrite :: Property -> Bool
I.propertyWrite = Bool
writable
} =
do
clientN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"client"
busN <- newName "busName"
objectPathN <- newName "objectPath"
methodCallN <- newName "methodCall"
argN <- newName "arg"
let takeBusArg = Maybe BusName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe BusName
busNameM
takeObjectPathArg = Maybe ObjectPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ObjectPath
objectPathM
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString String
"/") Maybe ObjectPath
objectPathM
methodCallDefN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"methodCallFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
getMethodCallDefDec = [d|
$( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodCallDefN ) =
M.MethodCall { M.methodCallPath = defObjectPath
, M.methodCallInterface = Just propertyInterface
, M.methodCallMember = fromString name
, M.methodCallDestination = busNameM
, M.methodCallSender = Nothing
, M.methodCallReplyExpected = True
, M.methodCallAutoStart = True
, M.methodCallBody = []
}
|]
setMethodCallParamsE = Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ
getSetMethodCallParams Name
methodCallDefN
(Name -> Bool -> Maybe Name
forall a. a -> Bool -> Maybe a
maybeName Name
busN Bool
takeBusArg)
(Name -> Bool -> Maybe Name
forall a. a -> Bool -> Maybe a
maybeName Name
objectPathN Bool
takeObjectPathArg)
(Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [])
makeGetterBody = [|
do
let $( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodCallN ) = $( ExpQ
setMethodCallParamsE )
getPropertyValue $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
clientN )
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN )
|]
makeSetterBody = [|
do
let $( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodCallN ) = $( ExpQ
setMethodCallParamsE )
setPropertyValue $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
clientN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodCallN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argN )
|]
methodCallDefs <- getMethodCallDefDec
getterBody <- makeGetterBody
setterBody <- makeSetterBody
let buildSignature = Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
takeBusArg Bool
takeObjectPathArg
getterSigType =
Type -> Type
buildSignature (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
AppT (Name -> Type
ConT ''IO) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Either)
(Name -> Type
ConT ''M.MethodError)) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
getArgType Type
propType
setterSigType = Type -> Type
buildSignature (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
addTypeArg (Type -> Type
getArgType Type
propType) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
AppT (Name -> Type
ConT ''IO) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Name -> Type
ConT ''M.MethodError)
buildArgs [Name]
rest = Name
clientNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeBusArg Name
busN
(Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeObjectPathArg Name
objectPathN [Name]
rest)
getterArgNames = [Name] -> [Name]
buildArgs []
setterArgNames = [Name] -> [Name]
buildArgs [Name
argN]
propertyString = String -> String
forall a b. Coercible a b => a -> b
coerce String
name
getterName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
propertyString
setterName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
propertyString
getterFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
getterName [Name]
getterArgNames Exp
getterBody
setterFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
setterName [Name]
setterArgNames Exp
setterBody
getterSignature = Name -> Type -> Dec
SigD Name
getterName Type
getterSigType
setterSignature = Name -> Type -> Dec
SigD Name
setterName Type
setterSigType
getterDefs = if Bool
readable then [Dec
getterSignature, Dec
getterFunction] else []
setterDefs = if Bool
writable then [Dec
setterSignature, Dec
setterFunction] else []
methodCallSignature = Name -> Type -> Dec
SigD Name
methodCallDefN (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''M.MethodCall
return $ methodCallSignature:methodCallDefs ++ getterDefs ++ setterDefs
generateSignalsFromInterface :: GenerationParams -> I.Interface -> Q [Dec]
generateSignalsFromInterface :: GenerationParams -> Interface -> Q [Dec]
generateSignalsFromInterface GenerationParams
params
I.Interface{ interfaceName :: Interface -> InterfaceName
I.interfaceName = InterfaceName
name
, interfaceSignals :: Interface -> [Signal]
I.interfaceSignals = [Signal]
signals
} = GenerationParams -> InterfaceName -> [Signal] -> Q [Dec]
generateSignals GenerationParams
params InterfaceName
name [Signal]
signals
generateSignals :: GenerationParams -> T.InterfaceName -> [I.Signal] -> Q [Dec]
generateSignals :: GenerationParams -> InterfaceName -> [Signal] -> Q [Dec]
generateSignals GenerationParams
params InterfaceName
name [Signal]
signals =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
(Signal -> Q [Dec]) -> [Signal] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (GenerationParams -> Signal -> Q [Dec]
generateSignal GenerationParams
params { genInterfaceName = coerce name })
[Signal]
signals
generateSignal :: GenerationParams -> I.Signal -> Q [Dec]
generateSignal :: GenerationParams -> Signal -> Q [Dec]
generateSignal GenerationParams
{ getTHType :: GenerationParams -> Type -> Type
getTHType = Type -> Type
getArgType
, genInterfaceName :: GenerationParams -> InterfaceName
genInterfaceName = InterfaceName
signalInterface
, genObjectPath :: GenerationParams -> Maybe ObjectPath
genObjectPath = Maybe ObjectPath
objectPathM
, genBusName :: GenerationParams -> Maybe BusName
genBusName = Maybe BusName
busNameM
, genTakeSignalErrorHandler :: GenerationParams -> Bool
genTakeSignalErrorHandler = Bool
takeErrorHandler
}
I.Signal
{ signalName :: Signal -> MemberName
I.signalName = MemberName
name
, signalArgs :: Signal -> [SignalArg]
I.signalArgs = [SignalArg]
args
} =
do
let buildArgNames :: Q [Name]
buildArgNames = (SignalArg -> Q Name) -> [SignalArg] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Q Name
newNameDef (String -> Q Name) -> (SignalArg -> String) -> SignalArg -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalArg -> String
I.signalArgName) [SignalArg]
args
argNames <- Q [Name]
buildArgNames
fromVariantOutputNames <- buildArgNames
toHandlerOutputNames <- buildArgNames
objectPathN <- newName "objectPath"
variantsN <- newName "variants"
signalN <- newName "signal"
receivedSignalN <- newName "signal"
clientN <- newName "client"
handlerArgN <- newName "handlerArg"
errorHandlerN <- newName "errorHandler"
matchRuleN <- newName "matchRule"
matchRuleArgN <- newName "matchRuleArg"
let variantListExp = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
makeToVariantApp [Name]
argNames
signalString = MemberName -> String
forall a b. Coercible a b => a -> b
coerce MemberName
name
signalDefN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"signalFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
takeObjectPathArg = Maybe ObjectPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ObjectPath
objectPathM
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString String
"/") Maybe ObjectPath
objectPathM
argCount = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames
getSignalDefDec = [d|
$( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
signalDefN ) =
M.Signal { M.signalPath = defObjectPath
, M.signalInterface = signalInterface
, M.signalMember = name
, M.signalDestination = Nothing
, M.signalSender = Nothing
, M.signalBody = []
}
|]
let mapOrHead' = Int -> (t -> b) -> [t] -> ([b] -> b) -> b
forall a t b.
(Num a, Eq a) =>
a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead Int
argCount
fromVariantExp = (Name -> Exp) -> [Name] -> ([Exp] -> Exp) -> Exp
forall {t} {b}. (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead' Name -> Exp
makeFromVariantApp [Name]
fromVariantOutputNames [Exp] -> Exp
mkTupE
maybeExtractionPattern = (Name -> Pat) -> [Name] -> ([Pat] -> Pat) -> Pat
forall {t} {b}. (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead' Name -> Pat
makeJustPattern [Name]
toHandlerOutputNames [Pat] -> Pat
TupP
applyToName Exp
toApply Name
n = Exp -> Exp -> Exp
AppE Exp
toApply (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
finalApplication = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Name -> Exp
applyToName (Name -> Exp
VarE Name
handlerArgN)
(Name
receivedSignalNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
toHandlerOutputNames)
makeHandlerN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"makeHandlerFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
makeHandlerCall =
if Bool
takeErrorHandler
then Exp -> Exp -> Exp
AppE Exp
base (Name -> Exp
VarE Name
errorHandlerN)
else Exp
base
where base :: Exp
base = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
makeHandlerN) (Name -> Exp
VarE Name
handlerArgN)
getSetSignal =
if Bool
takeObjectPathArg
then [|
$( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
signalDefN )
{ M.signalPath = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
objectPathN )
, M.signalBody = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
variantsN )
}
|]
else [| $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
signalDefN )
{ M.signalBody = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
variantsN ) }
|]
getEmitBody = [|
let $( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
variantsN ) = $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
variantListExp )
$( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
signalN ) = $( ExpQ
getSetSignal )
in
emit $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
clientN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
signalN )
|]
getErrorHandler =
if Bool
takeErrorHandler then
[| $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorHandlerN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
receivedSignalN )|]
else [| return () |]
getMakeHandlerBody =
if Int
argCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then
[| $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
finalApplication ) |]
else
[|
case M.signalBody $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
receivedSignalN ) of
$( Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fromVariantOutputNames ) ->
case $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fromVariantExp ) of
$( Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
maybeExtractionPattern ) -> $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
finalApplication )
_ -> $( ExpQ
getErrorHandler )
_ -> $( ExpQ
getErrorHandler )
|]
getRegisterBody = [|
let $( Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
matchRuleN ) = $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
matchRuleArgN )
{ C.matchInterface = Just signalInterface
, C.matchMember = Just name
, C.matchSender =
runGetFirst
[ C.matchSender $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
matchRuleArgN )
, busNameM
]
, C.matchPath =
runGetFirst
[ C.matchPath $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
matchRuleArgN )
, objectPathM
]
}
in
C.addMatch $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
clientN ) $( Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
matchRuleN ) $ $( Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
makeHandlerCall )
|]
registerBody <- getRegisterBody
makeHandlerBody <- getMakeHandlerBody
signalDef <- getSignalDefDec
emitBody <- getEmitBody
let methodSignature = (SignalArg -> Type -> Type) -> Type -> [SignalArg] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SignalArg -> Type -> Type
addInArg Type
unitIOType [SignalArg]
args
addInArg SignalArg
arg = Type -> Type -> Type
addTypeArg (Type -> Type -> Type) -> Type -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
getArgType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ SignalArg -> Type
I.signalArgType SignalArg
arg
fullArgNames = Name
clientNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeObjectPathArg Name
objectPathN [Name]
argNames
fullSignature =
Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
False Bool
takeObjectPathArg Type
methodSignature
functionN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"emit" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
emitSignature = Name -> Type -> Dec
SigD Name
functionN Type
fullSignature
emitFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
functionN [Name]
fullArgNames Exp
emitBody
handlerType = Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
methodSignature
errorHandlerType = Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
unitIOType
registerN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"registerFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
registerArgs = Name
clientNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
matchRuleArgNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
handlerArgNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:
Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeErrorHandler Name
errorHandlerN []
registerFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
registerN [Name]
registerArgs Exp
registerBody
registerType =
Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''C.Client) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''C.MatchRule) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
addTypeArg Type
handlerType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Bool -> Type -> Type -> Type
addTypeArgIf Bool
takeErrorHandler (Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
unitIOType) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
AppT (Name -> Type
ConT ''IO) (Name -> Type
ConT ''C.SignalHandler)
registerSignature = Name -> Type -> Dec
SigD Name
registerN Type
registerType
makeHandlerArgs =
Name
handlerArgNName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Bool -> Name -> [Name] -> [Name]
forall a. Bool -> a -> [a] -> [a]
addArgIf Bool
takeErrorHandler Name
errorHandlerN [Name
receivedSignalN]
makeHandlerFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
makeHandlerN [Name]
makeHandlerArgs Exp
makeHandlerBody
makeHandlerType = Type -> Type -> Type
addTypeArg Type
handlerType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Bool -> Type -> Type -> Type
addTypeArgIf Bool
takeErrorHandler Type
errorHandlerType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
unitIOType
makeHandlerSignature = Name -> Type -> Dec
SigD Name
makeHandlerN Type
makeHandlerType
signalSignature = Name -> Type -> Dec
SigD Name
signalDefN (Name -> Type
ConT ''M.Signal)
return $ signalSignature:
signalDef ++ [ emitSignature, emitFunction
, makeHandlerSignature, makeHandlerFunction
, registerSignature, registerFunction
]
generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]
generateFromFilePath :: GenerationParams -> String -> Q [Dec]
generateFromFilePath GenerationParams
generationParams String
filepath = do
xml <- IO Text -> Q Text
forall a. IO a -> Q a
runIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
Text.readFile String
filepath
let obj = [Object] -> Object
forall a. HasCallStack => [a] -> a
head ([Object] -> Object) -> [Object] -> Object
forall a b. (a -> b) -> a -> b
$ Maybe Object -> [Object]
forall a. Maybe a -> [a]
maybeToList (Maybe Object -> [Object]) -> Maybe Object -> [Object]
forall a b. (a -> b) -> a -> b
$ ObjectPath -> Text -> Maybe Object
I.parseXML ObjectPath
"/" Text
xml
interface = [Interface] -> Interface
forall a. HasCallStack => [a] -> a
head ([Interface] -> Interface) -> [Interface] -> Interface
forall a b. (a -> b) -> a -> b
$ Object -> [Interface]
I.objectInterfaces Object
obj
signals = GenerationParams -> Interface -> Q [Dec]
generateSignalsFromInterface GenerationParams
generationParams Interface
interface
client = GenerationParams -> Interface -> Q [Dec]
generateClient GenerationParams
generationParams Interface
interface
in fmap (++) signals <*> client