JACK.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-
    JACK bindings for Haskell
    Copyright (C) 2011 Henning Thielemann
    Copyright (C) 2007 Soenke Hahn

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

    This program 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 General Public License for more details.

    You should have received a copy of the GNU General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}

{-|

The Jack module defines types and functions that allows you to
use the JACK Audio Connection Kit.

-}
module Sound.JACK
  ( -- * general stuff
    Client,
    newClient,
    newClientDefault,
    disposeClient,
    withClient,
    withClientDefault,
    clientClose,
    getPorts,

    activate,
    deactivate,
    withActivation,

    PortType,
    Direction, Input, Output,

    Port,
    newPort,
    disposePort,
    withPort,

    PortSet,
    setOfPort,
    setOfPorts,

    Process,
    connect,
    mkProcess,
    setProcess,
    JackFFI.CallbackArg,

    getSampleRate,

    JackFFI.NFrames(JackFFI.NFrames),
    nframesIndices, nframesBounds,
    quit, waitForBreakAndClose,
    waitForBreak,

    -- * Exceptions
    handleExceptions,
)
    where

import Sound.JACK.Private

import qualified Sound.JACK.Exception as JackExc
import qualified Sound.JACK.FFI as JackFFI
import Sound.JACK.FFI (Process, nframesIndices, nframesBounds, )

import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans

import qualified Foreign.Marshal.Array as Array
import qualified Foreign.C.String as CString
import Foreign.Storable (Storable, peek, )
import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, )
import Foreign.C.String (peekCString, )
import Foreign.C.Error (Errno(Errno), )
import qualified Data.EnumSet as ES

import Control.Concurrent (MVar, putMVar, newEmptyMVar, takeMVar, threadDelay)

import qualified System.IO as IO
import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
import Data.Monoid (Monoid, mempty, mappend, )



class Direction dir where
    dirToFlags :: dir -> JackFFI.PortFlagSet

-- | Handles of Jack input ports
data Input = Input

instance Direction Input where
    dirToFlags ~Input = JackFFI.portIsInput

-- | Handles of Jack output ports
data Output = Output

instance Direction Output where
    dirToFlags ~Output = JackFFI.portIsOutput



-- | Constructs a new Jack client.
newClient ::
    (JackExc.ThrowsStatus e) =>
       String -- ^ name of the JACK server
    -> String -- ^ name of the client
    -> Sync.ExceptionalT e IO Client
newClient server name =
    withCString server $ \cserverS ->
    withCString name $ \cclientS ->
    alloca $ \status -> do
        let opt = ES.fromEnums [JackFFI.ServerName, JackFFI.NoStartServer]
        client <- Trans.lift $ JackFFI.client_open cclientS opt status cserverS
        _ <- checkStatus client status
        return (Client client)

-- | Creates a new JACK client with the "default" server
newClientDefault ::
    (JackExc.ThrowsStatus e) =>
       String -- ^ name of the client
    -> Sync.ExceptionalT e IO Client
newClientDefault name = newClient defaultServer name

defaultServer :: String
defaultServer = "default"

disposeClient ::
    (JackExc.ThrowsErrno e) =>
    Client -> Sync.ExceptionalT e IO ()
disposeClient client =
    liftErrno $ JackFFI.client_close (getClient client)

{- |
Run a block of code with a newly allocated client.
Do not use the client outside the block.
-}
withClient ::
    (JackExc.ThrowsStatus e) =>
       String -- ^ name of the JACK server
    -> String -- ^ name of the client
    -> (Client -> Sync.ExceptionalT e IO a)
    -> Sync.ExceptionalT e IO a
withClient server name =
    bracket
        (newClient server name)
        (Trans.lift . fmap (const ()) .
         JackFFI.client_close . getClient)

withClientDefault ::
    (JackExc.ThrowsStatus e) =>
       String -- ^ name of the client
    -> (Client -> Sync.ExceptionalT e IO a)
    -> Sync.ExceptionalT e IO a
withClientDefault =
    withClient defaultServer


checkStatus ::
    (JackExc.ThrowsStatus e) =>
       Ptr a
    -> Ptr JackFFI.StatusSet
    -> Sync.ExceptionalT e IO JackFFI.StatusSet
checkStatus c s = do
    errCode <- Trans.lift $ peek s
    Sync.assertT (JackExc.status errCode) (c /= nullPtr)
    return errCode


newPortByType ::
    (PortType typ, Direction dir,
     JackExc.ThrowsPortRegister e) =>
    JackFFI.PortFlagSet -> Client -> String ->
    Sync.ExceptionalT e IO (Port typ dir)
newPortByType flags (Client client) portName =
    let aux ::
            (PortType typ, Direction dir,
             JackExc.ThrowsPortRegister e) =>
            typ -> dir -> Sync.ExceptionalT e IO (Port typ dir)
        aux portType dir =
            withPortName portName $ \cPortName ->
            withCString (portTypeToCString portType) $ \pType -> do
        --     putStrLn ("register..." ++ show (client, cstring, pType, inout, 0))
                port <- Trans.lift $
                   JackFFI.port_register client cPortName pType (dirToFlags dir ES..|. flags) 0
                Sync.assertT JackExc.portRegister (port/=nullPtr)
                return $ Port port
    in  aux undefined undefined

{- |
Better use 'withPort' that also handles freeing the port.
-}
newPort ::
    (PortType typ, Direction dir,
     JackExc.ThrowsPortRegister e) =>
       Client -- ^ Jack client
    -> String -- ^ name of the input port
    -> Sync.ExceptionalT e IO (Port typ dir)
