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,

    activate,
    deactivate,
    withActivation,

    PortType,
    Direction, Input, Output,
    JackFFI.UnknownType, UnknownDirection,

    Port,
    newPort,
    disposePort,
    withPort,

    PortSet,
    setOfPort,
    setOfPorts,

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

    getSampleRate,

    mkClientRegistration,
    setClientRegistration,

    JackFFI.PortId,
    mkPortRegistration,
    setPortRegistration,
    mkPortConnect,
    setPortConnect,

    portById,
    portByName,

    portName,
    portShortName,

    getPorts,
    portGetAllConnections,

    narrowPort,
    narrowPortType,
    narrowPortDirection,
    switchUnknownTypePort,
    switchUnknownDirectionPort,

    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 qualified Sound.JACK.FFIFree as JackFFIFree
import Sound.JACK.FFI.MIDI (EventBuffer, )
import Sound.JACK.FFI (Process, nframesIndices, nframesBounds, )

import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import Control.Exception (finally, )

import qualified Foreign.Marshal.Array as Array
import qualified Foreign.C.String as CString
import qualified Foreign.C.Types as C
import Foreign.Storable (Storable, peek, )
import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, )
import Foreign.C.String (CString, 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

-- | Type argument for Jack input ports
data Input = Input

instance Direction Input where
    dirToFlags ~Input = JackFFI.portIsInput

-- | Type argument for Jack output ports
data Output = Output

instance Direction Output where
    dirToFlags ~Output = JackFFI.portIsOutput

{- |
Type argument for Jack ports
where we do not know
whether it is an input or an output port.
-}
data UnknownDirection = UnknownDirection

_dummyUnknownDirection :: UnknownDirection
_dummyUnknownDirection = UnknownDirection



-- | 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) name =
    let aux ::
            (PortType typ, Direction dir,
             JackExc.ThrowsPortRegister e) =>
            typ -> dir -> Sync.ExceptionalT e IO (Port typ dir)
        aux portType dir =
            withPortName name $ \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 =
    bracket_ (activate client) (deactivate client)

-- | 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


{-
dummy use of C that we imported in order to expose CInt constructor
-}
_dummy :: C.CInt
_dummy = undefined

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

peekPortNameArray :: Ptr CString -> IO [String]
peekPortNameArray a =
    if a == nullPtr
    then return []
    else finally
            (mapM peekCString =<< Array.peekArray0 nullPtr a)
            (JackFFIFree.freePortNameArray a)

-- | Returns the names of all existing ports.
getPorts :: Client -- ^ the Jack client
    -> IO [String] -- ^ the names as a list of strings
getPorts client =
    CString.withCString "" $ \empty -> do
        JackFFI.get_ports (getClient client) empty empty 0
            >>= peekPortNameArray


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


-- | Create a client registration callback 'FunPtr'.
foreign import ccall "wrapper" mkClientRegistration :: JackFFI.ClientRegistration -> IO (FunPtr JackFFI.ClientRegistration)

-- | Set the client registration callback.
setClientRegistration ::
    (JackExc.ThrowsErrno e) =>
    Client ->
    FunPtr JackFFI.ClientRegistration ->
    Sync.ExceptionalT e IO ()
setClientRegistration client procPtr =
    liftErrno $ JackFFI.set_client_registration_callback (getClient client) procPtr nullPtr


-- | Create a port registration callback 'FunPtr'.
foreign import ccall "wrapper" mkPortRegistration :: JackFFI.PortRegistration -> IO (FunPtr JackFFI.PortRegistration)

-- | Set the port registration callback.
setPortRegistration ::
    (JackExc.ThrowsErrno e) =>
    Client ->
    FunPtr JackFFI.PortRegistration ->
    Sync.ExceptionalT e IO ()
setPortRegistration client procPtr =
    liftErrno $ JackFFI.set_port_registration_callback (getClient client) procPtr nullPtr


-- | Create a port connect callback 'FunPtr'.
foreign import ccall "wrapper" mkPortConnect :: JackFFI.PortConnect -> IO (FunPtr JackFFI.PortConnect)

-- | Set the port connect callback.
setPortConnect ::
    (JackExc.ThrowsErrno e) =>
    Client ->
    FunPtr JackFFI.PortConnect ->
    Sync.ExceptionalT e IO ()
setPortConnect client procPtr =
    liftErrno $ JackFFI.set_port_connect_callback (getClient client) procPtr nullPtr


portById ::
    Client -> JackFFI.PortId ->
    IO (Port JackFFI.UnknownType UnknownDirection)
portById client portId =
    fmap Port $
    JackFFI.port_by_id (getClient client) portId

portByName ::
    Client -> String ->
    IO (Port JackFFI.UnknownType UnknownDirection)
