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

-- | 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 :: (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)
-> 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

-- 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 ?? :: f (a -> b) -> a -> f b
?? 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
ClientBusPathR (a -> IO b)
soFar ?/? :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b
?/? 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 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 (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 String
n =
  case String
n of
    String
"" -> String -> Q Name
newName String
"arg"
    String
"data" -> String -> Q Name
newName String
"arg"
    String
_ -> 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 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 :: 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 :: InterfaceName
genInterfaceName = InterfaceName -> InterfaceName
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 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 -> [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 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. [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 :: [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) -> [|
                       $( varE methodCallN )
                          { M.methodCallDestination = Just $( varE busN )
                          , M.methodCallPath = $( varE objectPathN )
                          , M.methodCallBody = $( variantsE )
                          }
                     |]
    (Just Name
busN, Maybe Name
Nothing) -> [|
                        $( varE methodCallN )
                          { M.methodCallDestination = Just $( varE busN )
                          , M.methodCallBody = $( variantsE )
                          }
                      |]
    (Maybe Name
Nothing, Just Name
objectPathN) -> [|
                        $( varE methodCallN )
                          { M.methodCallPath = $( varE objectPathN )
                          , M.methodCallBody = $( variantsE )
                          }
                      |]
    (Maybe Name
Nothing, Maybe Name
Nothing) -> [|
                         $( varE methodCallN ) { M.methodCallBody = $( 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 =
  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 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 (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
        Char
functionNameFirst:String
functionNameRest = MemberName -> String
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
    Name
clientN <- String -> Q Name
newName String
"client"
    Name
busN <- String -> Q Name
newName String
"busName"
    Name
objectPathN <- String -> Q Name
newName String
"objectPath"
    Name
methodCallN <- String -> Q Name
newName String
"methodCall"
    Name
callResultN <- String -> Q Name
newName String
"callResult"
    Name
replySuccessN <- String -> Q Name
newName String
"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
== Int
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
== Int
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 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
            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. [a] -> a
head [MethodArg]
outputArgs
            Int
_ -> (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 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 :: 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 String
"client"
    Name
busN <- String -> Q Name
newName String
"busName"
    Name
objectPathN <- String -> Q Name
newName String
"objectPath"
    Name
methodCallN <- String -> Q Name
newName String
"methodCall"
    Name
argN <- String -> Q Name
newName String
"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 String
"/") Maybe ObjectPath
objectPathM
        methodCallDefN :: Name
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 :: 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 [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
coerce String
name
        getterName :: 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 :: Name
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 :: 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 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 (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
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 String
"objectPath"
    Name
variantsN <- String -> Q Name
newName String
"variants"
    Name
signalN <- String -> Q Name
newName String
"signal"
    Name
receivedSignalN <- String -> Q Name
newName String
"signal"
    Name
clientN <- String -> Q Name
newName String
"client"
    Name
handlerArgN <- String -> Q Name
newName String
"handlerArg"
    Name
errorHandlerN <- String -> Q Name
newName String
"errorHandler"
    Name
matchRuleN <- String -> Q Name
newName String
"matchRule"
    Name
matchRuleArgN <- String -> Q Name
newName String
"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
coerce MemberName
name
        signalDefN :: 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 :: 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 String
"/") 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 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
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
$ String
"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
== Int
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 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
        -- Never take bus arg because it is set automatically anyway
        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
$ String
"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
$ String
"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 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 ObjectPath
"/" 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