newPort client name =
    newPortByType ES.empty client name


disposePort ::
    (PortType typ, Direction dir,
     JackExc.ThrowsErrno e) =>
    Client -> Port typ dir -> Sync.ExceptionalT e IO ()
disposePort client =
    liftErrno . JackFFI.port_unregister (getClient client) . getPort

{- |
Creates a new port for the given client and delete it after usage.
The port manages audio or MIDI data in input or output direction
depending on the Port type.
Usually the required port type can be inferred from following actions
that use that port.

Do not use the port outside the enclosed block.
-}
withPort ::
    (PortType typ, Direction dir,
     JackExc.ThrowsPortRegister e,
     JackExc.ThrowsErrno e) =>
       Client -- ^ Jack client
    -> String -- ^ name of the input port
    -> (Port typ dir -> Sync.ExceptionalT e IO a)
    -> Sync.ExceptionalT e IO a
withPort client name =
    bracket (newPort client name) (disposePort client)



-- | activates the given Jack client
activate ::
    (JackExc.ThrowsErrno e) =>
    Client -> Sync.ExceptionalT e IO ()
activate client =
    liftErrno $ JackFFI.activate $ getClient client

deactivate ::
    (JackExc.ThrowsErrno e) =>
    Client -> Sync.ExceptionalT e IO ()
deactivate client =
    liftErrno $ JackFFI.deactivate $ getClient client

withActivation ::
    (JackExc.ThrowsErrno e) =>
    Client ->
    Sync.ExceptionalT e IO () ->
    Sync.ExceptionalT e IO ()
withActivation client act =
    bracket (activate client) (\() -> deactivate client) (\() -> act)

-- | closes the given Jack client without causing any trouble (hopefully)
clientClose ::
    (JackExc.ThrowsErrno e) =>
    Client -> PortSet ->
    Sync.ExceptionalT e IO ()
clientClose client (PortSet ports) = do
    mapM_ (liftErrno . JackFFI.port_unregister (getClient client)) ports
    deactivate client
    disposeClient client

foreign import ccall "wrapper" mkProcess :: Process -> IO (FunPtr Process)


getClient :: Client -> Ptr JackFFI.Client
getClient (Client x) = x

getPort :: Port typ dir -> Ptr (JackFFI.Port typ)
getPort (Port x) = x

withPortName ::
    String -> (JackFFI.PortName -> Sync.ExceptionalT e IO a) ->
    Sync.ExceptionalT e IO a
withPortName name f =
    withCString name $ f . JackFFI.PortName

-- | returns the names of all existing ports of the given Jack client
getPorts :: Client -- ^ the Jack client
    -> IO [String] -- ^ the names as a list of strings
getPorts client =
    CString.withCString "" $ \empty -> do
        mapM peekCString
            =<< Array.peekArray0 nullPtr
            =<< JackFFI.get_ports (getClient client) empty empty 0


connect ::
    (JackExc.ThrowsErrno e) =>
    Client -> String -> String ->
    Sync.ExceptionalT e IO ()
connect client outport inport =
    withPortName outport $ \ outCString ->
    withPortName inport  $ \ inCString  ->
    liftErrno $ JackFFI.connect (getClient client) outCString inCString


{- |
A collection of mixed types of ports.
It is mainly needed for freeing all allocated ports.
-}
newtype PortSet = PortSet [Ptr (JackFFI.Port ())]

instance Monoid PortSet where
    mempty = PortSet mempty
    mappend (PortSet a) (PortSet b) = PortSet (mappend a b)

setOfPort ::
    (PortType typ, Direction dir) =>
    Port typ dir -> PortSet
setOfPort =
    PortSet . (:[]) . castPtr . getPort

setOfPorts ::
    (PortType typ, Direction dir) =>
    [Port typ dir] -> PortSet
setOfPorts =
    PortSet . map (castPtr . getPort)



quit ::
    MVar () -> Client -> PortSet -> IO ()
quit mvar client ports = do
    putStrLn "quitting..."
    Sync.resolveT
        (\(Errno e) ->
           IO.hPutStrLn IO.stderr $
           "exception when closing with errno: " ++ show e)
        (clientClose client ports)
    threadDelay 1000000
    putMVar mvar ()

waitForBreakAndClose ::
    Client -> PortSet -> IO ()
waitForBreakAndClose client ports = do
    mvar <- newEmptyMVar
    _ <- installHandler keyboardSignal
        (Catch $ quit mvar client ports)
        Nothing
    takeMVar mvar

waitForBreak :: IO ()
waitForBreak = do
    mvar <- newEmptyMVar
    _ <- installHandler keyboardSignal
        (Catch $ do
            putStrLn "quitting..."
            threadDelay 1000000
            putMVar mvar ())
        Nothing
    takeMVar mvar


handleExceptions ::
    Sync.ExceptionalT JackExc.All IO () ->
    IO ()
handleExceptions =
    Sync.resolveT $ IO.hPutStrLn IO.stderr . JackExc.toStringWithHead


setProcess ::
    (JackExc.ThrowsErrno e) =>
    Client ->
    FunPtr Process ->
    Sync.ExceptionalT e IO ()
setProcess client procPtr =
    liftErrno $ JackFFI.set_process_callback (getClient client) procPtr nullPtr


getSampleRate :: Client -> IO Int
getSampleRate (Client ptr) =
    fmap fromIntegral $ JackFFI.get_sample_rate ptr