{-# 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.Functor ((<$>))
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 = [Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
. map Just
#endif
type ClientBusPathR a = ReaderT (Client, T.BusName, T.ObjectPath) IO a
dbusInvoke :: (Client -> T.BusName -> T.ObjectPath -> a) -> ClientBusPathR a
dbusInvoke :: (Client -> BusName -> ObjectPath -> a) -> ClientBusPathR a
dbusInvoke fn :: Client -> BusName -> ObjectPath -> a
fn = (\(c :: Client
c, b :: BusName
b, p :: 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)
-> ClientBusPathR 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
fab :: f (a -> b)
fab ?? :: f (a -> b) -> a -> f b
?? a :: a
a = ((a -> b) -> b) -> f (a -> b) -> 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
soFar :: ClientBusPathR (a -> IO b)
soFar ?/? :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b
?/? arg :: a
arg = do
IO b
returnValue <- ((a -> IO b) -> IO b)
-> ClientBusPathR (a -> IO b)
-> ReaderT (Client, BusName, ObjectPath) IO (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
IO b -> ClientBusPathR b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO b
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 k :: 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 arrayTypeBuilder :: Type -> Type
arrayTypeBuilder dictTypeBuilder :: Type -> Type -> Type
dictTypeBuilder = Type -> Type
fn
where fn :: Type -> Type
fn t :: Type
t =
case Type
t of
T.TypeArray T.TypeWord8 -> Name -> Type
ConT ''BS.ByteString
T.TypeBoolean -> Name -> Type
ConT ''Bool
T.TypeWord8 -> Name -> Type
ConT ''Word8
T.TypeWord16 -> Name -> Type
ConT ''Word16
T.TypeWord32 -> Name -> Type
ConT ''Word32
T.TypeWord64 -> Name -> Type
ConT ''Word64
T.TypeInt16 -> Name -> Type
ConT ''Int16
T.TypeInt32 -> Name -> Type
ConT ''Int32
T.TypeInt64 -> Name -> Type
ConT ''Int64
T.TypeDouble -> Name -> Type
ConT ''Double
T.TypeUnixFd -> Name -> Type
ConT ''Fd
T.TypeString -> Name -> Type
ConT ''String
T.TypeSignature -> Name -> Type
ConT ''T.Signature
T.TypeObjectPath -> Name -> Type
ConT ''T.ObjectPath
T.TypeVariant -> Name -> Type
ConT ''T.Variant
T.TypeArray arrayType :: Type
arrayType -> Type -> Type
arrayTypeBuilder (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
fn Type
arrayType
T.TypeDictionary k :: Type
k v :: Type
v -> Type -> Type -> Type
dictTypeBuilder (Type -> Type
fn Type
k) (Type -> Type
fn Type
v)
T.TypeStructure ts :: [Type]
ts -> (Type -> Type -> Type) -> Type -> [Type] -> Type
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 (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 n :: String
n =
case String
n of
"" -> String -> Q Name
newName "arg"
"data" -> String -> Q Name
newName "arg"
_ -> String -> Q Name
newName String
n
defaultGenerationParams :: GenerationParams
defaultGenerationParams :: GenerationParams
defaultGenerationParams =
GenerationParams :: Maybe BusName
-> Maybe ObjectPath
-> InterfaceName
-> Bool
-> (Type -> Type)
-> GenerationParams
GenerationParams
{ genBusName :: Maybe BusName
genBusName = Maybe BusName
forall a. Maybe a
Nothing
, genInterfaceName :: InterfaceName
genInterfaceName = String -> InterfaceName
forall a. IsString a => String -> a
fromString ""
, 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 argT :: 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 condition :: Bool
condition theType :: 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 0)
addArgIf :: Bool -> a -> [a] -> [a]
addArgIf :: Bool -> a -> [a] -> [a]
addArgIf condition :: Bool
condition name :: 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 :: [Name]
argNames body :: 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 params :: 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 :: InterfaceName
genInterfaceName = InterfaceName -> InterfaceName
forall a b. Coercible a b => a -> b
coerce InterfaceName
name } in
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
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)
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 :: a -> Bool -> Maybe a
maybeName name :: a
name condition :: 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
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
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 = Name -> [Pat] -> Pat
ConP 'Just [Name -> Pat
VarP Name
name]
mapOrHead ::
(Num a, Eq a) => a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead :: a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead outputLength :: a
outputLength fn :: t -> b
fn names :: [t]
names cons :: [b] -> b
cons =
case a
outputLength of
1 -> t -> b
fn (t -> b) -> t -> b
forall a b. (a -> b) -> a -> b
$ [t] -> t
forall a. [a] -> a
head [t]
names
_ -> [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 :: [Maybe a] -> Maybe a
runGetFirst options :: [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 takeBusArg :: Bool
takeBusArg takeObjectPathArg :: 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 methodCallN :: Name
methodCallN mBusN :: Maybe Name
mBusN mObjectPathN :: Maybe Name
mObjectPathN variantsE :: ExpQ
variantsE =
case (Maybe Name
mBusN, Maybe Name
mObjectPathN) of
(Just busN :: Name
busN, Just objectPathN :: Name
objectPathN) -> [|
$( varE methodCallN )
{ M.methodCallDestination = Just $( varE busN )
, M.methodCallPath = $( varE objectPathN )
, M.methodCallBody = $( variantsE )
}
|]
(Just busN :: Name
busN, Nothing) -> [|
$( varE methodCallN )
{ M.methodCallDestination = Just $( varE busN )
, M.methodCallBody = $( variantsE )
}
|]
(Nothing, Just objectPathN :: Name
objectPathN) -> [|
$( varE methodCallN )
{ M.methodCallPath = $( varE objectPathN )
, M.methodCallBody = $( variantsE )
}
|]
(Nothing, Nothing) -> [|
$( varE methodCallN ) { M.methodCallBody = $( variantsE ) }
|]
clientArgumentUnpackingMessage :: String
clientArgumentUnpackingMessage :: String
clientArgumentUnpackingMessage =
"The client method could not unpack the message that was received."
clientArgumentUnpackingError :: [T.Variant] -> M.MethodError
clientArgumentUnpackingError :: [Variant] -> MethodError
clientArgumentUnpackingError variants :: [Variant]
variants =
MethodError :: ErrorName
-> Serial
-> Maybe BusName
-> Maybe BusName
-> [Variant]
-> MethodError
M.MethodError
{ methodErrorName :: ErrorName
M.methodErrorName = ErrorName
C.errorFailed
, methodErrorSerial :: Serial
M.methodErrorSerial = Word32 -> Serial
T.Serial 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 (inputArgs :: [MethodArg]
inputArgs, outputArgs :: [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 (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)
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)
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
functionNameFirst :: Char
functionNameFirst:functionNameRest :: 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]
++ "MethodCall"
defObjectPath :: ObjectPath
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString "/") Maybe ObjectPath
objectPathM
Name
clientN <- String -> Q Name
newName "client"
Name
busN <- String -> Q Name
newName "busName"
Name
objectPathN <- String -> Q Name
newName "objectPath"
Name
methodCallN <- String -> Q Name
newName "methodCall"
Name
callResultN <- String -> Q Name
newName "callResult"
Name
replySuccessN <- String -> Q Name
newName "replySuccess"
[Name]
methodArgNames <- Q [Name]
buildArgNames
[Name]
fromVariantOutputNames <- Q [Name]
buildOutputNames
[Name]
finalOutputNames <- Q [Name]
buildOutputNames
let variantListExp :: [Exp]
variantListExp = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
makeToVariantApp [Name]
methodArgNames
mapOrHead' :: (t -> b) -> [t] -> ([b] -> b) -> b
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 :: Exp
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 :: Exp
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 :: Pat
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 :: Q [Dec]
getMethodCallDefDec = [d|
$( varP 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 :: ExpQ
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 (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 :: ExpQ
handleReplySuccess =
if Int
outputLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then
[| Right () |]
else
[|
case M.methodReturnBody $( varE replySuccessN ) of
$( return $ ListP $ map VarP fromVariantOutputNames ) ->
case $( return fromVariantExp ) of
$( return maybeExtractionPattern ) -> Right $( return finalResultTuple )
_ -> Left $ clientArgumentUnpackingError $
M.methodReturnBody $( varE replySuccessN )
_ -> Left $ clientArgumentUnpackingError $
M.methodReturnBody $( varE replySuccessN )
|]
getFunctionBody :: ExpQ
getFunctionBody = [|
do
let $( varP methodCallN ) = $( setMethodCallParamsE )
$( varP callResultN ) <- call $( return $ VarE clientN ) $( varE methodCallN )
return $ case $( varE callResultN ) of
Right $( return rightPattern ) -> $( handleReplySuccess )
Left e -> Left e
|]
where rightPattern :: Pat
rightPattern = if Int
outputLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then Pat
WildP
else Name -> Pat
VarP Name
replySuccessN
Exp
functionBody <- ExpQ
getFunctionBody
[Dec]
methodCallDef <- Q [Dec]
getMethodCallDefDec
let methodSignature :: Type
methodSignature = (MethodArg -> Type -> Type) -> Type -> [MethodArg] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MethodArg -> Type -> Type
addInArg Type
fullOutputSignature [MethodArg]
inputArgs
addInArg :: MethodArg -> Type -> Type
addInArg arg :: 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
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 :: Type
outputSignature =
case Int
outputLength of
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. [a] -> a
head [MethodArg]
outputArgs
_ -> (Type -> MethodArg -> Type) -> Type -> [MethodArg] -> Type
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 -> MethodArg -> Type
addOutArg target :: Type
target arg :: 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 :: Type
fullSignature = Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
takeBusArg Bool
takeObjectPathArg Type
methodSignature
fullArgNames :: [Name]
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 :: Dec
definitionDec = Name -> Type -> Dec
SigD Name
functionN Type
fullSignature
function :: Dec
function = Name -> [Name] -> Exp -> Dec
mkFunD Name
functionN [Name]
fullArgNames Exp
functionBody
methodCallSignature :: Dec
methodCallSignature = Name -> Type -> Dec
SigD Name
methodCallDefN (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''M.MethodCall
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
methodCallSignatureDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
methodCallDef [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec
definitionDec, Dec
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
Name
clientN <- String -> Q Name
newName "client"
Name
busN <- String -> Q Name
newName "busName"
Name
objectPathN <- String -> Q Name
newName "objectPath"
Name
methodCallN <- String -> Q Name
newName "methodCall"
Name
argN <- String -> Q Name
newName "arg"
let 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
defObjectPath :: ObjectPath
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString "/") Maybe ObjectPath
objectPathM
methodCallDefN :: Name
methodCallDefN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "methodCallFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
getMethodCallDefDec :: Q [Dec]
getMethodCallDefDec = [d|
$( varP 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 :: ExpQ
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 (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [])
makeGetterBody :: ExpQ
makeGetterBody = [|
do
let $( varP methodCallN ) = $( setMethodCallParamsE )
getPropertyValue $( return $ VarE clientN )
$( varE methodCallN )
|]
makeSetterBody :: ExpQ
makeSetterBody = [|
do
let $( varP methodCallN ) = $( setMethodCallParamsE )
setPropertyValue $( varE clientN ) $( varE methodCallN ) $( varE argN )
|]
[Dec]
methodCallDefs <- Q [Dec]
getMethodCallDefDec
Exp
getterBody <- ExpQ
makeGetterBody
Exp
setterBody <- ExpQ
makeSetterBody
let buildSignature :: Type -> Type
buildSignature = Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
takeBusArg Bool
takeObjectPathArg
getterSigType :: Type
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
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] -> [Name]
buildArgs rest :: [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]
getterArgNames = [Name] -> [Name]
buildArgs []
setterArgNames :: [Name]
setterArgNames = [Name] -> [Name]
buildArgs [Name
argN]
propertyString :: String
propertyString = String -> String
forall a b. Coercible a b => a -> b
coerce String
name
getterName :: Name
getterName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
propertyString
setterName :: Name
setterName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
propertyString
getterFunction :: Dec
getterFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
getterName [Name]
getterArgNames Exp
getterBody
setterFunction :: Dec
setterFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
setterName [Name]
setterArgNames Exp
setterBody
getterSignature :: Dec
getterSignature = Name -> Type -> Dec
SigD Name
getterName Type
getterSigType
setterSignature :: Dec
setterSignature = Name -> Type -> Dec
SigD Name
setterName Type
setterSigType
getterDefs :: [Dec]
getterDefs = if Bool
readable then [Dec
getterSignature, Dec
getterFunction] else []
setterDefs :: [Dec]
setterDefs = if Bool
writable then [Dec
setterSignature, Dec
setterFunction] else []
methodCallSignature :: Dec
methodCallSignature = Name -> Type -> Dec
SigD Name
methodCallDefN (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''M.MethodCall
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
methodCallSignatureDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
methodCallDefs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
getterDefs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
setterDefs
generateSignalsFromInterface :: GenerationParams -> I.Interface -> Q [Dec]
generateSignalsFromInterface :: GenerationParams -> Interface -> Q [Dec]
generateSignalsFromInterface params :: 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 params :: GenerationParams
params name :: InterfaceName
name signals :: [Signal]
signals =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
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)
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 :: InterfaceName
genInterfaceName = InterfaceName -> InterfaceName
forall a b. Coercible a b => a -> b
coerce InterfaceName
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)
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
[Name]
argNames <- Q [Name]
buildArgNames
[Name]
fromVariantOutputNames <- Q [Name]
buildArgNames
[Name]
toHandlerOutputNames <- Q [Name]
buildArgNames
Name
objectPathN <- String -> Q Name
newName "objectPath"
Name
variantsN <- String -> Q Name
newName "variants"
Name
signalN <- String -> Q Name
newName "signal"
Name
receivedSignalN <- String -> Q Name
newName "signal"
Name
clientN <- String -> Q Name
newName "client"
Name
handlerArgN <- String -> Q Name
newName "handlerArg"
Name
errorHandlerN <- String -> Q Name
newName "errorHandler"
Name
matchRuleN <- String -> Q Name
newName "matchRule"
Name
matchRuleArgN <- String -> Q Name
newName "matchRuleArg"
let variantListExp :: [Exp]
variantListExp = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
makeToVariantApp [Name]
argNames
signalString :: String
signalString = MemberName -> String
forall a b. Coercible a b => a -> b
coerce MemberName
name
signalDefN :: Name
signalDefN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "signalFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
takeObjectPathArg :: Bool
takeObjectPathArg = Maybe ObjectPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ObjectPath
objectPathM
defObjectPath :: ObjectPath
defObjectPath = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe (String -> ObjectPath
forall a. IsString a => String -> a
fromString "/") Maybe ObjectPath
objectPathM
argCount :: Int
argCount = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames
getSignalDefDec :: Q [Dec]
getSignalDefDec = [d|
$( varP signalDefN ) =
M.Signal { M.signalPath = defObjectPath
, M.signalInterface = signalInterface
, M.signalMember = name
, M.signalDestination = Nothing
, M.signalSender = Nothing
, M.signalBody = []
}
|]
let mapOrHead' :: (t -> b) -> [t] -> ([b] -> b) -> b
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 :: Exp
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 :: Pat
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 -> Name -> Exp
applyToName toApply :: Exp
toApply n :: 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
finalApplication = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
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 :: Name
makeHandlerN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "makeHandlerFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
makeHandlerCall :: Exp
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 :: ExpQ
getSetSignal =
if Bool
takeObjectPathArg
then [|
$( varE signalDefN )
{ M.signalPath = $( varE objectPathN )
, M.signalBody = $( varE variantsN )
}
|]
else [| $( varE signalDefN )
{ M.signalBody = $( varE variantsN ) }
|]
getEmitBody :: ExpQ
getEmitBody = [|
let $( varP variantsN ) = $( return $ ListE variantListExp )
$( varP signalN ) = $( getSetSignal )
in
emit $( varE clientN ) $( varE signalN )
|]
getErrorHandler :: ExpQ
getErrorHandler =
if Bool
takeErrorHandler then
[| $( varE errorHandlerN ) $( varE receivedSignalN )|]
else [| return () |]
getMakeHandlerBody :: ExpQ
getMakeHandlerBody =
if Int
argCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then
[| $( return finalApplication ) |]
else
[|
case M.signalBody $( varE receivedSignalN ) of
$( return $ ListP $ map VarP fromVariantOutputNames ) ->
case $( return fromVariantExp ) of
$( return maybeExtractionPattern ) -> $( return finalApplication )
_ -> $( getErrorHandler )
_ -> $( getErrorHandler )
|]
getRegisterBody :: ExpQ
getRegisterBody = [|
let $( varP matchRuleN ) = $( varE matchRuleArgN )
{ C.matchInterface = Just signalInterface
, C.matchMember = Just name
, C.matchSender =
runGetFirst
[ C.matchSender $( varE matchRuleArgN )
, busNameM
]
, C.matchPath =
runGetFirst
[ C.matchPath $( varE matchRuleArgN )
, objectPathM
]
}
in
C.addMatch $( varE clientN ) $( varE matchRuleN ) $ $( return makeHandlerCall )
|]
Exp
registerBody <- ExpQ
getRegisterBody
Exp
makeHandlerBody <- ExpQ
getMakeHandlerBody
[Dec]
signalDef <- Q [Dec]
getSignalDefDec
Exp
emitBody <- ExpQ
getEmitBody
let methodSignature :: Type
methodSignature = (SignalArg -> Type -> Type) -> Type -> [SignalArg] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SignalArg -> Type -> Type
addInArg Type
unitIOType [SignalArg]
args
addInArg :: SignalArg -> Type -> Type
addInArg arg :: 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]
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 :: Type
fullSignature =
Bool -> Bool -> Type -> Type
buildGeneratedSignature Bool
False Bool
takeObjectPathArg Type
methodSignature
functionN :: Name
functionN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "emit" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
emitSignature :: Dec
emitSignature = Name -> Type -> Dec
SigD Name
functionN Type
fullSignature
emitFunction :: Dec
emitFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
functionN [Name]
fullArgNames Exp
emitBody
handlerType :: Type
handlerType = Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
methodSignature
errorHandlerType :: Type
errorHandlerType = Type -> Type -> Type
addTypeArg (Name -> Type
ConT ''M.Signal) Type
unitIOType
registerN :: Name
registerN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "registerFor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
signalString
registerArgs :: [Name]
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 :: Dec
registerFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
registerN [Name]
registerArgs Exp
registerBody
registerType :: Type
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 :: Dec
registerSignature = Name -> Type -> Dec
SigD Name
registerN Type
registerType
makeHandlerArgs :: [Name]
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 :: Dec
makeHandlerFunction = Name -> [Name] -> Exp -> Dec
mkFunD Name
makeHandlerN [Name]
makeHandlerArgs Exp
makeHandlerBody
makeHandlerType :: Type
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 :: Dec
makeHandlerSignature = Name -> Type -> Dec
SigD Name
makeHandlerN Type
makeHandlerType
signalSignature :: Dec
signalSignature = Name -> Type -> Dec
SigD Name
signalDefN (Name -> Type
ConT ''M.Signal)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
signalSignatureDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
[Dec]
signalDef [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [ Dec
emitSignature, Dec
emitFunction
, Dec
makeHandlerSignature, Dec
makeHandlerFunction
, Dec
registerSignature, Dec
registerFunction
]
generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]
generateFromFilePath :: GenerationParams -> String -> Q [Dec]
generateFromFilePath generationParams :: GenerationParams
generationParams filepath :: String
filepath = do
Text
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
obj = [Object] -> Object
forall a. [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 "/" Text
xml
interface :: Interface
interface = [Interface] -> Interface
forall a. [a] -> a
head ([Interface] -> Interface) -> [Interface] -> Interface
forall a b. (a -> b) -> a -> b
$ Object -> [Interface]
I.objectInterfaces Object
obj
signals :: Q [Dec]
signals = GenerationParams -> Interface -> Q [Dec]
generateSignalsFromInterface GenerationParams
generationParams Interface
interface
client :: Q [Dec]
client = GenerationParams -> Interface -> Q [Dec]
generateClient GenerationParams
generationParams Interface
interface
in ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) Q [Dec]
signals Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
client