{-# LINE 1 "src/Sound/Pulse/Mainloop.hsc" #-}
{-
{-# LINE 2 "src/Sound/Pulse/Mainloop.hsc" #-}
    Copyright 2016 Markus Ongyerth

    This file is part of pulseaudio-hs.

    Monky is free software: you can redistribute it and/or modify
    it under the terms of the GNU Lesser General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    Monky is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License
    along with pulseaudio-hs.  If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module      : Sound.Pulse.Mainloop
Description : Provides a class and wrapper type for Mainloop abstraction
Maintianer  : ongy
Stability   : experimental

This module provides Haskell abstractions over the pulse mainloop-api <https://freedesktop.org/software/pulseaudio/doxygen/mainloop-api_8h.html>.

There is also a simple implementation for this in 'Sound.Pulse.Mainloop.Simple'.
-}
module Sound.Pulse.Mainloop
    ( PAMainloop(..)
    , PAIOEventFlags(..)
    , PAMainloopApi
    , getMainloopApi

    )
where

import Sound.Pulse.Userdata


{-# LINE 47 "src/Sound/Pulse/Mainloop.hsc" #-}

{-# LINE 48 "src/Sound/Pulse/Mainloop.hsc" #-}

import Control.Applicative ((<$>), (<*>))
import Foreign.Marshal.Utils (with)
import Foreign.Storable
import Foreign.StablePtr
import Foreign.Ptr
import Foreign.C.Types
import System.Posix.Types (Fd(..))

import Data.Bits ((.&.), (.|.))

import Control.Concurrent.MVar

import Data.Time
import Data.Time.Internal

-- |Events that 'PAIOEvent's may wait for.
-- At my current level of testing, it looks like libpulse only uses Input (and
-- I guess output when writing to the server)
data PAIOEventFlags
    = PAIOEventNull -- ^No Event (this is for compatibility, should never show up)
    | PAIOEventInput -- ^Fd went ready for reading
    | PAIOEventOutput -- ^Fd went ready for writing
    | PAIOEventHangup -- ^Fd got a hangup (see poll documentation)
    | PAIOEventError -- ^Fd got an error (see poll documentation)
    deriving (Eq, Show)

-- |Internal function for conversion
ioEventToCInt :: PAIOEventFlags -> CInt
ioEventToCInt PAIOEventNull   = 0
{-# LINE 78 "src/Sound/Pulse/Mainloop.hsc" #-}
ioEventToCInt PAIOEventInput  = 1
{-# LINE 79 "src/Sound/Pulse/Mainloop.hsc" #-}
ioEventToCInt PAIOEventOutput = 2
{-# LINE 80 "src/Sound/Pulse/Mainloop.hsc" #-}
ioEventToCInt PAIOEventHangup = 4
{-# LINE 81 "src/Sound/Pulse/Mainloop.hsc" #-}
ioEventToCInt PAIOEventError  = 8
{-# LINE 82 "src/Sound/Pulse/Mainloop.hsc" #-}

-- |Internal function for conversion
ioEventsToCInt :: [PAIOEventFlags] -> CInt
ioEventsToCInt xs = foldr (\x y -> ioEventToCInt x .|. y) 0 xs

-- |Internal function for conversion
ioEventsFromCInt :: CInt -> [PAIOEventFlags]
ioEventsFromCInt val =
    let enull  = potAdd PAIOEventNull   []
        input  = potAdd PAIOEventInput  enull
        output = potAdd PAIOEventOutput input
        hangup = potAdd PAIOEventHangup output
        err    = potAdd PAIOEventError  hangup
    in err
    where potAdd :: PAIOEventFlags -> ([PAIOEventFlags] -> [PAIOEventFlags])
          potAdd con = if (val .&. ioEventToCInt con) /= 0 then (con:) else id

{- | The main class for a pulseaudio mainloop abstraction. -}
class PAMainloop a where
    -- |Pulseaudio IO event. Will have to wait for an Fd to become ready
    -- (w.r.t. to flags)
    data PAIOEvent a :: *
    -- |Pulseaudio Time event. Should fire at a specified time.
    data PATimeEvent a :: *
    -- |Pulseaudio Defer event. Should be handled before other events. May
    -- be disabled.
    data PADeferEvent a :: *

    -- |Create a new 'PAIOEvent' and set it to listen for specified events.
    ioNew    :: a -> Fd -> [PAIOEventFlags] -> ([PAIOEventFlags] -> IO ()) -> IO (PAIOEvent a)
    -- |Modify the events an IOEvent is waiting on.
    ioEnable :: (PAIOEvent a) -> [PAIOEventFlags] -> IO ()
    -- |Delete an IOEvent.
    ioFree   :: (PAIOEvent a) -> IO ()
    -- |Set the destroy handler of an IOEvent. The handler should be called,
    -- when the event is deleted.
    ioSetDestroy :: (PAIOEvent a) -> IO () -> IO ()

    -- |Create a new 'PATimeEvent'. This should fire at the given time.
    timeNew :: a -> PATime -> (PATime -> IO ()) -> IO (PATimeEvent a)
    -- |Set a new time when the 'PATimeEvent' should fire. This may require
    -- requeing.
    timeRestart :: PATimeEvent a -> PATime -> IO ()
    -- |Delete a 'PATimeEvent'.
    timeFree :: PATimeEvent a -> IO ()
    -- |Set the destroy handler.
    timeSetDestroy :: PATimeEvent a -> IO () -> IO ()

    -- |Create a new 'PADefereEvent'. This should be fired before any other
    -- events.
    deferNew :: a -> IO () -> IO (PADeferEvent a)
    -- |Enable or disable a 'PADefereEvent'.
    deferEnable :: PADeferEvent a -> Bool -> IO ()
    -- |Delete the event.
    deferFree :: PADeferEvent a -> IO ()
    -- |Set the destroy handler for the event.
    deferSetDestroy :: PADeferEvent a -> IO () -> IO ()

    -- |Quit the mainloop and return the given int.
    quitLoop :: a -> Int -> IO ()

-- |Internal wrapper type for PAIOEvent
data PAIOEventW a = PAIOEventW
    {- ioRealHandle  :: -} (PAIOEvent a)
    {- ioWrappedData :: -} (Ptr Userdata)
    {- ioWrappedApi  :: -} (Ptr (PAMainloopApi a))

-- |"Record-name"
ioRealHandle :: PAIOEventW a -> PAIOEvent a
ioRealHandle (PAIOEventW x _ _) = x

-- |Internal wrapper type for PATimeEvent
data PATimeEventW a = PATimeEventW
    {- timeRealHandle  :: -} (PATimeEvent a)
    {- timeWrappedData :: -} (Ptr Userdata)
    {- timeWrappedApi  :: -} (Ptr (PAMainloopApi a))

-- |"Record-name"
timeRealHandle :: PATimeEventW a -> PATimeEvent a
timeRealHandle (PATimeEventW x _ _) = x

-- |Internal wrapper type for PADeferEvent
data PADeferEventW a = PADeferEventW
    {- deferRealHandle  :: -} (PADeferEvent a)
    {- deferWrappedData :: -} (Ptr Userdata)
    {- deferWrappedApi  :: -} (Ptr (PAMainloopApi a))

-- |"Record-name"
deferRealHandle :: PADeferEventW a -> PADeferEvent a
deferRealHandle (PADeferEventW x _ _) = x

{- IO Events -}
type IOEvCB a = Ptr (PAMainloopApi a) -> StablePtr (PAIOEventW a) -> CInt -> CInt -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkIOEvCB :: FunPtr (IOEvCB a) -> (IOEvCB a)

type IONew a = Ptr (PAMainloopApi a) -> CInt -> CInt -> FunPtr (IOEvCB a) -> Ptr Userdata -> IO (StablePtr (PAIOEventW a))
foreign import ccall "wrapper" mkIONew :: IONew a -> IO (FunPtr (IONew a))

type IOEnable a = StablePtr (PAIOEventW a) -> CInt -> IO ()
foreign import ccall "wrapper" mkIOEnable :: IOEnable a -> IO (FunPtr (IOEnable a))

type IOFree a = StablePtr (PAIOEventW a) -> IO ()
foreign import ccall "wrapper" mkIOFree :: IOFree a -> IO (FunPtr (IOFree a))

type IODestroy a = Ptr (PAMainloopApi a) -> StablePtr (PAIOEventW a) -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkIODestroy :: FunPtr (IODestroy a) -> (IODestroy a)

type IOSetDestroy a = StablePtr (PAIOEventW a) -> FunPtr (IODestroy a) -> IO ()
foreign import ccall "wrapper" mkIOSetDestroy :: IOSetDestroy a -> IO (FunPtr (IOSetDestroy a))

{- Time Events -}
type TimeEvCB a = Ptr (PAMainloopApi a) -> StablePtr (PATimeEventW a) -> Ptr PAITime -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkTimeEvCB :: FunPtr (TimeEvCB a) -> (TimeEvCB a)

type TimeNew a = Ptr (PAMainloopApi a) -> Ptr PAITime -> FunPtr (TimeEvCB a) -> Ptr Userdata -> IO (StablePtr (PATimeEventW a))
foreign import ccall "wrapper" mkTimeNew :: TimeNew a -> IO (FunPtr (TimeNew a))

type TimeRestart a = StablePtr (PATimeEventW a) -> Ptr PAITime -> IO ()
foreign import ccall "wrapper" mkTimeRestart :: TimeRestart a -> IO (FunPtr (TimeRestart a))

type TimeFree a = StablePtr (PATimeEventW a) -> IO ()
foreign import ccall "wrapper" mkTimeFree :: TimeFree a -> IO (FunPtr (TimeFree a))

type TimeDestroy a = Ptr (PAMainloopApi a) -> StablePtr (PATimeEventW a) -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkTimeDestroy :: FunPtr (TimeDestroy a) -> (TimeDestroy a)

type TimeSetDestroy a = StablePtr (PATimeEventW a) -> FunPtr (TimeDestroy a) -> IO ()
foreign import ccall "wrapper" mkTimeSetDestroy :: TimeSetDestroy a -> IO (FunPtr (TimeSetDestroy a))

{- Defer Events -}
type DeferEvCB a = Ptr (PAMainloopApi a) -> StablePtr (PADeferEventW a) -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkDeferEvCB :: FunPtr (DeferEvCB a) -> DeferEvCB a

type DeferNew a = Ptr (PAMainloopApi a) -> FunPtr (DeferEvCB a) -> Ptr Userdata -> IO (StablePtr (PADeferEventW a))
foreign import ccall "wrapper" mkDeferNew :: DeferNew a -> IO (FunPtr (DeferNew a))

type DeferEnable a = StablePtr (PADeferEventW a) -> CInt -> IO ()
foreign import ccall "wrapper" mkDeferEnable :: DeferEnable a -> IO (FunPtr (DeferEnable a))

type DeferFree a = StablePtr (PADeferEventW a) -> IO ()
foreign import ccall "wrapper" mkDeferFree :: DeferFree a -> IO (FunPtr (DeferFree a))

type DeferDestroy a = Ptr (PAMainloopApi a) -> StablePtr (PADeferEventW a) -> Ptr Userdata -> IO ()
foreign import ccall "dynamic" mkDeferDestroy :: FunPtr (DeferDestroy a) -> (DeferDestroy a)

type DeferSetDestroy a = StablePtr (PADeferEventW a) -> FunPtr (DeferDestroy a) -> IO ()
foreign import ccall "wrapper" mkDeferSetDestroy :: DeferSetDestroy a -> IO (FunPtr (DeferSetDestroy a))

type Quit a = Ptr (PAMainloopApi a) -> CInt -> IO ()
foreign import ccall "wrapper" mkQuit :: Quit a -> IO (FunPtr (Quit a))

-- |The type used to encapsule a 'PAMainloop' in a C compatible struct of
-- 'FunPtr's.
data PAMainloopApi a = PAMainloopApi
    { userdata          :: StablePtr a

    , io_new            :: FunPtr (IONew a)
    , io_enable         :: FunPtr (IOEnable a)
    , io_free           :: FunPtr (IOFree a)
    , io_set_destroy    :: FunPtr (IOSetDestroy a)

    , time_new          :: FunPtr (TimeNew a)
    , time_restart      :: FunPtr (TimeRestart a)
    , time_free         :: FunPtr (TimeFree a)
    , time_set_destroy  :: FunPtr (TimeSetDestroy a)

    , defer_new         :: FunPtr (DeferNew a)
    , defer_enable      :: FunPtr (DeferEnable a)
    , defer_free        :: FunPtr (DeferFree a)
    , defer_set_destroy :: FunPtr (DeferSetDestroy a)

    , quit              :: FunPtr (Quit a)
    }

instance Storable (PAMainloopApi a) where
    sizeOf _ = (112)
{-# LINE 258 "src/Sound/Pulse/Mainloop.hsc" #-}
    alignment _ = (8)
{-# LINE 259 "src/Sound/Pulse/Mainloop.hsc" #-}
    peek p = PAMainloopApi
        <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) p
{-# LINE 261 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 262 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 16) p
{-# LINE 263 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 24) p
{-# LINE 264 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 265 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 40) p
{-# LINE 266 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 48) p
{-# LINE 267 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 56) p
{-# LINE 268 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 64) p
{-# LINE 269 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 72) p
{-# LINE 270 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 80) p
{-# LINE 271 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 88) p
{-# LINE 272 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 96) p
{-# LINE 273 "src/Sound/Pulse/Mainloop.hsc" #-}
        <*> (\hsc_ptr -> peekByteOff hsc_ptr 104) p
{-# LINE 274 "src/Sound/Pulse/Mainloop.hsc" #-}
    poke p (PAMainloopApi {..}) = do
        (\hsc_ptr -> pokeByteOff hsc_ptr 0)          p userdata
{-# LINE 276 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8)            p io_new
{-# LINE 277 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16)         p io_enable
{-# LINE 278 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24)           p io_free
{-# LINE 279 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 32)    p io_set_destroy
{-# LINE 280 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 40)          p time_new
{-# LINE 281 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 48)      p time_restart
{-# LINE 282 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 56)         p time_free
{-# LINE 283 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 64)  p time_set_destroy
{-# LINE 284 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 72)         p defer_new
{-# LINE 285 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 80)      p defer_enable
{-# LINE 286 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 88)        p defer_free
{-# LINE 287 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 96) p defer_set_destroy
{-# LINE 288 "src/Sound/Pulse/Mainloop.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 104)              p quit
{-# LINE 289 "src/Sound/Pulse/Mainloop.hsc" #-}

-- |Get the Mainloop back from a 'PAMainloopApi' without marshalling all of it.
getMainloopImpl :: Ptr (PAMainloopApi a) -> IO a
getMainloopImpl p =
    deRefStablePtr =<< (peek . (\hsc_ptr -> hsc_ptr `plusPtr` 0) $ p)
{-# LINE 294 "src/Sound/Pulse/Mainloop.hsc" #-}

-- |Warning! This leaks a bit of memory when it's Garbage collected, because
-- the FunPtrs created for the PulseApi cannot be collected at that point.
-- Currently there is no way to properly free them, but this should only be
-- called once per application, so this will be a known Bug for now.
getMainloopApi :: PAMainloop a => a -> IO (PAMainloopApi a)
getMainloopApi api = do
    io_enable <- mkIOEnable $ \ptr flags -> do
        evt <- deRefStablePtr ptr
        ioEnable (ioRealHandle evt) (ioEventsFromCInt flags)
    io_new <- mkIONew $ \a fd flags fptr usr -> do
        -- This is stupid :(
        let fun = mkIOEvCB fptr
        impl <- getMainloopImpl a
        mvar <- newEmptyMVar
        ret <- ioNew impl (Fd fd) (ioEventsFromCInt flags) $ \iflags -> do
            evtp <- readMVar mvar
            fun a evtp fd (ioEventsToCInt iflags) usr
        rpt <- newStablePtr $ PAIOEventW ret usr a
        putMVar mvar rpt
        return rpt
    io_free <- mkIOFree ((=<<) (ioFree . ioRealHandle) . deRefStablePtr)
    io_set_destroy <- mkIOSetDestroy $ \ptr fptr -> do
        let fun = mkIODestroy fptr
        (PAIOEventW evt usr a) <- deRefStablePtr ptr
        ioSetDestroy evt $ fun a ptr usr

    time_new <- mkTimeNew $ \a timep fptr usr -> do
        let fun = mkTimeEvCB fptr
        impl <- getMainloopImpl a
        mvar <- newEmptyMVar
        time <- peek timep
        ret <- timeNew impl (fromPAI time) $ \itime -> do
            evt <- readMVar mvar
            with (toPAI itime) $ flip (fun a evt) usr
        rpt <- newStablePtr $ PATimeEventW ret usr a
        putMVar mvar rpt
        return rpt
    time_restart <- mkTimeRestart $ \ptr timep -> do
        time <- peek timep
        flip timeRestart (fromPAI time) . timeRealHandle =<< deRefStablePtr ptr
    time_free <- mkTimeFree ((=<<) (timeFree . timeRealHandle) . deRefStablePtr)
    time_set_destroy <- mkTimeSetDestroy $ \ptr fptr -> do
        let fun = mkTimeDestroy fptr
        (PATimeEventW evt usr a) <- deRefStablePtr ptr
        timeSetDestroy evt $ fun a ptr usr

    defer_new <- mkDeferNew $ \a fptr usr -> do
        let fun = mkDeferEvCB fptr
        impl <- getMainloopImpl a
        mvar <- newEmptyMVar
        ret <- deferNew impl $ (flip (fun a) usr =<< readMVar mvar)
        rpt <- newStablePtr $ PADeferEventW ret usr a
        putMVar mvar rpt
        return rpt
    defer_enable <- mkDeferEnable $ \ptr switch -> do
        flip deferEnable (switch /= 0) . deferRealHandle =<< deRefStablePtr ptr
    defer_free <- mkDeferFree ((=<<) (deferFree . deferRealHandle) . deRefStablePtr)
    defer_set_destroy <- mkDeferSetDestroy $ \ptr fptr -> do
        let fun = mkDeferDestroy fptr
        (PADeferEventW evt usr a) <- deRefStablePtr ptr
        deferSetDestroy evt $ fun a ptr usr

    quit <- mkQuit $ \ptr val -> do
        impl <- getMainloopImpl ptr
        quitLoop impl (fromIntegral val)
    userdata <- newStablePtr api
    return $ PAMainloopApi {..}