module TXML
  (
    initialize
  , uninitialize
  , sendCommand
  , setCallback
  , freeCallback
  , Callback
  , LogLevel(..)
  ) where

import qualified Data.ByteString.Char8    as BS
import qualified Data.Text                as T
import           Data.Text.Encoding
import           Data.Text.Encoding.Error
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.Ptr

foreign import ccall "Initialize" c_Initialize :: CString -> CInt -> IO CString
foreign import ccall "UnInitialize" c_UnInitialize :: IO CString
foreign import ccall "SendCommand" c_SendCommand :: CString -> IO CString
foreign import ccall "SetCallback" c_SetCallback ::
  FunPtr (CString -> IO CBool) -> IO CBool
foreign import ccall "FreeMemory" c_FreeMemory :: CString -> IO CBool

{-
foreign import ccall "SetLogLevel" c_SetLogLevel :: CInt -> IO CString
foreign import ccall "SetCallbackEx" c_SetCallbackEx ::
  FunPtr (CString -> CBool) -> Ptr () -> IO CBool
-}

foreign import ccall "wrapper" createCallbackPtr ::
  (CString -> IO CBool) -> IO (FunPtr (CString -> IO CBool))

data LogLevel =
    Debug
  | Info
  | Warning
  deriving (Show, Eq, Ord)

newtype Callback = Callback { unCallback :: FunPtr (CString  -> IO CBool)}

logLevelToInt :: LogLevel -> CInt
logLevelToInt Debug   = 3
logLevelToInt Info    = 2
logLevelToInt Warning = 1

strErrorStringToResult :: CString -> IO (Either T.Text ())
strErrorStringToResult str =
  if nullPtr /= str
    then do
      packed <- BS.packCString str
      let result = decodeUtf8With lenientDecode $ packed
      _ <- c_FreeMemory str
      pure $ Left result
    else
      pure $ Right ()

rawStringToResult :: CString -> IO (Either T.Text ())
rawStringToResult str =
  if nullPtr /= str
    then do
      packed <- BS.packCString str
      let result = decodeUtf8With lenientDecode $ packed
      _ <- c_FreeMemory str
      if "<result success=\"true\"/>" `T.isPrefixOf` result
        then pure $ Right ()
        else pure $ Left result
    else
      pure $ Left ""

initialize :: FilePath -> LogLevel -> IO (Either T.Text ())
initialize fp loglevel =
  BS.useAsCString (encodeUtf8 . T.pack $ fp) $ \fpcstr ->
    c_Initialize fpcstr (logLevelToInt loglevel) >>= strErrorStringToResult

uninitialize :: IO (Either T.Text ())
uninitialize = c_UnInitialize >>= rawStringToResult

sendCommand :: T.Text -> IO (Either T.Text ())
sendCommand cmdData = do
  BS.useAsCString (encodeUtf8 cmdData) $ \fpcstr ->
    c_SendCommand fpcstr >>= rawStringToResult

setCallback :: (T.Text -> IO Bool) -> IO (Maybe Callback)
setCallback callback = do
  wrappedCallback <- createCallbackPtr (\x -> do
                                           packed <- BS.packCString x
                                           boolToCBool <$> (callback $
                                             decodeUtf8With lenientDecode
                                               packed))
  ret <- c_SetCallback wrappedCallback
  if ret /= 0
    then return . Just . Callback $ wrappedCallback
    else do
      freeHaskellFunPtr wrappedCallback
      return Nothing
  where
    boolToCBool False = 0
    boolToCBool True  = 1

freeCallback :: Callback -> IO ()
freeCallback = freeHaskellFunPtr . unCallback