-- | Monad class implementing an Open Sound Control transport.
module Sound.Osc.Transport.Monad where

import Control.Monad {- base -}
import Control.Monad.IO.Class {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Control.Monad.Trans.Reader as R {- transformers -}

import qualified Sound.Osc.Datum as Datum {- hosc -}
import qualified Sound.Osc.Packet as Packet {- hosc -}
import qualified Sound.Osc.Transport.Fd as Fd {- hosc -}
import qualified Sound.Osc.Wait as Wait {- hosc -}

-- | Sender monad.
class Monad m => SendOsc m where
  -- | Encode and send an Osc packet.
  sendPacket :: Packet.PacketOf Packet.Message -> m ()

-- | Receiver monad.
class Monad m => RecvOsc m where
  -- | Receive and decode an Osc packet.
  recvPacket :: m (Packet.PacketOf Packet.Message)

-- | 'DuplexOsc' is the union of 'SendOsc' and 'RecvOsc'.
class (SendOsc m, RecvOsc m) => DuplexOsc m

-- | 'Transport' is 'DuplexOsc' with a 'MonadIO' constraint.
class (DuplexOsc m, MonadIO m) => Transport m

-- | 'SendOsc' over 'ReaderT'.
instance (Fd.Transport t, MonadIO io) => SendOsc (R.ReaderT t io) where
  sendPacket :: PacketOf Message -> ReaderT t io ()
sendPacket PacketOf Message
p = (t -> io ()) -> ReaderT t io ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT (IO () -> io ()
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> (t -> IO ()) -> t -> io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> PacketOf Message -> IO ()) -> PacketOf Message -> t -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip t -> PacketOf Message -> IO ()
forall t. Transport t => t -> PacketOf Message -> IO ()
Fd.sendPacket PacketOf Message
p)

-- | 'RecvOsc' over 'ReaderT'.
instance (Fd.Transport t, MonadIO io) => RecvOsc (R.ReaderT t io) where
  recvPacket :: ReaderT t io (PacketOf Message)
recvPacket = (t -> io (PacketOf Message)) -> ReaderT t io (PacketOf Message)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT (IO (PacketOf Message) -> io (PacketOf Message)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PacketOf Message) -> io (PacketOf Message))
-> (t -> IO (PacketOf Message)) -> t -> io (PacketOf Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> IO (PacketOf Message)
forall t. Transport t => t -> IO (PacketOf Message)
Fd.recvPacket)

-- | 'DuplexOsc' over 'ReaderT'.
instance (Fd.Transport t, MonadIO io) => DuplexOsc (R.ReaderT t io)

-- | 'Transport' over 'ReaderT'.
instance (Fd.Transport t, MonadIO io) => Transport (R.ReaderT t io)

-- | Transport connection.
type Connection t a = R.ReaderT t IO a

-- | Bracket Open Sound Control communication.
withTransport :: Fd.Transport t => IO t -> Connection t r -> IO r
withTransport :: forall t r. Transport t => IO t -> Connection t r -> IO r
withTransport IO t
u = IO t -> (t -> IO r) -> IO r
forall t a. Transport t => IO t -> (t -> IO a) -> IO a
Fd.withTransport IO t
u ((t -> IO r) -> IO r)
-> (Connection t r -> t -> IO r) -> Connection t r -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection t r -> t -> IO r
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT

-- | 'void' of 'withTransport'.
withTransport_ :: Fd.Transport t => IO t -> Connection t r -> IO ()
withTransport_ :: forall t r. Transport t => IO t -> Connection t r -> IO ()
withTransport_ IO t
u = IO r -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO r -> IO ())
-> (Connection t r -> IO r) -> Connection t r -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO t -> Connection t r -> IO r
forall t r. Transport t => IO t -> Connection t r -> IO r
withTransport IO t
u

-- * Send

