hosc 0.11.1 → 0.12

raw patch · 23 files changed

+869/−407 lines, 23 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• README +20/−11
• Sound/OSC.hs +9/−0
• Sound/OSC/FD.hs +8/−0
• Sound/OSC/Transport/FD.hs +97/−0
• Sound/OSC/Transport/FD/TCP.hs +42/−0
• Sound/OSC/Transport/FD/UDP.hs +70/−0
• Sound/OSC/Transport/Monad.hs +96/−0
• Sound/OpenSoundControl.hs +16/−42
• Sound/OpenSoundControl/Class.hs +31/−0
• Sound/OpenSoundControl/Coding.hs +28/−14
• Sound/OpenSoundControl/Coding/Byte.hs +1/−1
• Sound/OpenSoundControl/Coding/Coerce.hs +9/−8
• Sound/OpenSoundControl/Coding/Decode/Base.hs +23/−20
• Sound/OpenSoundControl/Coding/Decode/Binary.hs +42/−43
• Sound/OpenSoundControl/Coding/Encode/Base.hs +23/−15
• Sound/OpenSoundControl/Coding/Encode/Builder.hs +55/−37
• Sound/OpenSoundControl/Time.hs +24/−12
• Sound/OpenSoundControl/Transport.hs +0/−56
• Sound/OpenSoundControl/Transport/TCP.hs +0/−46
• Sound/OpenSoundControl/Transport/UDP.hs +0/−62
• Sound/OpenSoundControl/Type.hs +220/−28
• Sound/OpenSoundControl/Wait.hs +27/−0
• hosc.cabal +28/−12

@@ -1,15 +1,24 @@ hosc - haskell open sound control+--------------------------------- -hosc provides Sound.OpenSoundControl, a haskell-module implementing a subset of the Open Sound-Control byte protocol.+[hosc][hosc] provides Sound.OpenSoundControl, a [haskell][hs]+module implementing a subset of the [Open Sound Control][osc] byte protocol. -  http://slavepianos.org/rd/?t=hosc-  http://haskell.org/-  http://opensoundcontrol.org/+© [rohan drape][rd], [stefan kersten][sk] and others, 2006-2012,+[gpl][gpl]. with contributions by: -(c) rohan drape, stefan kersten and others, 2006-2011-    gpl, http://gnu.org/copyleft/-    with contributions by alex mclean-                        & henning thielemann-    see darcs history for details+- [alex mclean][am]+- [henning thielemann][ht]++see the [darcs][darcs] [history][hosc-history] for details++[hosc]: http://rd.slavepianos.org/?t=hosc+[hs]: http://haskell.org/+[osc]: http://opensoundcontrol.org/+[rd]:  http://rd.slavepianos.org/+[sk]: http://space.k-hornz.de/+[am]: http://yaxu.org/+[ht]: http://www.henning-thielemann.de/Research.html+[darcs]: http://darcs.net/+[gpl]: http://gnu.org/copyleft/+[hosc-history]:  http://rd.slavepianos.org/r/d/darcsweb.cgi?r=hosc

@@ -0,0 +1,9 @@+-- | Composite of "Sound.OpenSoundControl" and+-- "Sound.OSC.Transport.Monad".+module Sound.OSC (module M) where++import Control.Monad.IO.Class as M (MonadIO,liftIO)+import Sound.OpenSoundControl as M+import Sound.OSC.Transport.FD.UDP as M+import Sound.OSC.Transport.FD.TCP as M+import Sound.OSC.Transport.Monad as M

@@ -0,0 +1,8 @@+-- | Composite of "Sound.OpenSoundControl" and+-- "Sound.OSC.Transport.FD".+module Sound.OSC.FD (module M) where++import Sound.OpenSoundControl as M+import Sound.OSC.Transport.FD as M+import Sound.OSC.Transport.FD.UDP as M+import Sound.OSC.Transport.FD.TCP as M

@@ -0,0 +1,97 @@+-- | An abstract transport layer with implementations for @UDP@ and+-- @TCP@ transport.+module Sound.OSC.Transport.FD where++import Control.Exception+import Data.List+import Data.Maybe+import Sound.OpenSoundControl.Class+import Sound.OpenSoundControl.Type+import Sound.OpenSoundControl.Wait++-- | Abstract over the underlying transport protocol.+class Transport t where+   -- | Encode and send an OSC packet.+   sendOSC :: OSC o => t -> o -> IO ()+   -- | Receive and decode an OSC packet.+   recvPacket :: t -> IO Packet+   -- | Close an existing connection.+   close :: t -> IO ()++-- | Bracket OSC communication.+withTransport :: Transport t => IO t -> (t -> IO a) -> IO a+withTransport u = bracket u close++-- * Send++-- | Type restricted synonym for 'sendOSC'.+sendMessage :: Transport t => t -> Message -> IO ()+sendMessage = sendOSC++-- | Type restricted synonym for 'sendOSC'.+sendBundle :: Transport t => t -> Bundle -> IO ()+sendBundle = sendOSC++-- * Receive++-- | Variant of 'recvPacket' that runs 'fromPacket'.+recvOSC :: (Transport t,OSC o) => t -> IO (Maybe o)+recvOSC = fmap fromPacket . recvPacket++-- | Variant of 'recvPacket' that runs 'packet_to_bundle'.+recvBundle :: (Transport t) => t -> IO Bundle+recvBundle = fmap packet_to_bundle . recvPacket++-- | Variant of 'recvPacket' that runs 'packet_to_message'.+recvMessage :: (Transport t) => t -> IO (Maybe Message)+recvMessage = fmap packet_to_message . recvPacket++-- | Variant of 'recvPacket' that runs 'packetMessages'.+recvMessages :: (Transport t) => t -> IO [Message]+recvMessages = fmap packetMessages . recvPacket++-- * Timeout++-- | Variant of 'recvPacket' that implements an /n/ second 'timeout'.+recvPacketTimeout :: (Transport t) => Double -> t -> IO (Maybe Packet)+recvPacketTimeout n fd = timeout_r n (recvPacket fd)++-- * Wait++-- | Wait for a 'Packet' where the supplied predicate is 'True',+-- discarding intervening packets.+waitUntil :: (Transport t) => t -> (Packet -> Bool) -> IO Packet+waitUntil t f = untilPredicate f (recvPacket t)++-- | Wait for a 'Packet' where the supplied function does not give+-- 'Nothing', discarding intervening packets.+waitFor :: (Transport t) => t -> (Packet -> Maybe a) -> IO a+waitFor t f = untilMaybe f (recvPacket t)++-- | 'waitUntil' 'packet_is_immediate'.+waitImmediate :: Transport t => t -> IO Packet+waitImmediate t = waitUntil t packet_is_immediate++-- | 'waitFor' 'packet_to_message', ie. an incoming 'Message' or+-- immediate mode 'Bundle' with one element.+waitMessage :: Transport t => t -> IO Message+waitMessage t = waitFor t packet_to_message++-- | A 'waitFor' for variant using 'packet_has_address' to match on+-- the 'Address_Pattern' of incoming 'Packets'.+waitAddress :: Transport t => t -> Address_Pattern -> IO Packet+waitAddress t s =+    let f o = if packet_has_address s o then Just o else Nothing+    in waitFor t f++-- | Variant on 'waitAddress' that returns matching 'Message'.+waitReply :: Transport t => t -> Address_Pattern -> IO Message+waitReply t s =+    let f = fromMaybe (error "waitReply: message not located?") .+            find (message_has_address s) .+            packetMessages+    in fmap f (waitAddress t s)++-- | Variant of 'waitReply' that runs 'messageDatum'.+waitDatum :: Transport t => t -> Address_Pattern -> IO [Datum]+waitDatum t = fmap messageDatum . waitReply t

