{-# 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(..))

-- | Compatibility helper to create (total) tuple expressions
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

-- Use these operators together with dbusInvoke to invoke functions of the form
-- Client -> T.BusName -> T.ObjectPath
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
            -- Because of a quirk in how we unmarshal things, we currently HAVE
            -- to decorde arrays of Word8 in this way.
            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
        -- Never take bus arg because it is set automatically anyway
        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