module Speech.Recognition.NuanceRecognizer9.Core 
    where

import Speech.Recognition.NuanceRecognizer9.C2HS

import Control.Monad (liftM)
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable

#include "SWIepAPI.h"
#include "SWIrecAPI.h"

{#context prefix = "SWI"#}

--
-- * Recognizer API
--

-- FIXME: c2hs should produce Storable instances

{#pointer *SWIrecRecognizer as RecRecognizer newtype #}

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


{#pointer *SWIrecAudioSamples as RecAudioSamples newtype #}

{#pointer *SWIrecResultData as RecResultData newtype #}

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


{#enum recFuncResult as RecFuncResult {underscoreToCase} deriving (Eq,Show)#}

{#enum recStopCode as RecStopCode {underscoreToCase} deriving (Eq,Show)#}

{#enum recRecognizerStatus as RecRecognizerStatus {underscoreToCase} deriving (Eq,Show)#}

{#enum recResultType as RecResultType {underscoreToCase} deriving (Eq,Show)#}

data RecGrammarData = 
      RecGrammarURI {
                     recGrammarURI :: String,
                     recGrammarMediaType :: String
                    }
    | RecGrammarData {
                      recGrammarData :: String,
                      recGrammarMediaType :: String
                     }

-- | Audio sample status. 
type RecSampleStatus = [RecSampleFlag]

data RecSampleFlag = RecSampleFirst
                   | RecSampleContinue
                   | RecSampleLast
                   | RecSampleSuppressed
                   | RecSampleLost
                   | RecSampleNewChunk
                   | RecSampleEndChunk
  deriving (Eq,Show,Bounded)

instance Enum RecSampleFlag where
    succ = toEnum . (* 2) . fromEnum
    pred = toEnum . (`div` 2) . fromEnum

    fromEnum RecSampleFirst      = 0x01
    fromEnum RecSampleContinue   = 0x02
    fromEnum RecSampleLast       = 0x04
    fromEnum RecSampleSuppressed = 0x08
    fromEnum RecSampleLost       = 0x10
    fromEnum RecSampleNewChunk   = 0x20
    fromEnum RecSampleEndChunk   = 0x40

    toEnum 0x01 = RecSampleFirst
    toEnum 0x02 = RecSampleContinue
    toEnum 0x04 = RecSampleLast
    toEnum 0x08 = RecSampleSuppressed
    toEnum 0x10 = RecSampleLost
    toEnum 0x20 = RecSampleNewChunk
    toEnum 0x40 = RecSampleEndChunk
    toEnum x    = error $ "Bad RecSampleFlag: " ++ show x

    enumFrom        = boundedEnumFrom

    enumFromThen    = boundedEnumFromThen

    enumFromTo      = defaultEnumFromTo

    -- FIXME: can we make a sensible default for this?
    -- we don't use it though
    enumFromThenTo = error "RecSampleFlag:enumFromThenTo"

boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]
boundedEnumFrom x = enumFromTo x maxBound

boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]
boundedEnumFromThen x y = enumFromThenTo x y bound
        where
          bound | fromEnum y >= fromEnum x = maxBound
	        | otherwise                = minBound

defaultEnumFromTo :: Enum a => a -> a -> [a]
defaultEnumFromTo x y | x' > y'   = []
                      | otherwise = stop $ iterate succ x
       where x' = fromEnum x
             y' = fromEnum y
             stop [] = []
             stop (e:es) = case compare (fromEnum e) y' of
                             LT -> e : stop es
                             EQ -> [e]
                             GT -> error $ "defaultEnumFromTo: "
                                            ++ show (fromEnum e) 
                                            ++ " > " ++ show y'



-- FIXME: SWIrecAcousticStateLoad
-- FIXME: SWIrecAcousticStateQuerySize

{#fun recAcousticStateReset
  { id `RecRecognizer' }
 -> `()' result*- #} 
 where result = recCheckResult "recAcousticStateReset"

-- FIXME: SWIrecAcousticStateSave


{#fun recAudioWrite
  { id `RecRecognizer', 
    id `RecAudioSamples' } 
 -> `()' result*- #} 
 where result = recCheckResult "recAudioWrite"

-- FIXME: SWIrecGetWaveform

{#fun recGetXMLResult
  { id `RecResultData',
    withCWString'* `String',
    alloca- `String' peekPeekCWString'*
    }
 -> `()' result*- #} 
 where result = recCheckResult "recGetXMLResult"

{#fun recGrammarActivate
 { id `RecRecognizer',
   withRecGrammarData* `RecGrammarData',
   `Int',
   `String'} 
 -> `()' result*- #} 
 where result = recCheckResult "recGrammarActivate"

-- FIXME: SWIrecGrammarCompile

{#fun recGrammarDeactivate
  { id `RecRecognizer',
    withRecGrammarData* `RecGrammarData' }
 -> `()' result*- #} 
 where result = recCheckResult "recGrammarDeactivate"

{#fun recGrammarFree
  { id `RecRecognizer',
    withRecGrammarData* `RecGrammarData' }
 -> `()' result*- #} 
 where result = recCheckResult "recGrammarFree"

{#fun recGrammarLoad
  { id `RecRecognizer',
    withRecGrammarData* `RecGrammarData' }
 -> `()' result*- #} 
 where result = recCheckResult "recGrammarLoad"


{#fun recInit
   { withMaybeCWString'* `Maybe FilePath' }
 -> `()' result*- #} 
 where result = recCheckResult "recInit"


-- FIXME: SWIrecLogEvent
-- FIXME: SWIrecParseDTMFResults

data MaxComputeTime = ComputeForever
                    | ComputeMaxMS Int
   deriving (Eq,Show)



{#fun recRecognizerCompute
  {id `RecRecognizer',
   maxComputeTimeToInt `MaxComputeTime',
   alloca- `RecRecognizerStatus' peekEnum*,
   alloca- `RecResultType' peekEnum*,
   alloca- `RecResultData' peek*
  }
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerCompute"
       maxComputeTimeToInt ComputeForever    = (-1)
       maxComputeTimeToInt (ComputeMaxMS ms) = cIntConv ms

{#fun recRecognizerCreate
 { alloca- `RecRecognizer' peek*,
   withNullPtr- `Ptr ()',
   withNullPtr- `Ptr ()'}
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerCreate"

{#fun recRecognizerDestroy
  { id `RecRecognizer'}
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerDestroy"

{#fun recRecognizerGetParameter
  { id `RecRecognizer',
    withCWString'* `String',
    allocaParameterBuf- `String' peekCWString'*, -- FIXME: should be peekCWStringLen
    allocaParameterBufLen- `Int'
  }
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerGetParameter"

{#fun recRecognizerSetParameter
  {id `RecRecognizer',
   withCWString'* `String',
   withCWString'* `String'}
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerSetParameter"

{#fun recRecognizerStart
  { id `RecRecognizer'}
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerStart"

{#fun recRecognizerStop
  { id `RecRecognizer',
    cFromEnum `RecStopCode'}
 -> `()' result*- #} 
 where result = recCheckResult "recRecognizerStop"

{#fun recSessionEnd
  { id `RecRecognizer'}
 -> `()' result*- #} 
 where result = recCheckResult "recSessionEnd"

{#fun recSessionStart
  { id `RecRecognizer',
    withCWString'* `String',
    withMaybeCWString'* `Maybe String'}
 -> `()' result*- #} 
 where result = recCheckResult "recSessionStart"

{#fun recTerminate
 {}
 -> `()' result*- #} 
 where result = recCheckResult "recTerminate"

{#fun recThreadCleanup
 {}
 -> `()' result*- #} 
 where result = recCheckResult "recThreadCleanup"

--
-- ** Error handling
--

recCheckResult :: String -> CInt -> IO ()
recCheckResult f r = 
    case cToEnum r of
      RecSuccess -> return ()
      -- FIXME: use throwDyn?
      e -> fail $ f ++ " failed: " ++ show e


--
-- * Speech Detector API
--

{#pointer *SWIepDetector as EpDetector newtype #}

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

{#enum epFuncResult as EpFuncResult {underscoreToCase} deriving (Eq,Show)#}

{#enum epState as EpState {underscoreToCase} deriving (Eq,Show)#}

{#enum epStopCode as EpStopCode {underscoreToCase} deriving (Eq,Show)#}

{#pointer *SWIepAudioSamples as EpAudioSamples newtype #}

-- FIXME: SWIepAcousticStateLoad
-- FIXME: SWIepAcousticStateQuerySize

{#fun epAcousticStateReset
  { id `EpDetector' }
 -> `()' result*- #}
 where result = epCheckResult "epAcousticStateReset"

-- FIXME: SWIepAcousticStateSave

{#fun epDetectorCreate
 { alloca- `EpDetector' peek* }
 -> `()' result*- #}
 where result = epCheckResult "epDetectorCreate"

{#fun epDetectorDestroy
  { id `EpDetector' }
 -> `()' result*- #}
 where result = epCheckResult "epDetectorDestroy"


{#fun epGetParameter
  { id `EpDetector',
    withCWString'* `String',
    allocaParameterBuf- `String' peekCWString'*, -- FIXME: should be peekCWStringLen
    allocaParameterBufLen- `Int'
  }
 -> `()' result*- #}
 where result = epCheckResult "epGetParameter"

{#fun epInit
  {}
 -> `()' result*- #}
 where result = epCheckResult "epInit"

{#fun epPromptDone
  { id `EpDetector' }
 -> `()' result*- #}
 where result = epCheckResult "epPromptDone"

{#fun epRead
  { id `EpDetector',
    id `RecAudioSamples',
    alloca- `EpState' peekEnum*,
    `Int' }
 -> `()' result*- #}
 where result = epCheckResult "epRead"


{#fun epSessionEnd
  { id `EpDetector' }
 -> `()' result*- #}
 where result = epCheckResult "epSessionEnd"

{#fun epSessionStart
  { id `EpDetector',
    withCWString'* `String',
    withMaybeCWString'* `Maybe String'}
 -> `()' result*- #}
 where result = epCheckResult "epSessionStart"

{#fun epSetParameter
  {id `EpDetector',
   withCWString'* `String',
   withCWString'* `String'}
 -> `()' result*- #}
 where result = epCheckResult "epSetParameter"

{#fun epStart
  { id `EpDetector' }
 -> `()' result*- #}
 where result = epCheckResult "epStart"

{#fun epStop
  { id `EpDetector',
    cFromEnum `EpStopCode',
    withMaybeCWString'* `Maybe String'
  }
 -> `()' result*- #}
 where result = epCheckResult "epStop"

{#fun epTerminate
  {}
 -> `()' result*- #}
 where result = epCheckResult "epTerminate"

{#fun epWrite
  { id `EpDetector',
    id `EpAudioSamples',
    alloca- `EpState' peekEnum*,
    alloca- `Int' peekIntConv*,
    alloca- `Int' peekIntConv*}
 -> `()' result*- #}
 where result = epCheckResult "epWrite"


--
-- ** Error handling
--

epCheckResult :: String -> CInt -> IO ()
epCheckResult f r = 
    case cToEnum r of
      EpResultSuccess -> return ()
      -- FIXME: use throwDyn?
      e -> fail $ f ++ " failed: " ++ show e


--
-- * Marshalling functions
--

-- NOTE: the CWString' functions shouldn't really be
-- needed. c2hs should use the CWChar type for wchar_t.

peekCWString' :: Integral a => Ptr a -> IO String
peekCWString' = peekCWString . castPtr

peekPeekCWString' :: Integral a => Ptr (Ptr a) -> IO String
peekPeekCWString' p = peek p >>= peekCWString'

withCWString' :: Integral a => String -> (Ptr a -> IO b) -> IO b
withCWString' s f = withCWString s (f . castPtr)

withMaybeCWString' :: Integral a => Maybe String -> (Ptr a -> IO b) -> IO b
withMaybeCWString' = maybe withNullPtr withCWString'

withNullPtr :: (Ptr a -> IO b) -> IO b
withNullPtr f = f nullPtr

parameterBufLen :: Integral a => a
parameterBufLen = 4096

-- FIXME: should be Ptr CWchar
allocaParameterBuf :: Integral a => (Ptr a -> IO b) -> IO b
allocaParameterBuf = allocaBytes parameterBufLen

allocaParameterBufLen :: (Ptr CUInt -> IO a) -> IO a
allocaParameterBufLen f = alloca $ \p -> poke p parameterBufLen >> f p



withRecGrammarData :: RecGrammarData -> (Ptr () -> IO a) -> IO a
withRecGrammarData d@(RecGrammarURI {}) f
    = withCWString "uri/2.0" $ \t ->
      withCWString (recGrammarURI d) $ \u ->
      withCWString (recGrammarMediaType d) $ \mt ->
      allocaBytes {#sizeof SWIrecGrammarData#} $ \p -> 
          do assign_SWIrecGrammarData p t u nullPtr mt nullPtr 0
             f p
withRecGrammarData d@(RecGrammarData {}) f
    = withCWString "string/2.0" $ \t ->
      -- should binary_data contain char or wchar?
      withCStringLen (recGrammarData d) $ \(bd,l) ->
      withCWString (recGrammarMediaType d) $ \mt ->
      allocaBytes {#sizeof SWIrecGrammarData#} $ \p -> 
          do assign_SWIrecGrammarData p t nullPtr nullPtr  mt (castPtr bd) (fromIntegral l)
             f p

foreign import ccall "swi_rec_extras.h assign_SWIrecGrammarData" assign_SWIrecGrammarData 
    :: Ptr () -> CWString -> CWString -> Ptr () -> CWString -> Ptr () -> CUInt -> IO ()


--
-- * RecAudioSamples stuff
--

recAudioSamplesLen :: RecAudioSamples -> IO Int
recAudioSamplesLen (RecAudioSamples p) = 
    liftM fromIntegral $ {#get SWIrecAudioSamples->len#} p

recAudioSamplesStatus :: RecAudioSamples -> IO RecSampleStatus
recAudioSamplesStatus (RecAudioSamples p) = 
    liftM extractBitMasks $ {#get SWIrecAudioSamples->status#} p

recAudioSamplesBuf :: RecAudioSamples -> IO (Ptr ())
recAudioSamplesBuf (RecAudioSamples p) = {#get SWIrecAudioSamples->samples#} p


allocaRecAudioSamples :: (RecAudioSamples -> IO a) -> IO a
allocaRecAudioSamples f = allocaBytes {#sizeof SWIrecAudioSamples#} (f . RecAudioSamples)

withRecAudioSamples :: Int -- ^ Buffer size in bytes.
                    -> String -- ^ Media type.
                    -> RecSampleStatus -- ^ Sample status.
                    -> (RecAudioSamples -> IO a) -> IO a
withRecAudioSamples len t s f = 
    allocaRecAudioSamples $ \r ->
    allocaBytes len $ \buf ->
    withCWString t $ \ct ->
        do assign_SWIrecAudioSamples r buf (fromIntegral len) ct (combineBitMasks s)
           f r

foreign import ccall "swi_rec_extras.h assign_SWIrecAudioSamples" assign_SWIrecAudioSamples 
    :: RecAudioSamples -> Ptr () -> CUInt -> CWString -> CInt -> IO ()

--
-- * EpAudioSamples stuff
--

-- NOTE: this seems to be identical to the recAudioSamples stuff

epAudioSamplesLen :: EpAudioSamples -> IO Int
epAudioSamplesLen (EpAudioSamples p) = 
    liftM fromIntegral $ {#get SWIepAudioSamples->len#} p

epAudioSamplesLenSet :: EpAudioSamples -> Int -> IO ()
epAudioSamplesLenSet (EpAudioSamples p) l = {#set SWIepAudioSamples->len#} p (fromIntegral l)

epAudioSamplesStatus :: EpAudioSamples -> IO RecSampleStatus
epAudioSamplesStatus (EpAudioSamples p) = 
    liftM extractBitMasks $ {#get SWIepAudioSamples->status#} p

epAudioSamplesStatusSet :: EpAudioSamples -> RecSampleStatus -> IO ()
epAudioSamplesStatusSet (EpAudioSamples p) = 
    {#set SWIepAudioSamples->status#} p . combineBitMasks

epAudioSamplesBuf :: EpAudioSamples -> IO (Ptr ())
epAudioSamplesBuf (EpAudioSamples p) = {#get SWIepAudioSamples->samples#} p

allocaEpAudioSamples :: (EpAudioSamples -> IO a) -> IO a
allocaEpAudioSamples f = allocaBytes {#sizeof SWIepAudioSamples#} (f . EpAudioSamples)

withEpAudioSamples :: Int -- ^ Buffer size in bytes.
                   -> String -- ^ Media type.
                   -> RecSampleStatus -- ^ Sample status.
                   -> (EpAudioSamples -> IO a) -> IO a
withEpAudioSamples len t s f = 
    allocaEpAudioSamples $ \r ->
    allocaBytes len $ \buf ->
    withCWString t $ \ct ->
        do assign_SWIepAudioSamples r buf (fromIntegral len) ct (combineBitMasks s)
           f r

foreign import ccall "swi_rec_extras.h assign_SWIepAudioSamples" assign_SWIepAudioSamples 
    :: EpAudioSamples -> Ptr () -> CUInt -> CWString -> CInt -> IO ()