@@ -0,0 +1,42 @@+-- | OSC over TCP implementation.+module Sound.OSC.Transport.FD.TCP where++import qualified Data.ByteString.Lazy as B {- bytestring -}+import Control.Monad+import Network {- network -}+import Sound.OpenSoundControl.Class+import Sound.OpenSoundControl.Coding+import Sound.OpenSoundControl.Coding.Byte+import Sound.OSC.Transport.FD+import System.IO++-- | The TCP transport handle data type.+data TCP = TCP {tcpHandle :: Handle}++instance Transport TCP where+   sendOSC (TCP fd) msg =+      do let b = encodeOSC msg+             n = fromIntegral (B.length b)+         B.hPut fd (B.append (encode_u32 n) b)+         hFlush fd+   recvPacket (TCP fd) =+      do b0 <- B.hGet fd 4+         b1 <- B.hGet fd (fromIntegral (decode_u32 b0))+         return (decodePacket b1)+   close (TCP fd) = hClose fd++-- | Make a 'TCP' connection.+openTCP :: String -> Int -> IO TCP+openTCP host =+    liftM TCP .+    connectTo host .+    PortNumber .+    fromIntegral++-- | A trivial 'TCP' /OSC/ server.+tcpServer' :: Int -> (TCP -> IO ()) -> IO ()+tcpServer' p f = do+  s <- listenOn (PortNumber (fromIntegral p))+  (sequence_ . repeat) (do (fd, _, _) <- accept s+                           f (TCP fd)+                           return ())

@@ -0,0 +1,70 @@+-- | OSC over UDP implementation.+module Sound.OSC.Transport.FD.UDP where++import Control.Monad+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as B+import qualified Network.Socket as N+import qualified Network.Socket.ByteString as C (sendTo,recvFrom)+import qualified Network.Socket.ByteString.Lazy as C (send,recv)+import Sound.OpenSoundControl.Class+import Sound.OpenSoundControl.Coding+import Sound.OpenSoundControl.Type+import Sound.OSC.Transport.FD++-- | The UDP transport handle data type.+data UDP = UDP {udpSocket :: N.Socket}++-- | Return the port number associated with the UDP socket.+udpPort :: Integral n => UDP -> IO n+udpPort (UDP fd) = fmap fromIntegral (N.socketPort fd)++instance Transport UDP where+   sendOSC (UDP fd) msg = void (C.send fd (encodeOSC msg))+   recvPacket (UDP fd) = liftM decodePacket (C.recv fd 8192)+   close (UDP fd) = N.sClose fd++-- | Create and initialise UDP socket.+udp_socket :: (N.Socket -> N.SockAddr -> IO ()) -> String -> Int -> IO UDP+udp_socket f host port = do+  fd <- N.socket N.AF_INET N.Datagram 0+  a <- N.inet_addr host+  let sa = N.SockAddrInet (fromIntegral port) a+  f fd sa+  return (UDP fd)++-- | Make a 'UDP' connection.+--+-- > let t = openUDP "127.0.0.1" 57110+-- > in withTransport t (\fd -> recvT 0.5 fd >>= print)+openUDP :: String -> Int -> IO UDP+openUDP = udp_socket N.connect+-- N.setSocketOption fd N.RecvTimeOut 1000++-- | Trivial 'UDP' server socket.+--+-- > import Control.Concurrent+--+-- > let {f fd = forever (recvMessage fd >>= print)+-- >     ;t = udpServer "127.0.0.1" 57300}+-- > in void (forkIO (withTransport t f))+--+-- > let t = openUDP "127.0.0.1" 57300+-- > in withTransport t (\fd -> sendMessage fd (message "/n" []))+udpServer :: String -> Int -> IO UDP+udpServer = udp_socket N.bindSocket++-- | Send variant to send to specified address.+sendTo :: OSC o => UDP -> o -> N.SockAddr -> IO ()+sendTo (UDP fd) o a = do+  -- Network.Socket.ByteString.Lazy.sendTo does not exist+  let o' = S.pack (B.unpack (encodeOSC o))+  void (C.sendTo fd o' a)++-- | Recv variant to collect message source address.+recvFrom :: UDP -> IO (Packet, N.SockAddr)+recvFrom (UDP fd) = do+  -- Network.Socket.ByteString.Lazy.recvFrom does not exist+  (s,a) <- C.recvFrom fd 8192+  let s' = B.pack (S.unpack s)+  return (decodePacket s',a)

@@ -0,0 +1,96 @@+-- | Monad class implementing an Open Sound Control transport.+module Sound.OSC.Transport.Monad where++import Control.Monad.Trans.Reader {- transformers -}+import Control.Monad.IO.Class as M+import Data.List+import Data.Maybe+import Sound.OpenSoundControl.Class+import qualified Sound.OSC.Transport.FD as T+import Sound.OpenSoundControl.Type+import Sound.OpenSoundControl.Wait++class (Functor m,Monad m,MonadIO m) => Transport m where+   -- | Encode and send an OSC packet.+   sendOSC :: OSC o => o -> m ()+   -- | Receive and decode an OSC packet.+   recvPacket :: m Packet++instance (T.Transport t,Functor io,MonadIO io) => Transport (ReaderT t io) where+   sendOSC o = ReaderT (M.liftIO . flip T.sendOSC o)+   recvPacket = ReaderT (M.liftIO . T.recvPacket)++-- | Transport connection.+type Connection t a = ReaderT t IO a++-- | Bracket Open Sound Control communication.+withTransport :: T.Transport t => IO t -> Connection t a -> IO a+withTransport u = T.withTransport u . runReaderT++-- * Send++-- | Type restricted synonym for 'sendOSC'.+sendMessage :: Transport m => Message -> m ()+sendMessage = sendOSC++-- | Type restricted synonym for 'sendOSC'.+sendBundle :: Transport m => Bundle -> m ()+sendBundle = sendOSC++-- * Receive++-- | Variant of 'recvPacket' that runs 'fromPacket'.+recvOSC :: (Transport m,OSC o) => m (Maybe o)+recvOSC = fmap fromPacket recvPacket++-- | Variant of 'recvPacket' that runs 'packet_to_bundle'.+recvBundle :: (Transport m) => m Bundle+recvBundle = fmap packet_to_bundle recvPacket++-- | Variant of 'recvPacket' that runs 'packet_to_message'.+recvMessage :: (Transport m) => m (Maybe Message)+recvMessage = fmap packet_to_message recvPacket++-- | Variant of 'recvPacket' that runs 'packetMessages'.+recvMessages :: (Transport m) => m [Message]+recvMessages = fmap packetMessages recvPacket++-- * Wait++-- | Wait for a 'Packet' where the supplied predicate is 'True',+-- discarding intervening packets.+waitUntil :: (Transport m) => (Packet -> Bool) -> m Packet+waitUntil f = untilPredicate f recvPacket++-- | Wait for a 'Packet' where the supplied function does not give+-- 'Nothing', discarding intervening packets.+waitFor :: (Transport m) => (Packet -> Maybe a) -> m a+waitFor f = untilMaybe f recvPacket++-- | 'waitUntil' 'packet_is_immediate'.+waitImmediate :: Transport m => m Packet+waitImmediate = waitUntil packet_is_immediate++-- | 'waitFor' 'packet_to_message', ie. an incoming 'Message' or+-- immediate mode 'Bundle' with one element.+waitMessage :: Transport m => m Message+waitMessage = waitFor packet_to_message++-- | A 'waitFor' for variant using 'packet_has_address' to match on+-- the 'Address_Pattern' of incoming 'Packets'.+waitAddress :: Transport m => Address_Pattern -> m Packet+waitAddress s =+    let f o = if packet_has_address s o then Just o else Nothing+    in waitFor f++-- | Variant on 'waitAddress' that returns matching 'Message'.+waitReply :: Transport m => Address_Pattern -> m Message+waitReply s =+    let f = fromMaybe (error "waitReply: message not located?") .+            find (message_has_address s) .+            packetMessages+    in fmap f (waitAddress s)++-- | Variant of 'waitReply' that runs 'messageDatum'.+waitDatum :: Transport m => Address_Pattern -> m [Datum]+waitDatum = fmap messageDatum . waitReply

