module Speech.Synthesis.RealSpeak4.Core 
    where

import Speech.Synthesis.RealSpeak4.C2HS

import Control.Exception (bracket)
import Control.Monad (liftM, unless)
import Data.List (genericLength)
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable

#include "lh_ttsso.h"

{#enum LIST_OF_ERRORS as TtsRetVal {underscoreToCase} with prefix = "" deriving (Eq,Show)#}

{#pointer HTTSINSTANCE as TtsInstance newtype #}

instance Storable TtsInstance where
    sizeOf (TtsInstance r) = sizeOf r
    alignment (TtsInstance r) = alignment r
    peek p = fmap TtsInstance (peek (castPtr p))
    poke p (TtsInstance r) = poke (castPtr p) r

{#pointer *LH_SDK_SERVER as LhSdkServer newtype #}
{#pointer *TTSPARM as TtsParm newtype #}
{#pointer *SpeakData newtype #}

{#fun TtsInitializeEx as initializeEx 
 { alloca- `TtsInstance' peek*,
   idMaybe `Maybe LhSdkServer',
   id `TtsParm',
   id `Ptr ()' }
 -> `()' result*- #}
  where result = checkResult "TtsInitializeEx"
	idMaybe = maybe (LhSdkServer nullPtr) id

{#fun TtsProcessEx as processEx
  { id `TtsInstance',
    id `SpeakData' }
 -> `()' result*- #}
  where result = checkResult "TtsProcessEx"

{#fun TtsUninitialize as uninitialize
   { id `TtsInstance' }
 -> `()' result*- #}
  where result = checkResult "TtsUninitialize"

{#fun TtsStop as stop
   { id `TtsInstance' }
 -> `()' result*- #}
  where result = checkResult "TtsStop"

--
-- * TTSPARM stuff
--

-- FIXME: hacky to use deriving Enum
data TtsFrequency = TtsFreq8KHz
                  | TtsFreq11KHz
                  | TtsFreq22KHz
  deriving (Eq,Show,Enum) 

-- FIXME: hacky to use deriving Enum
data TtsOutputType = TtsLinear16Bit
                   | TtsMuLaw8Bit
                   | TtsALaw8Bit
  deriving (Eq,Show,Enum) 

-- FIXME: hacky to use deriving Enum
data TtsDataType = TtsDataTypePcm
                 | TtsDataTypeAcv
                 | TtsDataTypeText
    deriving (Eq,Show,Enum)



type TtsSourceCb = Ptr () -- app data
                 -> Ptr () -- data buffer to write to
                 -> {#type LH_U32#} -- data buffer size
                 -> Ptr {#type LH_U32#} -- number of bytes written
                 -> IO {#type LH_S32#} -- return TTS_SUCCESS or TTS_ENDOFDATA

type TtsDestCb = Ptr () -- app data
               -> {#type LH_U16#} -- data type being delivered
               -> Ptr () -- output data buffer
               -> {#type LH_U32#} -- size of output buffer
               -> Ptr {#type LH_U32#} -- size of returned buffer
               -> IO (Ptr ())

type TtsEventCb = Ptr () -- app data
                -> Ptr () -- event data
                -> {#type LH_U16#} -- size of event data buffer
                -> {#type LH_U16#} -- event type
                -> IO {#type LH_S32#} -- return TTS_SUCCESS




-- | The 'TtsParm' must not be freed until after
-- 'uninitializeEx' has been called.
mallocTtsParm :: IO TtsParm
mallocTtsParm = do p <- mallocBytes {#sizeof TTSPARM#}
                   clearBytes p {#sizeof TTSPARM#}
                   return (TtsParm p)

freeTtsParm :: TtsParm -> IO ()
freeTtsParm (TtsParm p) =
    do {#get TTSPARM->szLibLocation#}       p >>= freeIfNonNull
       {#get TTSPARM->szLanguageString#}    p >>= freeIfNonNull
       {#get TTSPARM->szVoiceString#}       p >>= freeIfNonNull
       {#get TTSPARM->cbFuncs.TtsSourceCb#} p >>= freeFunIfNonNull
       {#get TTSPARM->cbFuncs.TtsDestCb#}   p >>= freeFunIfNonNull
       {#get TTSPARM->cbFuncs.TtsEventCb#}  p >>= freeFunIfNonNull
       free p

-- FIXME: make enum
setLanguage :: {#type LH_U16#} -> TtsParm -> IO ()
setLanguage x (TtsParm p) = {#set TTSPARM->nLanguage#} p x

setLanguageString :: String -> TtsParm -> IO ()
setLanguageString x (TtsParm p) = 
    do {#set TTSPARM->nLanguage#} p 9999 -- FIXME: TTS_LANG_USE_STRING
       newCString x >>= {#set TTSPARM->szLanguageString#} p

setVoiceString :: String -> TtsParm -> IO ()
setVoiceString x (TtsParm p) = 
    do {#set TTSPARM->nVoice#} p 9999 -- FIXME: TTS_VOICE_USE_STRING
       newCString x >>= {#set TTSPARM->szVoiceString#} p

setOutputType :: TtsOutputType -> TtsParm -> IO ()
setOutputType x (TtsParm p) = {#set TTSPARM->nOutputType#} p (cFromEnum x)

setFrequency :: TtsFrequency -> TtsParm -> IO ()
setFrequency x (TtsParm p) = {#set TTSPARM->nFrequency#} p (cFromEnum x)

setLibLocation :: FilePath -> TtsParm -> IO ()
setLibLocation f (TtsParm p) = 
    do x <- {#get TTSPARM->szLibLocation#} p
       freeIfNonNull x
       s <- newCString f
       {#set TTSPARM->szLibLocation#} p s

setOutputDataType :: TtsDataType -> TtsParm -> IO ()
setOutputDataType t (TtsParm p) = {#set TTSPARM->nOutputDataType#} p (cFromEnum t)

setInputDataType :: TtsDataType -> TtsParm -> IO ()
setInputDataType t (TtsParm p) = {#set TTSPARM->nInputDataType#} p (cFromEnum t)

freeIfNonNull :: Ptr a -> IO ()
freeIfNonNull p = unless (p == nullPtr) $ free p

freeFunIfNonNull :: FunPtr a -> IO ()
freeFunIfNonNull p = unless (p == nullFunPtr) $ freeHaskellFunPtr p


-- FIXME: free old function pointers, if any
setCbFuncs :: Maybe TtsSourceCb -> TtsDestCb -> Maybe TtsEventCb -> TtsParm -> IO ()
setCbFuncs msrc dest mev (TtsParm p) = 
    do
    {#set TTSPARM->cbFuncs.numCallbacks#} p 3
    maybe (return nullFunPtr) mkTtsSourceCb msrc 
              >>= {#set TTSPARM->cbFuncs.TtsSourceCb#} p
    mkTtsDestCb dest
              >>= {#set TTSPARM->cbFuncs.TtsDestCb#} p
    maybe (return nullFunPtr) mkTtsEventCb mev
              >>= {#set TTSPARM->cbFuncs.TtsEventCb#} p

foreign import ccall "wrapper"
   mkTtsSourceCb :: TtsSourceCb -> IO (FunPtr TtsSourceCb)

foreign import ccall "wrapper"
   mkTtsDestCb :: TtsDestCb -> IO (FunPtr TtsDestCb)

foreign import ccall "wrapper"
   mkTtsEventCb :: TtsEventCb -> IO (FunPtr TtsEventCb)



--
-- * SpeakData
--


withSpeakData :: (SpeakData -> IO a) -> IO a
withSpeakData = bracket mallocSpeakData freeSpeakData

mallocSpeakData :: IO SpeakData
mallocSpeakData = 
    do p <- mallocBytes {#sizeof SpeakData#}
       clearBytes p {#sizeof SpeakData#}
       return (SpeakData p)

-- FIXME: free fetchProperties?
freeSpeakData :: SpeakData -> IO ()
freeSpeakData (SpeakData p) =
    do {#get SpeakData->uri#} p >>= freeIfNonNull
       {#get SpeakData->data#} p >>= freeIfNonNull
       {#get SpeakData->contentType#} p >>= freeIfNonNull
       free p

setSpeakData :: String -- ^ Content-type
             -> [Word8] -- ^ Data
             -> SpeakData -> IO ()
setSpeakData t s (SpeakData p) =
    do newCString t >>= {#set SpeakData->contentType#} p
       cs <- newArray s
       {#set SpeakData->data#} p (castPtr cs)
       {#set SpeakData->lengthBytes#} p (genericLength s)

-- FIXME: add setSpeakUri


--
-- * Error handling
--

checkResult :: String -> {#type LH_S32#} -> IO ()
checkResult f r = 
    case cToEnum r of
      TtsSuccess -> return ()
      -- FIXME: use throwDyn?
      e -> fail $ f ++ " failed: " ++ show e

--
-- * Marshalling utilities
--

callocaBytes :: Int -> (Ptr a -> IO b) -> IO b
callocaBytes n f = allocaBytes n (\p -> clearBytes p n >> f p)

clearBytes :: Ptr a -> Int -> IO ()
clearBytes p n = memset p 0 (fromIntegral n) >> return ()

foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)