{-# LANGUAGE TemplateHaskell, TypeOperators, DeriveDataTypeable #-}

module DBus.TH
  (module Data.Int,
   module Data.Word,
   Proxy,
   Client, BusName,
   ObjectPath, InterfaceName,
   MemberName, Variant,
   connectSession, connectSystem,
   proxy,
   Signature (..),
   Function (..),
   (=::), as,
   interface
  ) where

import Control.Monad
import Data.Int
import Data.Word
import Language.Haskell.TH
import qualified Data.Text as Text
import Data.Char
import Data.List
import Data.Generics
import DBus.Client.Simple hiding (Type, Signature)

-- | Function signature
data Signature = Return Name
               | Name :-> Signature
  deriving (Eq, Show, Data, Typeable)

infixr 6 :->

-- | Function with DBus name and Haskell name
data Function = Function {
    fnName      :: String    -- ^ Function name to use in Haskell
  , fnDBusName  :: String    -- ^ Function name to use in DBus
  , fnSignature :: Signature -- ^ Function signature
    }
  deriving (Eq, Show, Data, Typeable)

-- | Create a Function from it's name and Signature.
-- Sets fnDBusName == fnName.
(=::) :: String -> Signature -> Function
name =:: sig = Function name name sig

infixr 5 =::

-- | Set specific Haskell name for Function.
as :: Function -> String -> Function
fn `as` name = fn {fnName = name}

infixl 4 `as`

nArgs :: Signature -> Int
nArgs (Return _) = 0
nArgs (_ :-> s)  = 1 + nArgs s

firstLower :: String -> String
firstLower [] = []
firstLower (x:xs) = toLower x: xs

-- | Generate bindings for methods in specific DBus interface.
-- If second argument is (Just prefix), then prefix will be
-- added to the beginning of all DBus names and removed from all
-- Haskell names.
interface :: String       -- ^ Interface name
          -> Maybe String -- ^ Prefix
          -> [Function]   -- ^ List of functions
          -> Q [Dec]
interface ifaceName mbPrefix fns = concat `fmap` mapM iface fns
  where
    iface :: Function -> Q [Dec]
    iface (Function name dbusName sig) =
        let name'     = strip name
            dbusName' = addPrefix dbusName
        in sequence [generateSignature name' sig,
                     generateImplementation name' dbusName' sig]

    addPrefix :: String -> String
    addPrefix s =
      case mbPrefix of
        Nothing     -> s
        Just prefix -> prefix ++ s

    strip :: String -> String
    strip s =
      case mbPrefix of
        Nothing     -> s
        Just prefix -> if prefix `isPrefixOf` s
                         then drop (length prefix) s
                         else s

    generateSignature :: String -> Signature -> Q Dec
    generateSignature name sig = do
        dbt <- dbusType (transformType sig)
        return $ SigD (mkName $ firstLower name) dbt

    dbusType :: Type -> Q Type
    dbusType t = [t| Proxy -> $(return t) |]

    transformType :: Signature -> Type
    transformType (Return t) = AppT (ConT ''IO) (AppT (ConT ''Maybe) (ConT t))
    transformType (t :-> s)  = AppT (AppT ArrowT (ConT t)) (transformType s)

    generateImplementation :: String -> String -> Signature -> Q Dec
    generateImplementation name dbusName sig = do
        let bus  = mkName "bus"
        args <- replicateM (nArgs sig) (newName "x")
        body <- generateBody dbusName sig args
        return $ FunD (mkName $ firstLower name) [Clause (VarP bus: map VarP args) (NormalB body) []]

    generateBody :: String -> Signature -> [Name] -> Q Exp
    generateBody name sig names = do
        [| do
           res <- call $(varE $ mkName "bus")
                       (interfaceName_ $ Text.pack ifaceName)
                       (memberName_ $ Text.pack name)
                       $(variant names) 
           return $ fromVariant (res !! 0)
          |]

    variant :: [Name] -> Q Exp
    variant names = do
      exs <- mapM variant1 names
      return $ ListE exs

    variant1 :: Name -> Q Exp
    variant1 name = [| toVariant $(varE name) |]