@@ -1,46 +1,20 @@--- | An implementation of a subset of the /Open Sound Control/ byte--- protocol, documented at <http://opensoundcontrol.org/>.+-- | Composite of non-transport related modules. ----- For the most part this top-level module is the only import--- required.  It provides the 'Datum' and 'OSC' types, 'encodeOSC' and--- 'decodeOSC' functions, basic 'UDP' and 'TCP' 'Transport' layers,--- and basic temporal operations 'utcr' to access the current time and--- 'pauseThread' to delay the current thread.+-- Provides the 'Datum', 'Message', 'Bundle' and 'Packet' types and+-- the 'OSC' and 'Coding' type-classes. ----- > let o = Bundle immediately [Message "/g_free" [Int 0]]--- > in decodeOSC (encodeOSC o) == o-module Sound.OpenSoundControl (module Sound.OpenSoundControl.Type-                              ,module Sound.OpenSoundControl.Time-                              ,module Sound.OpenSoundControl.Transport-                              ,module Sound.OpenSoundControl.Transport.UDP-                              ,module Sound.OpenSoundControl.Transport.TCP-                              ,C.encodeOSC,C.decodeOSC-                              ,openUDP,udpServer-                              ,openTCP,tcpServer) where--import Sound.OpenSoundControl.Coding.Decode.Binary as C-import Sound.OpenSoundControl.Coding.Encode.Builder as C-import Sound.OpenSoundControl.Type-import Sound.OpenSoundControl.Time-import Sound.OpenSoundControl.Transport-import Sound.OpenSoundControl.Transport.UDP-import Sound.OpenSoundControl.Transport.TCP---- | Make a UDP connection.+-- The basic constructors are 'message' and 'bundle', the basic coding+-- functions are 'encodePacket' and 'decodePacket'. ----- > let t = openUDP "127.0.0.1" 57110--- > in withTransport t (\fd -> recvT 0.5 fd >>= print)-openUDP :: String -> Int -> IO UDP-openUDP = openUDP' (C.encodeOSC,C.decodeOSC)---- | Trivial udp server.-udpServer :: String -> Int -> IO UDP-udpServer = udpServer' (C.encodeOSC,C.decodeOSC)---- | Make a TCP connection.-openTCP :: String -> Int -> IO TCP-openTCP = openTCP' (C.encodeOSC,C.decodeOSC)+-- > import Sound.OpenSoundControl+-- >+-- > let {o = bundle immediately [message "/g_free" [Int 0]]+-- >     ;e = encodeBundle o :: String}+-- > in decodeBundle e == o+module Sound.OpenSoundControl (module M) where --- | A trivial TCP OSC server.-tcpServer :: Int -> (TCP -> IO ()) -> IO ()-tcpServer = tcpServer' (C.encodeOSC,C.decodeOSC)+import Sound.OpenSoundControl.Class as M+import Sound.OpenSoundControl.Coding as M+import Sound.OpenSoundControl.Type as M+import Sound.OpenSoundControl.Time as M+import Sound.OpenSoundControl.Wait as M

@@ -0,0 +1,31 @@+-- | Typeclass for encoding and decoding OSC packets.+module Sound.OpenSoundControl.Class where++import Sound.OpenSoundControl.Type+import Sound.OpenSoundControl.Coding++-- | A type-class for values that can be translated to and from OSC+-- 'Packet's.+class OSC o where+    toPacket :: o -> Packet -- ^ Translation to 'Packet'.+    fromPacket :: Packet -> Maybe o -- ^ Translation from 'Packet'.++instance OSC Message where+    toPacket = Packet_Message+    fromPacket = packet_to_message++instance OSC Bundle where+    toPacket = Packet_Bundle+    fromPacket = Just . packet_to_bundle++instance OSC Packet where+    toPacket = id+    fromPacket = Just++-- | 'encodePacket' '.' 'toPacket'.+encodeOSC :: (Coding c,OSC o) => o -> c+encodeOSC = encodePacket . toPacket++-- | 'fromPacket' '.' 'decodePacket'.+decodeOSC :: (Coding c,OSC o) => c -> Maybe o+decodeOSC = fromPacket . decodePacket

@@ -1,33 +1,47 @@ {-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-} -- | A type-class to provide coding operations to different data types --   using the same function names.-module Sound.OpenSoundControl.Coding (Coding(..),Coder) where+module Sound.OpenSoundControl.Coding where  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as C-import           Sound.OpenSoundControl.Type (OSC)+import Sound.OpenSoundControl.Type import qualified Sound.OpenSoundControl.Coding.Decode.Binary as Binary import qualified Sound.OpenSoundControl.Coding.Encode.Builder as Builder  -- | Converting from and to binary packet representations. class Coding a where-    -- | Decode an OSC packet.-    encodeOSC :: OSC -> a-    -- | Encode an OSC packet.-    decodeOSC :: a -> OSC+    encodePacket :: Packet -> a -- ^ Decode an OSC packet.+    decodePacket :: a -> Packet -- ^ Encode an OSC packet.  instance Coding S.ByteString where-    encodeOSC = Builder.encodeOSC'-    decodeOSC = Binary.decodeOSC'+    encodePacket = Builder.encodePacket_strict+    decodePacket = Binary.decodePacket_strict  instance Coding B.ByteString where-    encodeOSC = Builder.encodeOSC-    decodeOSC = Binary.decodeOSC+    encodePacket = Builder.encodePacket+    decodePacket = Binary.decodePacket  instance Coding String where-    encodeOSC = C.unpack . encodeOSC-    decodeOSC = decodeOSC . C.pack+    encodePacket = C.unpack . encodePacket+    decodePacket = decodePacket . C.pack --- | An 'encodeOSC' and 'decodeOSC' pair over 'B.ByteString'.-type Coder = (OSC -> B.ByteString,B.ByteString -> OSC)+-- | An 'encodePacket' and 'decodePacket' pair over 'B.ByteString'.+type Coder = (Packet -> B.ByteString,B.ByteString -> Packet)++-- | 'encodePacket' '.' 'Packet_Message'.+encodeMessage :: Coding c => Message -> c+encodeMessage = encodePacket . Packet_Message++-- | 'encodePacket' '.' 'Packet_Bundle'.+encodeBundle :: Coding c => Bundle -> c+encodeBundle = encodePacket . Packet_Bundle++-- | 'packet_to_message' '.' 'decodePacket'.+decodeMessage :: Coding c => c -> Maybe Message+decodeMessage = packet_to_message . decodePacket++-- | 'packet_to_bundle' '.' 'decodePacket'.+decodeBundle :: Coding c => c -> Bundle+decodeBundle = packet_to_bundle . decodePacket

