{-# 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 = TupE
#if MIN_VERSION_template_haskell(2,16,0)
         . map Just
#endif

type ClientBusPathR a = ReaderT (Client, T.BusName, T.ObjectPath) IO a

dbusInvoke :: (Client -> T.BusName -> T.ObjectPath -> a) -> ClientBusPathR a
dbusInvoke fn = (\(c, b, p) -> fn c b p) <$> 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
fab ?? a = fmap ($ a) fab
{-# INLINE (??) #-}

infixl 4 ?/?
(?/?) :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b
soFar ?/? arg = do
  returnValue <- fmap ($ arg) soFar
  lift returnValue

data GenerationParams = GenerationParams
  { genBusName :: Maybe T.BusName
  , genObjectPath :: Maybe T.ObjectPath
  , genInterfaceName :: T.InterfaceName
  , genTakeSignalErrorHandler :: Bool
  , getTHType :: T.Type -> Type
  }

defaultGetDictType :: Type -> Type -> Type
defaultGetDictType k =
  AppT (AppT (ConT ''Map.Map) k)

defaultGetTHType :: T.Type -> Type
defaultGetTHType = buildGetTHType (AppT ListT) defaultGetDictType

buildGetTHType ::
  (Type -> Type) -> (Type -> Type -> Type) -> T.Type -> Type
buildGetTHType arrayTypeBuilder dictTypeBuilder = fn
  where fn t =
          case t of
            -- Because of a quirk in how we unmarshal things, we currently HAVE
            -- to decorde arrays of Word8 in this way.
            T.TypeArray T.TypeWord8 -> ConT ''BS.ByteString
            T.TypeBoolean -> ConT ''Bool
            T.TypeWord8 -> ConT ''Word8
            T.TypeWord16 -> ConT ''Word16
            T.TypeWord32 -> ConT ''Word32
            T.TypeWord64 -> ConT ''Word64
            T.TypeInt16 -> ConT ''Int16
            T.TypeInt32 -> ConT ''Int32
            T.TypeInt64 -> ConT ''Int64
            T.TypeDouble -> ConT ''Double
            T.TypeUnixFd -> ConT ''Fd
            T.TypeString -> ConT ''String
            T.TypeSignature -> ConT ''T.Signature
            T.TypeObjectPath -> ConT ''T.ObjectPath
            T.TypeVariant -> ConT ''T.Variant
            T.TypeArray arrayType -> arrayTypeBuilder $ fn arrayType
            T.TypeDictionary k v -> dictTypeBuilder (fn k) (fn v)
            T.TypeStructure ts -> foldl AppT (TupleT $ length ts) $ map fn ts

newNameDef :: String -> Q Name
newNameDef n =
  case n of
    "" -> newName "arg"
    "data" -> newName "arg"
    _ -> newName n

defaultGenerationParams :: GenerationParams
defaultGenerationParams =
  GenerationParams
  { genBusName = Nothing
  , genInterfaceName = fromString ""
  , getTHType = defaultGetTHType
  , genObjectPath = Nothing
  , genTakeSignalErrorHandler = False
  }

addTypeArg :: Type -> Type -> Type
addTypeArg argT = AppT (AppT ArrowT argT)

addTypeArgIf :: Bool -> Type -> Type -> Type
addTypeArgIf condition theType = if condition then addTypeArg theType else id

unitIOType :: Type
unitIOType = AppT (ConT ''IO) (TupleT 0)

addArgIf :: Bool -> a -> [a] -> [a]
addArgIf condition name = if condition then (name:) else id

mkFunD :: Name -> [Name] -> Exp -> Dec
mkFunD name argNames body =
  FunD name [Clause (map VarP argNames) (NormalB body) []]

generateClient :: GenerationParams -> I.Interface -> Q [Dec]
generateClient params
               I.Interface{ I.interfaceName = name
                          , I.interfaceProperties = properties
                          , I.interfaceMethods = methods
                          } =
  let params' = params { genInterfaceName = coerce name } in
  fmap concat <$> sequenceA $
                  map (generateClientMethod params') methods
                  ++
                  map (generateClientProperty params') properties

maybeName :: a -> Bool -> Maybe a
maybeName name condition = if condition then Just name else Nothing

makeToVariantApp :: Name -> Exp
makeToVariantApp name = AppE (VarE 'T.toVariant) $ VarE name

makeFromVariantApp :: Name -> Exp
makeFromVariantApp name = AppE (VarE 'T.fromVariant) $ VarE name

makeJustPattern :: Name -> Pat
makeJustPattern name = ConP 'Just [] [VarP name]

mapOrHead ::
  (Num a, Eq a) => a -> (t -> b) -> [t] -> ([b] -> b) -> b
mapOrHead outputLength fn names cons =
  case outputLength of
    1 -> fn $ head names
    _ -> cons $ map fn names

runGetFirst :: [Maybe a] -> Maybe a
runGetFirst options = getFirst $  mconcat $ map First options

buildGeneratedSignature :: Bool -> Bool -> Type -> Type
buildGeneratedSignature takeBusArg takeObjectPathArg =
  addTypeArg (ConT ''C.Client) . addTypeArgIf takeBusArg (ConT ''T.BusName) .
  addTypeArgIf takeObjectPathArg (ConT ''T.ObjectPath)

getSetMethodCallParams ::
  Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ
getSetMethodCallParams methodCallN mBusN mObjectPathN variantsE =
  case (mBusN, mObjectPathN) of
    (Just busN, Just objectPathN) -> [|
                       $( varE methodCallN )
                          { M.methodCallDestination = Just $( varE busN )
                          , M.methodCallPath = $( varE objectPathN )
                          , M.methodCallBody = $( variantsE )
                          }
                     |]
    (Just busN, Nothing) -> [|
                        $( varE methodCallN )
                          { M.methodCallDestination = Just $( varE busN )
                          , M.methodCallBody = $( variantsE )
                          }
                      |]
    (Nothing, Just objectPathN) -> [|
                        $( varE methodCallN )
                          { M.methodCallPath = $( varE objectPathN )
                          , M.methodCallBody = $( variantsE )
                          }
                      |]
    (Nothing, Nothing) -> [|
                         $( varE methodCallN ) { M.methodCallBody = $( variantsE ) }
                      |]

clientArgumentUnpackingMessage :: String
clientArgumentUnpackingMessage =
  "The client method could not unpack the message that was received."

clientArgumentUnpackingError :: [T.Variant] -> M.MethodError
clientArgumentUnpackingError variants =
  M.MethodError
  { M.methodErrorName = C.errorFailed
  , M.methodErrorSerial = T.Serial 0
  , M.methodErrorSender = Nothing
  , M.methodErrorDestination = Nothing
  , M.methodErrorBody = T.toVariant clientArgumentUnpackingMessage : variants
  }

generateClientMethod :: GenerationParams -> I.Method -> Q [Dec]
generateClientMethod GenerationParams
                       { getTHType = getArgType
                       , genInterfaceName = methodInterface
                       , genObjectPath = objectPathM
                       , genBusName = busNameM
                       }
                     I.Method
                       { I.methodArgs = args
                       , I.methodName = methodNameMN
                       } =
  do
    let (inputArgs, outputArgs) = partition ((== I.In) . I.methodArgDirection) args
        outputLength = length outputArgs
        buildArgNames = mapM (newNameDef . I.methodArgName) inputArgs
        buildOutputNames = mapM (newNameDef . I.methodArgName) outputArgs
        takeBusArg = isNothing busNameM
        takeObjectPathArg = isNothing objectPathM
        functionNameFirst:functionNameRest = coerce methodNameMN
        functionName = Char.toLower functionNameFirst:functionNameRest
        functionN = mkName $ Char.toLower functionNameFirst:functionNameRest
        methodCallDefN = mkName $ functionName ++ "MethodCall"
        defObjectPath = fromMaybe (fromString "/") objectPathM
    clientN <- newName "client"
    busN <- newName "busName"
    objectPathN <- newName "objectPath"
    methodCallN <- newName "methodCall"
    callResultN <- newName "callResult"
    replySuccessN <- newName "replySuccess"
    methodArgNames <- buildArgNames
    fromVariantOutputNames <- buildOutputNames
    finalOutputNames <- buildOutputNames
    let variantListExp = map makeToVariantApp methodArgNames
        mapOrHead' = mapOrHead outputLength
        fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames mkTupE
        finalResultTuple = mapOrHead' VarE finalOutputNames mkTupE
        maybeExtractionPattern = mapOrHead' makeJustPattern finalOutputNames TupP
        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 = getSetMethodCallParams methodCallDefN
                               (maybeName busN takeBusArg)
                               (maybeName objectPathN takeObjectPathArg)
                               (return $ ListE variantListExp)
        handleReplySuccess =
          if outputLength == 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 = [|
             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 = if outputLength == 0
                                         then WildP
                                         else VarP replySuccessN
    functionBody <- getFunctionBody
    methodCallDef <- getMethodCallDefDec
    let methodSignature = foldr addInArg fullOutputSignature inputArgs
        addInArg arg = addTypeArg $ getArgType $ I.methodArgType arg
        fullOutputSignature = AppT (ConT ''IO) $
                              AppT (AppT (ConT ''Either)
                                         (ConT ''M.MethodError))
                              outputSignature
        outputSignature =
          case outputLength of
            1 -> getArgType $ I.methodArgType $ head outputArgs
            _ -> foldl addOutArg (TupleT outputLength) outputArgs
        addOutArg target arg = AppT target $ getArgType $ I.methodArgType arg
        fullSignature = buildGeneratedSignature takeBusArg takeObjectPathArg methodSignature
        fullArgNames =
          clientN:addArgIf takeBusArg busN
                   (addArgIf takeObjectPathArg objectPathN methodArgNames)
        definitionDec = SigD functionN fullSignature
        function = mkFunD functionN fullArgNames functionBody
        methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall
    return $ methodCallSignature:methodCallDef ++ [definitionDec, function]

generateClientProperty :: GenerationParams -> I.Property -> Q [Dec]
generateClientProperty GenerationParams
                         { getTHType = getArgType
                         , genInterfaceName = propertyInterface
                         , genObjectPath = objectPathM
                         , genBusName = busNameM
                         }
                       I.Property
                         { I.propertyName = name
                         , I.propertyType = propType
                         , I.propertyRead = readable
                         , I.propertyWrite = writable
                         } =
  do
    clientN <- newName "client"
    busN <- newName "busName"
    objectPathN <- newName "objectPath"
    methodCallN <- newName "methodCall"
    argN <- newName "arg"
    let takeBusArg = isNothing busNameM
        takeObjectPathArg = isNothing objectPathM
        defObjectPath = fromMaybe (fromString "/") objectPathM
        methodCallDefN = mkName $ "methodCallFor" ++ name
        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 = getSetMethodCallParams methodCallDefN
                                   (maybeName busN takeBusArg)
                                   (maybeName objectPathN takeObjectPathArg)
                                   (return $ ListE [])
        makeGetterBody = [|
          do
            let $( varP methodCallN ) = $( setMethodCallParamsE )
            getPropertyValue $( return $ VarE clientN )
                             $( varE methodCallN )
          |]
        makeSetterBody = [|
          do
            let $( varP methodCallN ) = $( setMethodCallParamsE )
            setPropertyValue $( varE clientN ) $( varE methodCallN ) $( varE argN )
          |]
    methodCallDefs <- getMethodCallDefDec
    getterBody <- makeGetterBody
    setterBody <- makeSetterBody
    let buildSignature = buildGeneratedSignature takeBusArg takeObjectPathArg
        getterSigType =
          buildSignature $ AppT (ConT ''IO) $
                         AppT (AppT (ConT ''Either)
                                      (ConT ''M.MethodError)) $ getArgType propType
        setterSigType = buildSignature $ addTypeArg (getArgType propType) $
                        AppT (ConT ''IO) $ AppT (ConT ''Maybe) (ConT ''M.MethodError)
        buildArgs rest = clientN:addArgIf takeBusArg busN
                         (addArgIf takeObjectPathArg objectPathN rest)
        getterArgNames = buildArgs []
        setterArgNames = buildArgs [argN]
        propertyString = coerce name
        getterName = mkName $ "get" ++ propertyString
        setterName = mkName $ "set" ++ propertyString
        getterFunction = mkFunD getterName getterArgNames getterBody
        setterFunction = mkFunD setterName setterArgNames setterBody
        getterSignature = SigD getterName getterSigType
        setterSignature = SigD setterName setterSigType
        getterDefs = if readable then [getterSignature, getterFunction] else []
        setterDefs = if writable then [setterSignature, setterFunction] else []
        methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall
    return $ methodCallSignature:methodCallDefs ++ getterDefs ++ setterDefs

generateSignalsFromInterface :: GenerationParams -> I.Interface -> Q [Dec]
generateSignalsFromInterface params
                             I.Interface{ I.interfaceName = name
                                        , I.interfaceSignals = signals
                                        } = generateSignals params name signals

generateSignals :: GenerationParams -> T.InterfaceName -> [I.Signal] -> Q [Dec]
generateSignals params name signals =
  fmap concat <$> sequenceA $
                map (generateSignal params { genInterfaceName = coerce name })
                    signals

generateSignal :: GenerationParams -> I.Signal -> Q [Dec]
generateSignal GenerationParams
                 { getTHType = getArgType
                 , genInterfaceName = signalInterface
                 , genObjectPath = objectPathM
                 , genBusName = busNameM
                 , genTakeSignalErrorHandler = takeErrorHandler
                 }
               I.Signal
                 { I.signalName = name
                 , I.signalArgs = args
                 } =
  do
    let buildArgNames = mapM (newNameDef . I.signalArgName) args

    argNames <- 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 = map makeToVariantApp argNames
        signalString = coerce name
        signalDefN = mkName $ "signalFor" ++ signalString
        takeObjectPathArg = isNothing objectPathM
        defObjectPath = fromMaybe (fromString "/") objectPathM
        argCount = length argNames
        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' = mapOrHead argCount
        fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames mkTupE
        maybeExtractionPattern = mapOrHead' makeJustPattern toHandlerOutputNames TupP
        applyToName toApply n = AppE toApply $ VarE n
        finalApplication = foldl applyToName (VarE handlerArgN)
                           (receivedSignalN:toHandlerOutputNames)
        makeHandlerN = mkName $ "makeHandlerFor" ++ signalString
        makeHandlerCall =
          if takeErrorHandler
          then AppE base (VarE errorHandlerN)
          else base
            where base = AppE (VarE makeHandlerN) (VarE handlerArgN)
        getSetSignal  =
          if takeObjectPathArg
          then [|
                  $( varE signalDefN )
                     { M.signalPath = $( varE objectPathN )
                     , M.signalBody = $( varE variantsN )
                     }
                 |]
          else [| $( varE signalDefN )
                  { M.signalBody = $( varE variantsN ) }
                |]
        getEmitBody = [|
          let $( varP variantsN ) = $( return $ ListE variantListExp )
              $( varP signalN ) = $( getSetSignal )
          in
            emit $( varE clientN ) $( varE signalN )
          |]
        getErrorHandler =
          if takeErrorHandler then
            [| $( varE errorHandlerN  ) $( varE receivedSignalN )|]
          else [| return () |]
        getMakeHandlerBody =
          if argCount == 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 = [|
          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 )
            |]
    registerBody <- getRegisterBody
    makeHandlerBody <- getMakeHandlerBody
    signalDef <- getSignalDefDec
    emitBody <- getEmitBody
    let methodSignature = foldr addInArg unitIOType args
        addInArg arg = addTypeArg $ getArgType $ I.signalArgType arg
        fullArgNames = clientN:addArgIf takeObjectPathArg objectPathN argNames
        -- Never take bus arg because it is set automatically anyway
        fullSignature =
            buildGeneratedSignature False takeObjectPathArg methodSignature
        functionN = mkName $ "emit" ++ signalString
        emitSignature = SigD functionN fullSignature
        emitFunction = mkFunD functionN fullArgNames emitBody
        handlerType = addTypeArg (ConT ''M.Signal) methodSignature
        errorHandlerType = addTypeArg (ConT ''M.Signal) unitIOType
        registerN = mkName $ "registerFor" ++ signalString
        registerArgs = clientN:matchRuleArgN:handlerArgN:
                       addArgIf takeErrorHandler errorHandlerN []
        registerFunction = mkFunD registerN registerArgs registerBody
        registerType =
          addTypeArg (ConT ''C.Client) $
          addTypeArg (ConT ''C.MatchRule) $
          addTypeArg handlerType $
          addTypeArgIf takeErrorHandler (addTypeArg (ConT ''M.Signal) unitIOType) $
          AppT (ConT ''IO) (ConT ''C.SignalHandler)
        registerSignature = SigD registerN registerType
        makeHandlerArgs =
          handlerArgN:addArgIf takeErrorHandler errorHandlerN [receivedSignalN]
        makeHandlerFunction = mkFunD makeHandlerN makeHandlerArgs makeHandlerBody
        makeHandlerType = addTypeArg handlerType $
                          addTypeArgIf takeErrorHandler errorHandlerType $
                          addTypeArg (ConT ''M.Signal) unitIOType
        makeHandlerSignature = SigD makeHandlerN makeHandlerType
        signalSignature = SigD signalDefN (ConT ''M.Signal)
    return $ signalSignature:
           signalDef ++ [ emitSignature, emitFunction
                        , makeHandlerSignature, makeHandlerFunction
                        , registerSignature, registerFunction
                        ]

generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]
generateFromFilePath generationParams filepath = do
    xml <- runIO $ Text.readFile filepath
    let obj = head $ maybeToList $ I.parseXML "/" xml
        interface = head $ I.objectInterfaces obj
        signals = generateSignalsFromInterface generationParams interface
        client = generateClient generationParams interface
     in fmap (++) signals <*> client