-- | Type restricted synonym for 'sendOsc'.
sendMessage :: SendOsc m => Packet.Message -> m ()
sendMessage :: forall (m :: * -> *). SendOsc m => Message -> m ()
sendMessage = PacketOf Message -> m ()
forall (m :: * -> *). SendOsc m => PacketOf Message -> m ()
sendPacket (PacketOf Message -> m ())
-> (Message -> PacketOf Message) -> Message -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> PacketOf Message
forall t. Message -> PacketOf t
Packet.Packet_Message

-- | Type restricted synonym for 'sendOsc'.
sendBundle :: SendOsc m => Packet.BundleOf Packet.Message -> m ()
sendBundle :: forall (m :: * -> *). SendOsc m => BundleOf Message -> m ()
sendBundle = PacketOf Message -> m ()
forall (m :: * -> *). SendOsc m => PacketOf Message -> m ()
sendPacket (PacketOf Message -> m ())
-> (BundleOf Message -> PacketOf Message)
-> BundleOf Message
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BundleOf Message -> PacketOf Message
forall t. BundleOf t -> PacketOf t
Packet.Packet_Bundle

-- * Receive

-- | Variant of 'recvPacket' that runs 'packet_to_bundle'.
recvBundle :: (RecvOsc m) => m (Packet.BundleOf Packet.Message)
recvBundle :: forall (m :: * -> *). RecvOsc m => m (BundleOf Message)
recvBundle = (PacketOf Message -> BundleOf Message)
-> m (PacketOf Message) -> m (BundleOf Message)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PacketOf Message -> BundleOf Message
Packet.packet_to_bundle m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
recvPacket

-- | Variant of 'recvPacket' that runs 'packet_to_message'.
recvMessage :: (RecvOsc m) => m (Maybe Packet.Message)
recvMessage :: forall (m :: * -> *). RecvOsc m => m (Maybe Message)
recvMessage = (PacketOf Message -> Maybe Message)
-> m (PacketOf Message) -> m (Maybe Message)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PacketOf Message -> Maybe Message
Packet.packet_to_message m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
recvPacket

-- | Erroring variant.
recvMessage_err :: RecvOsc m => m Packet.Message
recvMessage_err :: forall (m :: * -> *). RecvOsc m => m Message
recvMessage_err = (Maybe Message -> Message) -> m (Maybe Message) -> m Message
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Message -> Maybe Message -> Message
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Message
forall a. HasCallStack => [Char] -> a
error [Char]
"recvMessage")) m (Maybe Message)
forall (m :: * -> *). RecvOsc m => m (Maybe Message)
recvMessage

-- | Variant of 'recvPacket' that runs 'packetMessages'.
recvMessages :: (RecvOsc m) => m [Packet.Message]
recvMessages :: forall (m :: * -> *). RecvOsc m => m [Message]
recvMessages = (PacketOf Message -> [Message])
-> m (PacketOf Message) -> m [Message]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PacketOf Message -> [Message]
Packet.packetMessages m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
recvPacket

-- * Wait

{- | Wait for a 'Packet' where the supplied predicate is 'True',
discarding intervening packets.
-}
waitUntil :: (RecvOsc m) => (Packet.PacketOf Packet.Message -> Bool) -> m (Packet.PacketOf Packet.Message)
waitUntil :: forall (m :: * -> *).
RecvOsc m =>
(PacketOf Message -> Bool) -> m (PacketOf Message)
waitUntil PacketOf Message -> Bool
f = (PacketOf Message -> Bool)
-> m (PacketOf Message) -> m (PacketOf Message)
forall (m :: * -> *) a. Monad m => (a -> Bool) -> m a -> m a
Wait.untilPredicate PacketOf Message -> Bool
f m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
recvPacket

{- | Wait for a 'Packet' where the supplied function does not give 'Nothing',
discarding intervening packets.
-}
waitFor :: (RecvOsc m) => (Packet.PacketOf Packet.Message -> Maybe a) -> m a
waitFor :: forall (m :: * -> *) a.
RecvOsc m =>
(PacketOf Message -> Maybe a) -> m a
waitFor PacketOf Message -> Maybe a
f = (PacketOf Message -> Maybe a) -> m (PacketOf Message) -> m a
forall (m :: * -> *) a b. Monad m => (a -> Maybe b) -> m a -> m b
Wait.untilMaybe PacketOf Message -> Maybe a
f m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
recvPacket