@@ -89,6 +89,6 @@  -- | The number of bytes required to align an OSC value to the next --   4-byte boundary.-align :: (Num i, Bits i) => i -> i+align :: (Num i,Bits i) => i -> i {-# INLINE align #-} align n = ((n + 3) .&. complement 3) - n

@@ -3,13 +3,14 @@  import Sound.OpenSoundControl.Type --- | Map a normalizing function over datum at an osc packet.-coerce :: (Datum -> Datum) -> OSC -> OSC-coerce f o =-    case o of-      Message s xs -> Message s (map f xs)-      Bundle t xs -> Bundle t (map (coerce f) xs)+-- | Map a normalizing function over datum at an OSC 'Message'.+message_coerce :: (Datum -> Datum) -> Message -> Message+message_coerce f (Message s xs) = Message s (map f xs) +-- | Map a normalizing function over datum at an OSC 'Bundle'.+bundle_coerce :: (Datum -> Datum) -> Bundle -> Bundle+bundle_coerce f (Bundle t xs) = Bundle t (map (message_coerce f) xs)+ -- | Coerce Float to Double. f_to_d :: Datum -> Datum f_to_d d =@@ -34,5 +35,5 @@       _ -> d  -- | A normalized osc packet has only Int and Double numerical values.-normalize :: OSC -> OSC-normalize = coerce f_to_d+--normalize :: OSC -> OSC+--normalize = coerce f_to_d

@@ -1,6 +1,8 @@ -- | Base-level decode function for OSC packets (slow).  For ordinary --   use see 'Sound.OpenSoundControl.Coding.Decode.Binary'.-module Sound.OpenSoundControl.Coding.Decode.Base (decodeOSC) where+module Sound.OpenSoundControl.Coding.Decode.Base (decodeMessage+                                                 ,decodeBundle+                                                 ,decodePacket) where  import qualified Data.ByteString.Lazy as B import Data.List@@ -10,7 +12,7 @@ import Sound.OpenSoundControl.Type  -- The plain byte count of an OSC value.-size :: Char -> B.ByteString -> Int+size :: Datum_Type -> B.ByteString -> Int size ty b =     case ty of       'i' -> 4@@ -25,7 +27,7 @@       _ -> error "size: illegal type"  -- The storage byte count of an OSC value.-storage :: Char -> B.ByteString -> Int+storage :: Datum_Type -> B.ByteString -> Int storage ty b =     case ty of       's' -> let n = size 's' b + 1 in n + align n@@ -33,7 +35,7 @@       _ -> size ty B.empty  -- Decode an OSC datum-decode_datum :: Char -> B.ByteString -> Datum+decode_datum :: Datum_Type -> B.ByteString -> Datum decode_datum ty b =     case ty of       'i' -> Int (decode_i32 b)@@ -41,7 +43,7 @@       'd' -> Double (decode_f64 b)       's' -> String (decode_str (b_take (size 's' b) b))       'b' -> Blob (b_take (size 'b' b) (B.drop 4 b))-      't' -> TimeStamp $ NTPi (decode_u64 b)+      't' -> TimeStamp (NTPi (decode_u64 b))       'm' -> let [b0,b1,b2,b3] = B.unpack (B.take 4 b) in Midi (b0,b1,b2,b3)       _ -> error ("decode_datum: illegal type (" ++ [ty] ++ ")") @@ -52,9 +54,9 @@         f b' c = swap (B.splitAt (fromIntegral (storage c b')) b')     in zipWith decode_datum cs (snd (mapAccumL f b cs)) --- Decode an OSC message.-decode_message :: B.ByteString -> OSC-decode_message b =+-- | Decode an OSC 'Message'.+decodeMessage :: B.ByteString -> Message+decodeMessage b =     let n = storage 's' b         (String cmd) = decode_datum 's' b         m = storage 's' (b_drop n b)@@ -63,30 +65,31 @@     in Message cmd arg  -- Decode a sequence of OSC messages, each one headed by its length-decode_message_seq :: B.ByteString -> [OSC]+decode_message_seq :: B.ByteString -> [Message] decode_message_seq b =     let s = decode_i32 b-        m = decode_message $ b_drop 4 b-        nxt = decode_message_seq $ b_drop (4+s) b+        m = decodeMessage (b_drop 4 b)+        nxt = decode_message_seq (b_drop (4+s) b)     in if B.length b == 0 then [] else m:nxt -decode_bundle :: B.ByteString -> OSC-decode_bundle b =+-- | Decode an OSC 'Bundle'.+decodeBundle :: B.ByteString -> Bundle+decodeBundle b =     let h = storage 's' b -- header (should be '#bundle')         t = storage 't' (b_drop h b) -- time tag         (TimeStamp timeStamp) = decode_datum 't' (b_drop h b)-        ms = decode_message_seq $ b_drop (h+t) b+        ms = decode_message_seq (b_drop (h+t) b)     in Bundle timeStamp ms --- | Decode an OSC packet.+-- | Decode an OSC 'Packet'. -- -- > let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]--- > in decodeOSC b == Message "/g_free" [Int 0]-decodeOSC :: B.ByteString -> OSC-decodeOSC b =+-- > in decodePacket b == Message "/g_free" [Int 0]+decodePacket :: B.ByteString -> Packet+decodePacket b =     if bundleHeader `B.isPrefixOf` b-    then decode_bundle b-    else decode_message b+    then Packet_Bundle (decodeBundle b)+    else Packet_Message (decodeMessage b)  b_take :: Int -> B.ByteString -> B.ByteString b_take = B.take . fromIntegral

