{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.Util where

import           Control.Applicative
import           DBus.Generation
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import qualified Data.Char as Char
import           Data.Coerce
import           Data.Maybe
import           Language.Haskell.TH
import           StatusNotifier.Util (getIntrospectionObjectFromFile)

#if __GLASGOW_HASKELL__ >= 802
deriveShowAndEQ :: [DerivClause]
deriveShowAndEQ :: [DerivClause]
deriveShowAndEQ =
  [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Eq, Name -> Type
ConT ''Show]]
#endif

buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec
buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec
buildDataFromNameTypePairs Name
name [(Name, Type)]
pairs =
  Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
name (((Name, Type) -> VarBangType) -> [(Name, Type)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> VarBangType
forall {a} {c}. (a, c) -> (a, Bang, c)
mkVarBangType [(Name, Type)]
pairs)]
#if __GLASGOW_HASKELL__ >= 802
        [DerivClause]
deriveShowAndEQ
#else
        []
#endif
  where mkVarBangType :: (a, c) -> (a, Bang, c)
mkVarBangType (a
fieldName, c
fieldType) =
          (a
fieldName, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, c
fieldType)


standaloneDeriveEqShow :: Name -> [Dec]
#if __GLASGOW_HASKELL__ < 802
standaloneDeriveEqShow name =
  [ StandaloneDerivD [] (ConT ''Eq `AppT` ConT name)
  , StandaloneDerivD [] (ConT ''Show `AppT` ConT name)
  ]
#else
standaloneDeriveEqShow :: Name -> [Dec]
standaloneDeriveEqShow Name
_ = []
#endif

type GetTypeForName = String -> T.Type -> Maybe Type

data RecordGenerationParams = RecordGenerationParams
  { RecordGenerationParams -> Maybe [Char]
recordName :: Maybe String
  , RecordGenerationParams -> [Char]
recordPrefix :: String
  , RecordGenerationParams -> GetTypeForName
recordTypeForName :: GetTypeForName
  }

defaultRecordGenerationParams :: RecordGenerationParams
defaultRecordGenerationParams :: RecordGenerationParams
defaultRecordGenerationParams = RecordGenerationParams
  { recordName :: Maybe [Char]
recordName = Maybe [Char]
forall a. Maybe a
Nothing
  , recordPrefix :: [Char]
recordPrefix = [Char]
"_"
  , recordTypeForName :: GetTypeForName
recordTypeForName = (Type -> Maybe Type) -> GetTypeForName
forall a b. a -> b -> a
const ((Type -> Maybe Type) -> GetTypeForName)
-> (Type -> Maybe Type) -> GetTypeForName
forall a b. (a -> b) -> a -> b
$ Maybe Type -> Type -> Maybe Type
forall a b. a -> b -> a
const Maybe Type
forall a. Maybe a
Nothing
  }

generateGetAllRecord
  :: RecordGenerationParams
  -> GenerationParams
  -> I.Interface
  -> Q [Dec]
generateGetAllRecord :: RecordGenerationParams -> GenerationParams -> Interface -> Q [Dec]
generateGetAllRecord
               RecordGenerationParams
               { recordName :: RecordGenerationParams -> Maybe [Char]
recordName = Maybe [Char]
recordNameString
               , recordPrefix :: RecordGenerationParams -> [Char]
recordPrefix = [Char]
prefix
               , recordTypeForName :: RecordGenerationParams -> GetTypeForName
recordTypeForName = GetTypeForName
getTypeForName
               }
               GenerationParams { getTHType :: GenerationParams -> Type -> Type
getTHType = Type -> Type
getArgType }
               I.Interface { interfaceName :: Interface -> InterfaceName
I.interfaceName = InterfaceName
interfaceName
                           , interfaceProperties :: Interface -> [Property]
I.interfaceProperties = [Property]
properties
                           } = do
  let theRecordName :: Name
theRecordName =
        Name -> ([Char] -> Name) -> Maybe [Char] -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toUpper ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
Char.isLetter ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ InterfaceName -> [Char]
forall a b. Coercible a b => a -> b
coerce InterfaceName
interfaceName)
              [Char] -> Name
mkName Maybe [Char]
recordNameString
  let getPairFromProperty :: Property -> (Name, Type)
getPairFromProperty I.Property
                            { propertyName :: Property -> [Char]
I.propertyName = [Char]
propName
                            , propertyType :: Property -> Type
I.propertyType = Type
propType
                            } =
                            ( [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
propName
                            , Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (Type -> Type
getArgType Type
propType) (Maybe Type -> Type) -> Maybe Type -> Type
forall a b. (a -> b) -> a -> b
$ GetTypeForName
getTypeForName [Char]
propName Type
propType
                            )
      getAllRecord :: Dec
getAllRecord =
        Name -> [(Name, Type)] -> Dec
buildDataFromNameTypePairs
        Name
theRecordName ([(Name, Type)] -> Dec) -> [(Name, Type)] -> Dec
forall a b. (a -> b) -> a -> b
$ (Property -> (Name, Type)) -> [Property] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Property -> (Name, Type)
getPairFromProperty [Property]
properties
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
getAllRecordDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:Name -> [Dec]
standaloneDeriveEqShow Name
theRecordName

generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile :: RecordGenerationParams
-> GenerationParams -> Bool -> [Char] -> Q [Dec]
generateClientFromFile RecordGenerationParams
recordGenerationParams GenerationParams
params Bool
useObjectPath [Char]
filepath = do
  Object
object <- [Char] -> ObjectPath -> Q Object
getIntrospectionObjectFromFile [Char]
filepath ObjectPath
"/"
  let interface :: Interface
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
object
      actualObjectPath :: ObjectPath
actualObjectPath = Object -> ObjectPath
I.objectPath Object
object
      realParams :: GenerationParams
realParams =
        if Bool
useObjectPath
          then GenerationParams
params {genObjectPath :: Maybe ObjectPath
genObjectPath = ObjectPath -> Maybe ObjectPath
forall a. a -> Maybe a
Just ObjectPath
actualObjectPath}
          else GenerationParams
params
      <++> :: Q [a] -> Q [a] -> Q [a]
(<++>) = ([a] -> [a] -> [a]) -> Q [a] -> Q [a] -> Q [a]
forall a b c. (a -> b -> c) -> Q a -> Q b -> Q c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
  RecordGenerationParams -> GenerationParams -> Interface -> Q [Dec]
generateGetAllRecord RecordGenerationParams
recordGenerationParams GenerationParams
params Interface
interface Q [Dec] -> Q [Dec] -> Q [Dec]
forall {a}. Q [a] -> Q [a] -> Q [a]
<++>
    GenerationParams -> Interface -> Q [Dec]
generateClient GenerationParams
realParams Interface
interface Q [Dec] -> Q [Dec] -> Q [Dec]
forall {a}. Q [a] -> Q [a] -> Q [a]
<++>
    GenerationParams -> Interface -> Q [Dec]
generateSignalsFromInterface GenerationParams
realParams Interface
interface