-- | 'waitUntil' 'packet_is_immediate'.
waitImmediate :: RecvOsc m => m (Packet.PacketOf Packet.Message)
waitImmediate :: forall (m :: * -> *). RecvOsc m => m (PacketOf Message)
waitImmediate = (PacketOf Message -> Bool) -> m (PacketOf Message)
forall (m :: * -> *).
RecvOsc m =>
(PacketOf Message -> Bool) -> m (PacketOf Message)
waitUntil PacketOf Message -> Bool
forall t. PacketOf t -> Bool
Packet.packet_is_immediate

{- | 'waitFor' 'packet_to_message',
ie. an incoming 'Message' or immediate mode 'Bundle' with one element.
-}
waitMessage :: RecvOsc m => m Packet.Message
waitMessage :: forall (m :: * -> *). RecvOsc m => m Message
waitMessage = (PacketOf Message -> Maybe Message) -> m Message
forall (m :: * -> *) a.
RecvOsc m =>
(PacketOf Message -> Maybe a) -> m a
waitFor PacketOf Message -> Maybe Message
Packet.packet_to_message

{- | A 'waitFor' for variant using 'packet_has_address' to match on
the 'Address_Pattern' of incoming 'Packets'.
-}
waitAddress :: RecvOsc m => Packet.Address_Pattern -> m (Packet.PacketOf Packet.Message)
waitAddress :: forall (m :: * -> *). RecvOsc m => [Char] -> m (PacketOf Message)
waitAddress [Char]
s =
  let f :: PacketOf Message -> Maybe (PacketOf Message)
f PacketOf Message
o = if [Char] -> PacketOf Message -> Bool
Packet.packet_has_address [Char]
s PacketOf Message
o then PacketOf Message -> Maybe (PacketOf Message)
forall a. a -> Maybe a
Just PacketOf Message
o else Maybe (PacketOf Message)
forall a. Maybe a
Nothing
  in (PacketOf Message -> Maybe (PacketOf Message))
-> m (PacketOf Message)
forall (m :: * -> *) a.
RecvOsc m =>
(PacketOf Message -> Maybe a) -> m a
waitFor PacketOf Message -> Maybe (PacketOf Message)
f

-- | Variant on 'waitAddress' that returns matching 'Message'.
waitReply :: RecvOsc m => Packet.Address_Pattern -> m Packet.Message
waitReply :: forall (m :: * -> *). RecvOsc m => [Char] -> m Message
waitReply [Char]
s =
  let f :: PacketOf Message -> Message
f =
        Message -> Maybe Message -> Message
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Message
forall a. HasCallStack => [Char] -> a
error [Char]
"waitReply: message not located?")
          (Maybe Message -> Message)
-> (PacketOf Message -> Maybe Message)
-> PacketOf Message
-> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> Bool) -> [Message] -> Maybe Message
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ([Char] -> Message -> Bool
Packet.message_has_address [Char]
s)
          ([Message] -> Maybe Message)
-> (PacketOf Message -> [Message])
-> PacketOf Message
-> Maybe Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacketOf Message -> [Message]
Packet.packetMessages
  in (PacketOf Message -> Message) -> m (PacketOf Message) -> m Message
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PacketOf Message -> Message
f ([Char] -> m (PacketOf Message)
forall (m :: * -> *). RecvOsc m => [Char] -> m (PacketOf Message)
waitAddress [Char]
s)

-- | Variant of 'waitReply' that runs 'messageDatum'.
waitDatum :: RecvOsc m => Packet.Address_Pattern -> m [Datum.Datum]
waitDatum :: forall (m :: * -> *). RecvOsc m => [Char] -> m [Datum]
waitDatum = (Message -> [Datum]) -> m Message -> m [Datum]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> [Datum]
Packet.messageDatum (m Message -> m [Datum])
-> ([Char] -> m Message) -> [Char] -> m [Datum]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> m Message
forall (m :: * -> *). RecvOsc m => [Char] -> m Message
waitReply