@@ -1,7 +1,8 @@ -- | Optimised decode function for OSC packets.-module Sound.OpenSoundControl.Coding.Decode.Binary (getOSC-                                                   ,decodeOSC-                                                   ,decodeOSC') where+module Sound.OpenSoundControl.Coding.Decode.Binary+    (getPacket+    ,decodePacket+    ,decodePacket_strict) where  import Control.Applicative import Data.Binary.Get@@ -46,23 +47,24 @@     return b  -- | Get an OSC datum.-get_datum :: Char -> Get Datum-get_datum 'i' = Int    <$> fromIntegral <$> getInt32be-get_datum 'f' = Float  <$> realToFrac <$> I.getFloat32be-get_datum 'd' = Double <$> I.getFloat64be-get_datum 's' = String <$> get_string-get_datum 'b' = Blob   <$> (get_bytes =<< getWord32be)-get_datum 't' = TimeStamp <$> NTPi <$> getWord64be-get_datum 'm' = do-    b0 <- getWord8-    b1 <- getWord8-    b2 <- getWord8-    b3 <- getWord8-    return $ Midi (b0,b1,b2,b3)-get_datum t = fail ("get_datum: illegal type " ++ show t)+get_datum :: Datum_Type -> Get Datum+get_datum ty =+    case ty of+      'i' -> Int    <$> fromIntegral <$> getInt32be+      'f' -> Float  <$> realToFrac <$> I.getFloat32be+      'd' -> Double <$> I.getFloat64be+      's' -> String <$> get_string+      'b' -> Blob   <$> (get_bytes =<< getWord32be)+      't' -> TimeStamp <$> NTPi <$> getWord64be+      'm' -> do b0 <- getWord8+                b1 <- getWord8+                b2 <- getWord8+                b3 <- getWord8+                return $ Midi (b0,b1,b2,b3)+      _ -> fail ("get_datum: illegal type " ++ show ty) --- | Get an OSC message.-get_message :: Get OSC+-- | Get an OSC 'Message'.+get_message :: Get Message get_message = do     cmd <- get_string     dsc <- get_string@@ -72,45 +74,42 @@             return $ Message cmd arg         _ -> fail "get_message: invalid type descriptor string" --- | Get an OSC packet.-get_packet :: Get OSC-get_packet = do-    h <- uncheckedLookAhead (L.length bundleHeader)-    if h == bundleHeader-        then get_bundle-        else get_message---- | Get a sequence of OSC messages, each one headed by its length.-get_packet_seq :: Get [OSC]-get_packet_seq = do+-- | Get a sequence of OSC 'Message's, each one headed by its length.+get_message_seq :: Get [Message]+get_message_seq = do     b <- isEmpty     if b         then return []         else do-            p <- flip isolate get_packet =<< getWord32be-            ps <- get_packet_seq+            p <- flip isolate get_message =<< getWord32be+            ps <- get_message_seq             return (p:ps) -get_bundle :: Get OSC+get_bundle :: Get Bundle get_bundle = do     skip (fromIntegral (L.length bundleHeader))     t <- NTPi <$> getWord64be-    ps <- get_packet_seq+    ps <- get_message_seq     return $ Bundle t ps --- | Get an OSC packet.-getOSC :: Get OSC-getOSC = get_packet+-- | Get an OSC 'Packet'.+getPacket :: Get Packet+getPacket = do+    h <- uncheckedLookAhead (L.length bundleHeader)+    if h == bundleHeader+        then fmap Packet_Bundle get_bundle+        else fmap Packet_Message get_message + -- | Decode an OSC packet from a lazy ByteString. -- -- > let b = L.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] -- > in decodeOSC b == Message "/g_free" [Int 0]-decodeOSC :: L.ByteString -> OSC-{-# INLINE decodeOSC #-}-decodeOSC = runGet getOSC+decodePacket :: L.ByteString -> Packet+{-# INLINE decodePacket #-}+decodePacket = runGet getPacket  -- | Decode an OSC packet from a strict ByteString.-decodeOSC' :: S.ByteString -> OSC-{-# INLINE decodeOSC' #-}-decodeOSC' = runGet getOSC . L.fromChunks . (:[])+decodePacket_strict :: S.ByteString -> Packet+{-# INLINE decodePacket_strict #-}+decodePacket_strict = runGet getPacket . L.fromChunks . (:[])

@@ -1,6 +1,8 @@ -- | Base-level encode function for OSC packets (slow).  For ordinary --   use see 'Sound.OpenSoundControl.Coding.Encode.Builder'.-module Sound.OpenSoundControl.Coding.Encode.Base (encodeOSC) where+module Sound.OpenSoundControl.Coding.Encode.Base (encodeMessage+                                                 ,encodeBundle+                                                 ,encodePacket) where  import qualified Data.ByteString.Lazy as B import Data.Word@@ -10,7 +12,7 @@  -- Command argument types are given by a descriptor. descriptor :: [Datum] -> Datum-descriptor l = String (',' : map tag l)+descriptor l = String (',' : map datum_tag l)  -- Align a byte string if required. extend :: Word8 -> B.ByteString -> B.ByteString@@ -29,29 +31,35 @@       Blob b -> let n = encode_i32 (fromIntegral (B.length b))                 in B.append n (extend 0 b) --- Encode an OSC message.-encode_message :: String -> [Datum] -> B.ByteString-encode_message c l =+-- | Encode an OSC 'Message'.+encodeMessage :: Message -> B.ByteString+encodeMessage (Message c l) =     B.concat [encode_datum (String c)              ,encode_datum (descriptor l)              ,B.concat (map encode_datum l) ] --- Encode an OSC packet as an OSC blob.-encode_osc_blob :: OSC -> Datum-encode_osc_blob = Blob . encodeOSC+-- Encode an OSC 'Message' as an OSC blob.+encode_message_blob :: Message -> Datum+encode_message_blob = Blob . encodeMessage  -- Encode an OSC bundle.-encode_bundle_ntpi :: NTPi -> [OSC] -> B.ByteString+encode_bundle_ntpi :: NTPi -> [Message] -> B.ByteString encode_bundle_ntpi t l =     B.concat [bundleHeader              ,encode_u64 t-             ,B.concat (map (encode_datum . encode_osc_blob) l) ]+             ,B.concat (map (encode_datum . encode_message_blob) l) ] --- | Encode an OSC packet.-encodeOSC :: OSC -> B.ByteString-encodeOSC o =-    case o of-      Message c l -> encode_message c l+-- | Encode an OSC 'Bundle'.+encodeBundle :: Bundle -> B.ByteString+encodeBundle b =+    case b of       Bundle (NTPi t) l -> encode_bundle_ntpi t l       Bundle (NTPr t) l -> encode_bundle_ntpi (ntpr_ntpi t) l       Bundle (UTCr t) l -> encode_bundle_ntpi (utcr_ntpi t) l++-- | Encode an OSC 'Packet'.+encodePacket :: Packet -> B.ByteString+encodePacket o =+    case o of+      Packet_Message m -> encodeMessage m+      Packet_Bundle b -> encodeBundle b

@@ -1,7 +1,10 @@ -- | Optimised encode function for OSC packets.-module Sound.OpenSoundControl.Coding.Encode.Builder (buildOSC-                                                    ,encodeOSC-                                                    ,encodeOSC') where+module Sound.OpenSoundControl.Coding.Encode.Builder+    (build_packet+    ,encodeMessage+    ,encodeBundle+    ,encodePacket+    ,encodePacket_strict) where  import qualified Data.Binary.IEEE754 as I import qualified Data.ByteString as S@@ -12,11 +15,11 @@ import Data.Word (Word8) import Sound.OpenSoundControl.Coding.Byte (align, bundleHeader) import Sound.OpenSoundControl.Time-import Sound.OpenSoundControl.Type (Datum(..), OSC(..), tag)+import Sound.OpenSoundControl.Type  -- Command argument types are given by a descriptor. descriptor :: [Datum] -> String-descriptor l = ',' : map tag l+descriptor l = ',' : map datum_tag l  -- Generate a list of zero bytes for padding. padding :: Integral i => i -> [Word8]@@ -34,44 +37,59 @@  -- Encode an OSC datum. build_datum :: Datum -> B.Builder-build_datum (Int i)              = B.fromInt32be (fromIntegral i)-build_datum (Float f)            = B.fromWord32be (I.floatToWord (realToFrac f))-build_datum (Double d)           = B.fromWord64be (I.doubleToWord d)-build_datum (TimeStamp t)        = B.fromWord64be (fromIntegral (as_ntpi t))-build_datum (String s)           = build_string s-build_datum (Midi (b0,b1,b2,b3)) = B.fromWord8s [b0,b1,b2,b3]-build_datum (Blob b)             = build_bytes b+build_datum d =+    case d of+      Int i -> B.fromInt32be (fromIntegral i)+      Float n -> B.fromWord32be (I.floatToWord (realToFrac n))+      Double n -> B.fromWord64be (I.doubleToWord n)+      TimeStamp t -> B.fromWord64be (fromIntegral (as_ntpi t))+      String s -> build_string s+      Midi (b0,b1,b2,b3) -> B.fromWord8s [b0,b1,b2,b3]+      Blob b -> build_bytes b --- Encode an OSC message.-build_message :: String -> [Datum] -> B.Builder-build_message c l =-    mconcat [ build_string c-            , build_string (descriptor l)-            , mconcat $ map build_datum l ]+-- Encode an OSC 'Message'.+build_message :: Message -> B.Builder+build_message (Message c l) =+    mconcat [build_string c+            ,build_string (descriptor l)+            ,mconcat $ map build_datum l] --- Encode an OSC bundle.-build_bundle_ntpi :: NTPi -> [OSC] -> B.Builder+-- Encode an OSC 'Bundle'.+build_bundle_ntpi :: NTPi -> [Message] -> B.Builder build_bundle_ntpi t l =-    mconcat [ B.fromLazyByteString bundleHeader-            , B.fromWord64be t-            , mconcat $ map (build_bytes . B.toLazyByteString . buildOSC) l ]+    mconcat [B.fromLazyByteString bundleHeader+            ,B.fromWord64be t+            ,mconcat $ map (build_bytes . B.toLazyByteString . build_message) l] --- | Builder monoid for an OSC packet.-buildOSC :: OSC -> B.Builder-buildOSC (Message c l)       = build_message c l-buildOSC (Bundle (NTPi t) l) = build_bundle_ntpi t l-buildOSC (Bundle (NTPr t) l) = build_bundle_ntpi (ntpr_ntpi t) l-buildOSC (Bundle (UTCr t) l) = build_bundle_ntpi (utcr_ntpi t) l+-- | Builder monoid for an OSC 'Packet'.+build_packet :: Packet -> B.Builder+build_packet o =+    case o of+      Packet_Message m -> build_message m+      Packet_Bundle (Bundle (NTPi t) l) -> build_bundle_ntpi t l+      Packet_Bundle (Bundle (NTPr t) l) -> build_bundle_ntpi (ntpr_ntpi t) l+      Packet_Bundle (Bundle (UTCr t) l) -> build_bundle_ntpi (utcr_ntpi t) l --- | Encode an OSC packet to a lazy ByteString.+{-# INLINE encodeMessage #-}+{-# INLINE encodeBundle #-}+{-# INLINE encodePacket #-}+{-# INLINE encodePacket_strict #-}++-- | Encode an OSC 'Message'.+encodeMessage :: Message -> L.ByteString+encodeMessage = B.toLazyByteString . build_packet . Packet_Message++-- | Encode an OSC 'Bundle'.+encodeBundle :: Bundle -> L.ByteString+encodeBundle = B.toLazyByteString . build_packet . Packet_Bundle++-- | Encode an OSC 'Packet' to a lazy 'L.ByteString'. -- -- > let b = L.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] -- > in encodeOSC (Message "/g_free" [Int 0]) == b-encodeOSC :: OSC -> L.ByteString-{-# INLINE encodeOSC #-}-encodeOSC = B.toLazyByteString . buildOSC+encodePacket :: Packet -> L.ByteString+encodePacket = B.toLazyByteString . build_packet --- | Encode an OSC packet to a strict ByteString.-encodeOSC' :: OSC -> S.ByteString-{-# INLINE encodeOSC' #-}-encodeOSC' = B.toByteString . buildOSC+-- | Encode an Packet packet to a strict ByteString.+encodePacket_strict :: Packet -> S.ByteString+encodePacket_strict = B.toByteString . build_packet

@@ -1,9 +1,17 @@--- | Temporal representations and clock operations (read current time---   and pause thread).+-- | OSC related timing functions.+--+-- OSC timestamps are @NTP@ values, <http://ntp.org/>.+-- 'T.getCurrentTime' gives @UTC@ values.  The 'Time' type is a union+-- of the different representations.+--+-- 'utcr' reads the current time as real valued @UTC@ and+-- 'pauseThread' suspends the current thread for a real valued number+-- of seconds. module Sound.OpenSoundControl.Time where  import Control.Concurrent import Control.Monad+import Control.Monad.IO.Class import Data.Word import qualified Data.Time as T @@ -77,6 +85,10 @@         s = T.secondsToDiffTime 0     in T.UTCTime d s +-- | Convert an 'T.UTCTime' timestamp to a real-valued UTC timestamp.+utc_utcr :: T.UTCTime -> Double+utc_utcr t = realToFrac (T.diffUTCTime t utc_base)+ -- | Constant indicating the bundle is to be executed immediately. immediately :: Time immediately = NTPi 1@@ -84,15 +96,15 @@ -- * Clock operations  -- | Read current real-valued @UTC@ timestamp.-utcr :: IO Double-utcr = do-  t <- T.getCurrentTime-  return (realToFrac (T.diffUTCTime t utc_base))+utcr :: MonadIO m => m Double+utcr = liftIO (fmap utc_utcr T.getCurrentTime)  -- | Read current 'NTPi' timestamp.-ntpi :: IO NTPi+ntpi ::  MonadIO m => m NTPi ntpi = liftM utcr_ntpi utcr +-- * Thread operations.+ -- | The 'pauseThread' limit (in seconds).  Values larger than this -- require a different thread delay mechanism, see 'sleepThread'.  The -- value is the number of microseconds in @maxBound::Int@.@@ -102,17 +114,17 @@ -- | Pause current thread for the indicated duration (in seconds), see --   'pauseThreadLimit'.  Note also that this function does not --   attempt pauses less than @1e-4@.-pauseThread :: Double -> IO ()-pauseThread n = when (n > 1e-4) (threadDelay (floor (n * 1e6)))+pauseThread :: MonadIO m => Double -> m ()+pauseThread n = when (n > 1e-4) (liftIO (threadDelay (floor (n * 1e6))))  -- | Pause current thread until the given real-valued @UTC@ time, see -- 'pauseThreadLimit'.-pauseThreadUntil :: Double -> IO ()+pauseThreadUntil :: MonadIO m => Double -> m () pauseThreadUntil t = pauseThread . (t -) =<< utcr  -- | Sleep current thread for the indicated duration (in seconds). --   Divides long sleeps into parts smaller than 'pauseThreadLimit'.-sleepThread :: Double -> IO ()+sleepThread :: MonadIO m => Double -> m () sleepThread n =     if n >= pauseThreadLimit     then let n' = pauseThreadLimit - 1@@ -121,5 +133,5 @@  -- | Sleep current thread until the given real-valued @UTC@ time. -- Divides long sleeps into parts smaller than 'pauseThreadLimit'.-sleepThreadUntil :: Double -> IO ()+sleepThreadUntil :: MonadIO m => Double -> m () sleepThreadUntil t = sleepThread . (t -) =<< utcr

@@ -1,56 +0,0 @@--- | An abstract transport layer. hosc provides implementations for---   UDP and TCP transport.-module Sound.OpenSoundControl.Transport (Transport(..)-                                        ,withTransport-                                        ,recvT-                                        ,waitFor,wait) where--import Control.Exception-import Sound.OpenSoundControl.Type-import System.Timeout---- | Abstract over the underlying transport protocol.-class Transport t where-   -- | Encode and send an OSC packet.-   send :: t -> OSC -> IO ()-   -- | Receive and decode an OSC packet.-   recv :: t -> IO OSC-   -- | Close an existing connection.-   close :: t -> IO ()---- Does the OSC message have the specified address.-has_address :: String -> OSC -> Bool-has_address x o =-    case o of-      Message y _ -> x == y-      _ -> False---- Repeat action until `f' does not give Nothing when applied to result.-untilM :: Monad m => (a -> Maybe b) -> m a -> m b-untilM f act =-    let g p = let q = f p in case q of { Nothing -> rec-                                       ; Just r -> return r }-        rec = act >>= g-    in rec---- | Real valued variant of 'timeout'.-timeout_r :: Double -> IO a -> IO (Maybe a)-timeout_r t = timeout (floor (t * 1000000))---- | Variant that wraps 'recv' in an /n/ second 'timeout'.-recvT :: Transport t => Double -> t -> IO (Maybe OSC)-recvT n fd = timeout_r n (recv fd)---- | Wait for an OSC message where the supplied function does not give---   Nothing, discarding intervening messages.-waitFor :: Transport t => t -> (OSC -> Maybe a) -> IO a-waitFor t f = untilM f (recv t)---- | A 'waitFor' for variant matching on the address string of---   incoming messages.-wait :: Transport t => t -> String -> IO OSC-wait t s = waitFor t (\o -> if has_address s o then Just o else Nothing)---- | Bracket OSC communication.-withTransport :: Transport t => IO t -> (t -> IO a) -> IO a-withTransport u = bracket u close

@@ -1,46 +0,0 @@--- | OSC over TCP implementation.-module Sound.OpenSoundControl.Transport.TCP (TCP(..)-                                            ,openTCP'-                                            ,tcpServer') where--import qualified Data.ByteString.Lazy as B-import Control.Monad-import Network-import Sound.OpenSoundControl.Coding-import Sound.OpenSoundControl.Coding.Byte-import Sound.OpenSoundControl.Transport-import Sound.OpenSoundControl.Type-import System.IO---- | The TCP transport handle data type.-data TCP = TCP {tcpEncode :: OSC -> B.ByteString-               ,tcpDecode :: B.ByteString -> OSC-               ,tcpHandle :: Handle}--instance Transport TCP where-   send (TCP enc _ fd) msg =-      do let b = enc msg-             n = fromIntegral (B.length b)-         B.hPut fd (B.append (encode_u32 n) b)-         hFlush fd-   recv (TCP _ dec fd) =-      do b0 <- B.hGet fd 4-         b1 <- B.hGet fd (fromIntegral (decode_u32 b0))-         return (dec b1)-   close (TCP _ _ fd) = hClose fd---- | Make a TCP connection using specified coder.-openTCP' :: Coder -> String -> Int -> IO TCP-openTCP' (enc,dec) host =-    liftM (TCP enc dec) .-    connectTo host .-    PortNumber .-    fromIntegral---- | A trivial TCP OSC server using specified coder.-tcpServer' :: Coder -> Int -> (TCP -> IO ()) -> IO ()-tcpServer' (enc,dec) p f = do-  s <- listenOn (PortNumber (fromIntegral p))-  (sequence_ . repeat) (do (fd, _, _) <- accept s-                           f (TCP enc dec fd)-                           return ())

@@ -1,62 +0,0 @@--- | OSC over UDP implementation.-module Sound.OpenSoundControl.Transport.UDP (UDP(..),udpPort-                                            ,openUDP'-                                            ,udpServer'-                                            ,sendTo,recvFrom) where--import Control.Monad-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as B-import qualified Network.Socket as N-import qualified Network.Socket.ByteString as C (sendTo,recvFrom)-import qualified Network.Socket.ByteString.Lazy as C (send,recv)-import Sound.OpenSoundControl.Coding-import Sound.OpenSoundControl.Transport-import Sound.OpenSoundControl.Type---- | The UDP transport handle data type.-data UDP = UDP {udpEncode :: OSC -> B.ByteString-               ,udpDecode :: B.ByteString -> OSC-               ,udpSocket :: N.Socket}---- | Return the port number associated with the UDP socket.-udpPort :: Integral n => UDP -> IO n-udpPort (UDP _ _ fd) = fmap fromIntegral (N.socketPort fd)--instance Transport UDP where-   send  (UDP enc _ fd) msg = C.send fd (enc msg) >> return ()-   recv  (UDP _ dec fd) = liftM dec (C.recv fd 8192)-   close (UDP _ _ fd) = N.sClose fd---- | Make a UDP connection with specified coder.-openUDP' :: Coder -> String -> Int -> IO UDP-openUDP' (enc,dec) host port = do-  fd <- N.socket N.AF_INET N.Datagram 0-  a <- N.inet_addr host-  N.connect fd (N.SockAddrInet (fromIntegral port) a)-  -- N.setSocketOption fd N.RecvTimeOut 1000-  return (UDP enc dec fd)---- | Trivial udp server with specified coder.-udpServer' :: Coder -> String -> Int -> IO UDP-udpServer' (enc,dec) host port = do-  fd <- N.socket N.AF_INET N.Datagram 0-  a  <- N.inet_addr host-  let sa = N.SockAddrInet (fromIntegral port) a-  N.bindSocket fd sa-  return (UDP enc dec fd)---- | Send variant to send to specified address.-sendTo :: UDP -> OSC -> N.SockAddr -> IO ()-sendTo (UDP enc _ fd) o a = do-  -- Network.Socket.ByteString.Lazy.sendTo does not exist-  let o' = S.pack (B.unpack (enc o))-  C.sendTo fd o' a >> return ()---- | Recv variant to collect message source address.-recvFrom :: UDP -> IO (OSC, N.SockAddr)-recvFrom (UDP _ dec fd) = do-  -- Network.Socket.ByteString.Lazy.recvFrom does not exist-  (s,a) <- C.recvFrom fd 8192-  let s' = B.pack (S.unpack s)-  return (dec s',a)

@@ -1,14 +1,15 @@ -- | Alegbraic data types for OSC datum and packets.-module Sound.OpenSoundControl.Type (OSC(..)-                                   ,Datum(..)-                                   ,message-                                   ,bundle-                                   ,tag) where+module Sound.OpenSoundControl.Type where  import qualified Data.ByteString.Lazy as B+import Data.List+import Data.Maybe import Data.Word import Sound.OpenSoundControl.Time +-- | Type enumerating Datum categories.+type Datum_Type = Char+ -- | The basic elements of OSC messages. data Datum = Int Int            | Float Double@@ -19,20 +20,49 @@            | Midi (Word8,Word8,Word8,Word8)              deriving (Eq,Read,Show) --- | An OSC packet.-data OSC = Message String [Datum]-         | Bundle Time [OSC]-           deriving (Eq,Read,Show)+-- | OSC address pattern.+type Address_Pattern = String --- | OSC bundles can be ordered (time ascending).  Bundles and---   messages compare 'EQ'.-instance Ord OSC where+-- | An OSC message.+data Message = Message {messageAddress :: Address_Pattern+                       ,messageDatum :: [Datum]}+               deriving (Eq,Read,Show)++-- | An OSC bundle.+data Bundle = Bundle {bundleTime :: Time+                     ,bundleMessages :: [Message]}+              deriving (Eq,Read,Show)++-- | An OSC 'Packet' is either a 'Message' or a 'Bundle'.+data Packet = Packet_Message {packetMessage :: Message}+            | Packet_Bundle {packetBundle :: Bundle}+              deriving (Eq,Read,Show)++-- | OSC 'Bundle's can be ordered (time ascending).+instance Ord Bundle where     compare (Bundle a _) (Bundle b _) = compare a b-    compare _ _ = EQ +-- | 'Bundle' constructor. It is an 'error' if the 'Message' list is+-- empty.+bundle :: Time -> [Message] -> Bundle+bundle t xs =+    case xs of+      [] -> error "bundle: empty?"+      _ -> Bundle t xs++-- | 'Message' constructor.  It is an 'error' if the 'Address_Pattern'+-- doesn't conform to the OSC specification.+message :: Address_Pattern -> [Datum] -> Message+message a xs =+    case a of+      '/':_ -> Message a xs+      _ -> error "message: ill-formed address pattern"++-- * Datum+ -- | Single character identifier of an OSC datum.-tag :: Datum -> Char-tag dt =+datum_tag :: Datum -> Datum_Type+datum_tag dt =     case dt of       Int _ -> 'i'       Float _ -> 'f'@@ -42,17 +72,179 @@       TimeStamp _ -> 't'       Midi _ -> 'm' --- | Bundle constructor. It is an 'error' if the 'OSC' list is empty.-bundle :: Time -> [OSC] -> OSC-bundle t xs =-    case xs of-      [] -> error "bundle: empty?"-      _ -> Bundle t xs+-- | Variant of 'read'.+readMaybe :: (Read a) => String -> Maybe a+readMaybe s =+    case reads s of+      [(x, "")] -> Just x+      _ -> Nothing --- | Message constructor.  It is an 'error' if the address doesn't--- conform to the OSC specification.-message :: String -> [Datum] -> OSC-message a xs =-    case a of-      '/':_ -> Message a xs-      _ -> error "message: ill-formed address"+-- | Given 'Datum_Type' attempt to parse 'Datum' at 'String'.+--+-- > parse_datum 'i' "42" == Just (Int 42)+-- > parse_datum 'f' "3.14159" == Just (Float 3.14159)+-- > parse_datum 'd' "3.14159" == Just (Double 3.14159)+-- > parse_datum 's' "\"pi\"" == Just (String "pi")+-- > parse_datum 'b' "pi" == Just (Blob (B.pack [112,105]))+-- > parse_datum 'm' "(0,144,60,90)" == Just (Midi (0,144,60,90))+parse_datum :: Datum_Type -> String -> Maybe Datum+parse_datum ty =+    case ty of+      'i' -> fmap Int . readMaybe+      'f' -> fmap Float . readMaybe+      'd' -> fmap Double . readMaybe+      's' -> fmap String . readMaybe+      'b' -> Just . Blob . B.pack . map (fromIntegral . fromEnum)+      't' -> error "parse_datum: timestamp"+      'm' -> fmap Midi . readMaybe+      _ -> error "parse_datum: type"++-- | 'Datum' as real number if 'Double', 'Float' or 'Int', else 'Nothing'.+--+-- > map datum_real [Int 5,Float 5,String "5"] == [Just 5,Just 5,Nothing]+datum_real :: Datum -> Maybe Double+datum_real d =+    case d of+      Double n -> Just n+      Float n -> Just n+      Int n -> Just (fromIntegral n)+      _ -> Nothing++-- | A 'fromJust' variant of 'datum_real'.+--+-- > map datum_real_err [Int 5,Float 5] == [5,5]+datum_real_err :: Datum -> Double+datum_real_err = fromJust . datum_real++-- | 'Datum' as integral number if 'Double', 'Float' or 'Int', else+-- 'Nothing'.+--+-- > map datum_int [Int 5,Float 5.5,String "5"] == [Just 5,Just 5,Nothing]+datum_int :: Integral i => Datum -> Maybe i+datum_int d =+    case d of+      Int x -> Just (fromIntegral x)+      Float x -> Just (floor x)+      Double x -> Just (floor x)+      _ -> Nothing++-- | A 'fromJust' variant of 'datum_int'.+--+-- > map datum_int_err [Int 5,Float 5.5] == [5,5]+datum_int_err :: Integral i => Datum -> i+datum_int_err = fromJust . datum_int++-- | 'Datum' as 'String' if 'String' or 'Blob', else 'Nothing'.+--+-- > map datum_string [String "5",Blob (B.pack [53])] == [Just "5",Just "5"]+datum_string :: Datum -> Maybe String+datum_string d =+    case d of+      Blob s -> Just (map (toEnum . fromIntegral) (B.unpack s))+      String s -> Just s+      _ -> Nothing++-- | A 'fromJust' variant of 'datum_string'.+--+-- > map datum_string_err [String "5",Blob (B.pack [53])] == ["5","5"]+datum_string_err :: Datum -> String+datum_string_err = fromJust . datum_string++-- * Address++-- | Does 'Message' have the specified 'Address_Pattern'.+message_has_address :: Address_Pattern -> Message -> Bool+message_has_address x = (== x) . messageAddress++-- | Do any of the 'Message's at 'Bundle' have the specified+-- 'Address_Pattern'.+bundle_has_address :: Address_Pattern -> Bundle -> Bool+bundle_has_address x = any (message_has_address x) . bundleMessages++-- * Packet++-- | Does 'Packet' have the specified 'Address_Pattern', ie.+-- 'message_has_address' or 'bundle_has_address'.+packet_has_address :: Address_Pattern -> Packet -> Bool+packet_has_address x =+    at_packet (message_has_address x)+              (bundle_has_address x)++-- | The 'Time' of 'Packet', if the 'Packet' is a 'Message' this is+-- 'immediately'.+packetTime :: Packet -> Time+packetTime = at_packet (const immediately) bundleTime++-- | Retrieve the set of 'Message's from a 'Packet'.+packetMessages :: Packet -> [Message]+packetMessages = at_packet return bundleMessages++-- | If 'Packet' is a 'Message' add 'immediately' timestamp, else 'id'.+packet_to_bundle :: Packet -> Bundle+packet_to_bundle = at_packet (\m -> Bundle immediately [m]) id++-- | If 'Packet' is a 'Message' or a 'Bundle' with an /immediate/ time+-- tag and with one element, return the 'Message', else 'Nothing'.+packet_to_message :: Packet -> Maybe Message+packet_to_message p =+    case p of+      Packet_Bundle b ->+          case b of+            Bundle t [m] -> if t == immediately then Just m else Nothing+            _ -> Nothing+      Packet_Message m -> Just m++-- | Is 'Packet' immediate, ie. a 'Bundle' with timestamp+-- 'immediately', or a plain Message.+packet_is_immediate :: Packet -> Bool+packet_is_immediate = (== immediately) . packetTime++-- | Variant of 'either' for 'Packet'.+at_packet :: (Message -> a) -> (Bundle -> a) -> Packet -> a+at_packet f g p =+    case p of+      Packet_Message m -> f m+      Packet_Bundle b -> g b++-- * Pretty printing++-- | Pretty printer for 'Time'.+--+-- > map timePP [UTCr 0,NTPr 0,NTPi 0]+timePP :: Time -> String+timePP t =+    case t of+      UTCr n -> 'U' : show n+      NTPr n -> 'N' : show n+      NTPi i -> 'N' : show (ntpi_ntpr i)++-- | Pretty printer for 'Datum'.+--+-- > map datumPP [Float 1.2,String "str",Midi (0,0x90,0x40,0x60)]+datumPP :: Datum -> String+datumPP d =+    case d of+      Int n -> show n+      Float n -> show n+      Double n -> show n+      String s -> show s+      Blob s -> show s+      TimeStamp t -> timePP t+      Midi (p,q,r,s) -> '<' : intercalate "," (map show [p,q,r,s]) ++ ">"++-- | Pretty printer for 'Message'.+messagePP :: Message -> String+messagePP (Message a d) = unwords ("#message" : a : map datumPP d)++-- | Pretty printer for 'Bundle'.+bundlePP :: Bundle -> String+bundlePP (Bundle t m) =+    let m' = intersperse ";" (map messagePP m)+    in unwords ("#bundle" : timePP t : m')++-- | Pretty printer for 'Packet'.+packetPP :: Packet -> String+packetPP p =+    case p of+      Packet_Message m -> messagePP m+      Packet_Bundle b -> bundlePP b

@@ -0,0 +1,27 @@+module Sound.OpenSoundControl.Wait where++import System.Timeout++-- * Timeout++-- | Real valued variant of 'timeout'.+timeout_r :: Double -> IO a -> IO (Maybe a)+timeout_r t = timeout (floor (t * 1000000))++-- * Wait++-- | Repeat action until predicate /f/ is 'True' when applied to+-- result.+untilPredicate :: Monad m => (a -> Bool) -> m a -> m a+untilPredicate f act =+    let g p = if f p then rec else return p+        rec = act >>= g+    in rec++-- | Repeat action until /f/ does not give 'Nothing' when applied to+-- result.+untilMaybe :: Monad m => (a -> Maybe b) -> m a -> m b+untilMaybe f act =+    let g p = case f p of {Nothing -> rec;Just r -> return r}+        rec = act >>= g+    in rec

@@ -1,17 +1,27 @@ Name:              hosc-Version:           0.11.1+Version:           0.12 Synopsis:          Haskell Open Sound Control-Description:       @hosc@ provides "Sound.OpenSoundControl", an-                   implementation of a subset of the /Open Sound Control/-                   byte protocol documented at <http://opensoundcontrol.org/>.+Description:       @hosc@ implements a subset of the /Open Sound Control/+                   byte protocol, <http://opensoundcontrol.org/>.+                   .+                   "Sound.OpenSoundControl" implements the actual protocol.+                   .+                   "Sound.OSC.Transport.FD" implements a+                   /file descriptor/ based transport layer for @UDP@+                   and @TCP@.+                   .+                   "Sound.OSC.Transport.Monad" implements a+                   monadic interface to the @FD@ transport layer.+                   .+                   Composite modules are at "Sound.OSC" and "Sound.OSC.FD". License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape, Stefan Kersten and others, 2006-2011+Copyright:         (c) Rohan Drape, Stefan Kersten and others, 2006-2012 Author:            Rohan Drape, Stefan Kersten Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://slavepianos.org/rd/?t=hosc-Tested-With:       GHC == 7.2.2+Homepage:          http://rd.slavepianos.org/?t=hosc+Tested-With:       GHC == 7.6.1 Build-Type:        Simple Cabal-Version:     >= 1.8 Data-Files:        README@@ -23,9 +33,11 @@                    bytestring,                    data-binary-ieee754,                    network >= 2.3,-                   time+                   time,+                   transformers   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Sound.OpenSoundControl+                   Sound.OpenSoundControl.Class                    Sound.OpenSoundControl.Coding.Byte                    Sound.OpenSoundControl.Coding.Cast                    Sound.OpenSoundControl.Coding.Coerce@@ -36,10 +48,14 @@                    Sound.OpenSoundControl.Type                    Sound.OpenSoundControl.Coding                    Sound.OpenSoundControl.Time-                   Sound.OpenSoundControl.Transport-                   Sound.OpenSoundControl.Transport.TCP-                   Sound.OpenSoundControl.Transport.UDP+                   Sound.OpenSoundControl.Wait+                   Sound.OSC+                   Sound.OSC.FD+                   Sound.OSC.Transport.FD+                   Sound.OSC.Transport.FD.TCP+                   Sound.OSC.Transport.FD.UDP+                   Sound.OSC.Transport.Monad  Source-Repository  head   Type:            darcs-  Location:        http://slavepianos.org/rd/sw/hosc/+  Location:        http://rd.slavepianos.org/sw/hosc/