portByName client name =
    fmap Port $
    CString.withCString name $ JackFFI.port_by_name (getClient client) . JackFFI.PortName

-- | Return the full port name, including the @client_name:@ prefix.
portName :: Port typ dir -> IO String
portName (Port port) = JackFFI.port_name port >>= peekCString

-- | Return the short port name, not including the @client_name:@ prefix.
portShortName :: Port typ dir -> IO String
portShortName (Port port) = JackFFI.port_short_name port >>= peekCString

-- | Return all the port names a given port is connected to.
--
-- This function must not be called from a JACK event callback.
portGetAllConnections ::
    Client -> Port typ dir -> IO [String]
portGetAllConnections client (Port port) =
    JackFFI.port_get_all_connections (getClient client) port
        >>= peekPortNameArray

narrowPort ::
    (PortType typ, Direction dir, JackExc.ThrowsPortMismatch e) =>
    Port JackFFI.UnknownType UnknownDirection ->
    Sync.ExceptionalT e IO (Port typ dir)
narrowPort port =
    narrowPortType =<< narrowPortDirection port

narrowPortType ::
    (PortType typ, JackExc.ThrowsPortMismatch e) =>
    Port JackFFI.UnknownType dir ->
    Sync.ExceptionalT e IO (Port typ dir)
narrowPortType =
    let aux ::
            (PortType typ,
             JackExc.ThrowsPortMismatch e) =>
            typ -> Port JackFFI.UnknownType dir ->
            Sync.ExceptionalT e IO (Port typ dir)
        aux portType (Port port) = do
            typ <-
                Trans.lift $
                peekCString . JackFFI.deconsPortName =<< JackFFI.port_type port
            Sync.assertT (JackExc.portMismatch JackExc.TypeMismatch) $
                portTypeToCString portType == typ
            return $ Port $ castPtr port
    in  aux undefined

narrowPortDirection ::
    (Direction dir, JackExc.ThrowsPortMismatch e) =>
    Port typ UnknownDirection ->
    Sync.ExceptionalT e IO (Port typ dir)
narrowPortDirection =
    let aux ::
            (Direction dir,
             JackExc.ThrowsPortMismatch e) =>
            dir -> Port typ UnknownDirection ->
            Sync.ExceptionalT e IO (Port typ dir)
        aux dir (Port port) = do
            flags <- Trans.lift $ JackFFI.port_flags port
            Sync.assertT (JackExc.portMismatch JackExc.DirectionMismatch) $
                not $ ES.disjoint flags $ dirToFlags dir
            return $ Port port
    in  aux undefined

switchUnknownTypePort ::
    (JackExc.ThrowsPortMismatch e) =>
    Port JackFFI.UnknownType dir ->
    (Port C.CFloat dir -> Sync.ExceptionalT e IO a) ->
    (Port EventBuffer dir -> Sync.ExceptionalT e IO a) ->
    Sync.ExceptionalT e IO a
switchUnknownTypePort (Port port) audio midi = do
    typ <-
        Trans.lift $
            peekCString . JackFFI.deconsPortName
                =<< JackFFI.port_type port
    let ifMatch ::
            (PortType typ, Monad m) =>
            typ -> (Port typ dir -> m a) ->
            Port typ dir -> m a -> m a
        ifMatch portType trueAct p falseAct =
            if portTypeToCString portType == typ
              then trueAct p
              else falseAct
    case Port $ castPtr port of
        audioPort ->
            ifMatch undefined audio audioPort $
                case Port $ castPtr port of
                    midiPort ->
                        ifMatch undefined midi midiPort $
                        Sync.throwT $ JackExc.portMismatch JackExc.TypeMismatch

switchUnknownDirectionPort ::
    (JackExc.ThrowsPortMismatch e) =>
    Port typ UnknownDirection ->
    (Port typ Input -> Sync.ExceptionalT e IO a) ->
    (Port typ Output -> Sync.ExceptionalT e IO a) ->
    Sync.ExceptionalT e IO a
switchUnknownDirectionPort (Port port) input output = do
    flags <- Trans.lift $ JackFFI.port_flags port
    let ifMatch ::
            (Direction dir, Monad m) =>
            dir -> (Port typ dir -> m a) ->
            Port typ dir -> m a -> m a
        ifMatch dir trueAct p falseAct =
            if not $ ES.disjoint flags $ dirToFlags dir
              then trueAct p
              else falseAct
    case Port port of
        inPort ->
            ifMatch undefined input inPort $
                case Port port of
                    outPort ->
                        ifMatch undefined output outPort $
                        Sync.throwT $ JackExc.portMismatch JackExc.DirectionMismatch