diff --git a/README b/README
--- a/README
+++ b/README
@@ -1,10 +1,10 @@
hosc - haskell open sound control
---------------------------------
-[hosc][hosc] provides Sound.OpenSoundControl, a [haskell][hs]
+[hosc][hosc] provides `Sound.OSC`, a [haskell][hs]
module implementing a subset of the [Open Sound Control][osc] byte protocol.
-© [rohan drape][rd], [stefan kersten][sk] and others, 2006-2012,
+© [rohan drape][rd], [stefan kersten][sk] and others, 2006-2013,
[gpl][gpl]. with contributions by:
- [alex mclean][am]
diff --git a/Sound/OSC.hs b/Sound/OSC.hs
--- a/Sound/OSC.hs
+++ b/Sound/OSC.hs
@@ -1,9 +1,8 @@
--- | Composite of "Sound.OpenSoundControl" and
--- "Sound.OSC.Transport.Monad".
+-- | Composite of "Sound.OSC.Core" 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.Core 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
diff --git a/Sound/OSC/Class.hs b/Sound/OSC/Class.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Class.hs
@@ -0,0 +1,31 @@
+-- | Typeclass for encoding and decoding OSC packets.
+module Sound.OSC.Class where
+
+import Sound.OSC.Type
+import Sound.OSC.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
diff --git a/Sound/OSC/Coding.hs b/Sound/OSC/Coding.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-}
+-- | A type-class to provide coding operations to different data types
+-- using the same function names.
+module Sound.OSC.Coding where
+
+import qualified Data.ByteString as S {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -}
+
+import Sound.OSC.Type
+import qualified Sound.OSC.Coding.Decode.Binary as Binary
+import qualified Sound.OSC.Coding.Encode.Builder as Builder
+
+-- | Converting from and to binary packet representations.
+class Coding a where
+ encodePacket :: Packet -> a -- ^ Decode an OSC packet.
+ decodePacket :: a -> Packet -- ^ Encode an OSC packet.
+
+instance Coding S.ByteString where
+ encodePacket = Builder.encodePacket_strict
+ decodePacket = Binary.decodePacket_strict
+
+instance Coding B.ByteString where
+ encodePacket = Builder.encodePacket
+ decodePacket = Binary.decodePacket
+
+instance Coding String where
+ encodePacket = C.unpack . encodePacket
+ decodePacket = decodePacket . C.pack
+
+-- | 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
diff --git a/Sound/OSC/Coding/Byte.hs b/Sound/OSC/Coding/Byte.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Byte.hs
@@ -0,0 +1,104 @@
+-- | Byte-level coding utility functions.
+module Sound.OSC.Coding.Byte where
+
+import Data.Binary {- base -}
+import Data.Bits {- base -}
+import qualified Data.ByteString as S.B {- bytestring -}
+import qualified Data.ByteString.Char8 as S.C {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -}
+import Data.Int {- base -}
+
+import Sound.OSC.Coding.Cast
+import Sound.OSC.Type
+
+-- | Encode a signed 8-bit integer.
+encode_i8 :: Int -> B.ByteString
+encode_i8 n = encode (fromIntegral n :: Int8)
+
+-- | Encode a signed 16-bit integer.
+encode_i16 :: Int -> B.ByteString
+encode_i16 n = encode (fromIntegral n :: Int16)
+
+-- | Encode a signed 32-bit integer.
+encode_i32 :: Int -> B.ByteString
+encode_i32 n = encode (fromIntegral n :: Int32)
+
+-- | Encode an unsigned 16-bit integer.
+encode_u32 :: Int -> B.ByteString
+encode_u32 n = encode (fromIntegral n :: Word32)
+
+-- | Encode a signed 64-bit integer.
+encode_i64 :: Int64 -> B.ByteString
+encode_i64 = encode
+
+-- | Encode an unsigned 64-bit integer.
+encode_u64 :: Word64 -> B.ByteString
+encode_u64 = encode
+
+-- | Encode a 32-bit IEEE floating point number.
+encode_f32 :: Float -> B.ByteString
+encode_f32 = encode . f32_w32
+
+-- | Encode a 64-bit IEEE floating point number.
+encode_f64 :: Double -> B.ByteString
+encode_f64 = encode . f64_w64
+
+-- | Encode an ASCII string.
+encode_str :: ASCII -> B.ByteString
+{-# INLINE encode_str #-}
+encode_str = B.pack . S.B.unpack
+
+-- | Decode a signed 8-bit integer.
+decode_i8 :: B.ByteString -> Int
+decode_i8 b = fromIntegral (decode b :: Int8)
+
+-- | Decode a signed 16-bit integer.
+decode_i16 :: B.ByteString -> Int
+decode_i16 b = fromIntegral (decode b :: Int16)
+
+-- | Decode a signed 32-bit integer.
+decode_i32 :: B.ByteString -> Int
+decode_i32 b = fromIntegral (decode b :: Int32)
+
+-- | Decode an unsigned 32-bit integer.
+decode_u32 :: B.ByteString -> Int
+decode_u32 b = fromIntegral (decode b :: Word32)
+
+-- | Decode a signed 64-bit integer.
+decode_i64 :: B.ByteString -> Int64
+decode_i64 = decode
+
+-- | Decode an unsigned 64-bit integer.
+decode_u64 :: B.ByteString -> Word64
+decode_u64 = decode
+
+-- | Decode a 32-bit IEEE floating point number.
+decode_f32 :: B.ByteString -> Float
+decode_f32 b = w32_f32 (decode b :: Word32)
+
+-- | Decode a 64-bit IEEE floating point number.
+decode_f64 :: B.ByteString -> Double
+decode_f64 b = w64_f64 (decode b :: Word64)
+
+-- | Decode an ASCII string.
+decode_str :: B.ByteString -> ASCII
+{-# INLINE decode_str #-}
+decode_str = S.C.pack . C.unpack
+
+-- | Bundle header as a (strict) 'S.C.ByteString'.
+bundleHeader_strict :: S.C.ByteString
+bundleHeader_strict = S.C.pack "#bundle\0"
+
+-- | Bundle header as a lazy ByteString.
+bundleHeader :: B.ByteString
+{-# INLINE bundleHeader #-}
+bundleHeader = C.fromChunks [bundleHeader_strict]
+
+-- | The number of bytes required to align an OSC value to the next
+-- 4-byte boundary.
+--
+-- > map align [0::Int .. 7] == [0,3,2,1,0,3,2,1]
+align :: (Num i,Bits i) => i -> i
+{-# INLINE align #-}
+align n = ((n + 3) .&. complement 3) - n
diff --git a/Sound/OSC/Coding/Cast.hs b/Sound/OSC/Coding/Cast.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Cast.hs
@@ -0,0 +1,43 @@
+-- | Bit-level type casts and byte layout string typecasts.
+module Sound.OSC.Coding.Cast (f32_w32,w32_f32
+ ,f64_w64,w64_f64
+ ,str_cstr,cstr_str
+ ,str_pstr,pstr_str) where
+
+import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -}
+import Data.Char {- base -}
+import Data.Word {- base -}
+
+-- | The IEEE byte representation of a float.
+f32_w32 :: Float -> Word32
+f32_w32 = I.floatToWord
+
+-- | Inverse of 'f32_w32'.
+w32_f32 :: Word32 -> Float
+w32_f32 = I.wordToFloat
+
+-- | The IEEE byte representation of a double.
+f64_w64 :: Double -> Word64
+f64_w64 = I.doubleToWord
+
+-- | Inverse of 'f64_i64'.
+w64_f64 :: Word64 -> Double
+w64_f64 = I.wordToDouble
+
+-- | Transform a haskell string into a C string (a null suffixed byte
+-- string).
+str_cstr :: String -> [Word8]
+str_cstr s = map (fromIntegral . ord) s ++ [0]
+
+-- | Inverse of 'str_cstr'.
+cstr_str :: [Word8] -> String
+cstr_str = map (chr . fromIntegral) . takeWhile (/= 0)
+
+-- | Transform a haskell string to a pascal string (a length prefixed
+-- byte string).
+str_pstr :: String -> [Word8]
+str_pstr s = fromIntegral (length s) : map (fromIntegral . ord) s
+
+-- | Inverse of 'str_pstr'.
+pstr_str :: [Word8] -> String
+pstr_str = map (chr . fromIntegral) . drop 1
diff --git a/Sound/OSC/Coding/Decode/Base.hs b/Sound/OSC/Coding/Decode/Base.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Decode/Base.hs
@@ -0,0 +1,104 @@
+-- | Base-level decode function for OSC packets (slow). For ordinary
+-- use see 'Sound.OSC.Coding.Decode.Binary'.
+module Sound.OSC.Coding.Decode.Base (decodeMessage
+ ,decodeBundle
+ ,decodePacket) where
+
+import Data.Binary {- base -}
+import qualified Data.ByteString.Char8 as C {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import Data.List {- base -}
+import Data.Maybe {- base -}
+
+import Sound.OSC.Coding.Byte
+import Sound.OSC.Time
+import Sound.OSC.Type
+
+-- The plain byte count of an OSC value.
+size :: Datum_Type -> B.ByteString -> Int
+size ty b =
+ case ty of
+ 'i' -> 4
+ 'f' -> 4
+ 'd' -> 8
+ 't' -> 8 -- timetag
+ 'm' -> 4 -- MIDI message
+ 's' -> fromIntegral (fromMaybe
+ (error ("size: no terminating zero: " ++ show b))
+ (B.elemIndex 0 b))
+ 'b' -> decode_i32 (B.take 4 b)
+ _ -> error "size: illegal type"
+
+-- The storage byte count of an OSC value.
+storage :: Datum_Type -> B.ByteString -> Int
+storage ty b =
+ case ty of
+ 's' -> let n = size 's' b + 1 in n + align n
+ 'b' -> let n = size 'b' b in n + align n + 4
+ _ -> size ty B.empty
+
+-- Decode an OSC datum
+decode_datum :: Datum_Type -> B.ByteString -> Datum
+decode_datum ty b =
+ case ty of
+ 'i' -> Int32 (decode b)
+ 'h' -> Int64 (decode b)
+ 'f' -> Float (decode_f32 b)
+ 'd' -> Double (decode_f64 b)
+ 's' -> ASCII_String (decode_str (b_take (size 's' b) b))
+ 'b' -> Blob (b_take (size 'b' b) (B.drop 4 b))
+ 't' -> TimeStamp (ntpi_to_ntpr (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] ++ ")")
+
+-- Decode a sequence of OSC datum given a type descriptor string.
+decode_datum_seq :: ASCII -> B.ByteString -> [Datum]
+decode_datum_seq cs b =
+ let swap (x,y) = (y,x)
+ cs' = C.unpack cs
+ 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'.
+decodeMessage :: B.ByteString -> Message
+decodeMessage b =
+ let n = storage 's' b
+ (ASCII_String cmd) = decode_datum 's' b
+ m = storage 's' (b_drop n b)
+ (ASCII_String dsc) = decode_datum 's' (b_drop n b)
+ arg = decode_datum_seq (descriptor_tags dsc) (b_drop (n + m) b)
+ in Message (C.unpack cmd) arg
+
+-- Decode a sequence of OSC messages, each one headed by its length
+decode_message_seq :: B.ByteString -> [Message]
+decode_message_seq b =
+ let s = decode_i32 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 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)
+ in Bundle timeStamp ms
+
+-- | 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 decodePacket b == Message "/g_free" [Int 0]
+decodePacket :: B.ByteString -> Packet
+decodePacket b =
+ if bundleHeader `B.isPrefixOf` b
+ then Packet_Bundle (decodeBundle b)
+ else Packet_Message (decodeMessage b)
+
+b_take :: Int -> B.ByteString -> B.ByteString
+b_take = B.take . fromIntegral
+
+b_drop :: Int -> B.ByteString -> B.ByteString
+b_drop = B.drop . fromIntegral
diff --git a/Sound/OSC/Coding/Decode/Binary.hs b/Sound/OSC/Coding/Decode/Binary.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Decode/Binary.hs
@@ -0,0 +1,128 @@
+-- | Optimised decode function for OSC packets.
+module Sound.OSC.Coding.Decode.Binary
+ (getPacket
+ ,decodePacket
+ ,decodePacket_strict) where
+
+import Control.Applicative {- base -}
+import Control.Monad (when) {- base -}
+import Data.Binary.Get {- binary -}
+import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -}
+import qualified Data.ByteString.Char8 as S.C {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -}
+import Data.Int {- base -}
+import Data.Word {- base -}
+
+import Sound.OSC.Coding.Byte
+import Sound.OSC.Time
+import Sound.OSC.Type
+
+-- | Isolate an action to operating within a fixed block of bytes. The
+-- action is required to consume all the bytes that it is isolated to.
+isolate :: Word32 -> Get a -> Get a
+isolate n m = do
+ s <- get_bytes n
+ case runGetOrFail m s of
+ Left (_, _, e) -> fail e
+ Right (s', _, a) ->
+ if B.null s'
+ then return a
+ else fail "isolate: not all bytes consumed"
+
+-- | Get a 32 bit integer in big-endian byte order.
+getInt32be :: Get Int32
+getInt32be = fromIntegral <$> getWord32be
+
+-- | Get a 64 bit integer in big-endian byte order.
+getInt64be :: Get Int64
+getInt64be = fromIntegral <$> getWord64be
+
+-- | Get an aligned OSC string.
+get_string :: Get String
+get_string = do
+ s <- getLazyByteStringNul
+ skip (fromIntegral (align (B.length s + 1)))
+ return $ C.unpack s
+
+-- | Get an aligned OSC string.
+get_ascii :: Get ASCII
+get_ascii = do
+ s <- getLazyByteStringNul
+ skip (fromIntegral (align (B.length s + 1)))
+ return (S.C.pack (C.unpack s))
+
+-- | Get binary data prefixed by byte count.
+get_bytes :: Word32 -> Get B.ByteString
+get_bytes n = do
+ b <- getLazyByteString (fromIntegral n)
+ if n /= fromIntegral (B.length b)
+ then fail "get_bytes: end of stream"
+ else skip (fromIntegral (align n))
+ return b
+
+-- | Get an OSC datum.
+get_datum :: Datum_Type -> Get Datum
+get_datum ty =
+ case ty of
+ 'i' -> Int32 <$> fromIntegral <$> getInt32be
+ 'h' -> Int64 <$> fromIntegral <$> getInt64be
+ 'f' -> Float <$> realToFrac <$> I.getFloat32be
+ 'd' -> Double <$> I.getFloat64be
+ 's' -> ASCII_String <$> get_ascii
+ 'b' -> Blob <$> (get_bytes =<< getWord32be)
+ 't' -> TimeStamp <$> ntpi_to_ntpr <$> getWord64be
+ 'm' -> do b0 <- getWord8
+ b1 <- getWord8
+ b2 <- getWord8
+ b3 <- getWord8
+ return $ Midi (MIDI b0 b1 b2 b3)
+ _ -> fail ("get_datum: illegal type " ++ show ty)
+
+-- | Get an OSC 'Message'.
+get_message :: Get Message
+get_message = do
+ cmd <- get_string
+ dsc <- get_ascii
+ case S.C.unpack dsc of
+ ',':tags -> do
+ arg <- mapM get_datum tags
+ return $ Message cmd arg
+ _ -> fail "get_message: invalid type descriptor string"
+
+-- | 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_message =<< getWord32be
+ ps <- get_message_seq
+ return (p:ps)
+
+-- | Get a bundle. Fail if bundle header is not found in packet.
+get_bundle :: Get Bundle
+get_bundle = do
+ h <- getByteString (S.C.length bundleHeader_strict)
+ when (h /= bundleHeader_strict) (fail "get_bundle: not a bundle")
+ t <- ntpi_to_ntpr <$> getWord64be
+ ps <- get_message_seq
+ return $ Bundle t ps
+
+-- | Get an OSC 'Packet'.
+getPacket :: Get Packet
+getPacket = (Packet_Bundle <$> get_bundle) <|> (Packet_Message <$> get_message)
+
+-- | Decode an OSC packet from a lazy ByteString.
+--
+-- > 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]
+decodePacket :: B.ByteString -> Packet
+{-# INLINE decodePacket #-}
+decodePacket = runGet getPacket
+
+-- | Decode an OSC packet from a strict ByteString.
+decodePacket_strict :: S.C.ByteString -> Packet
+{-# INLINE decodePacket_strict #-}
+decodePacket_strict = runGet getPacket . B.fromChunks . (:[])
diff --git a/Sound/OSC/Coding/Encode/Base.hs b/Sound/OSC/Coding/Encode/Base.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Encode/Base.hs
@@ -0,0 +1,56 @@
+-- | Base-level encode function for OSC packets (slow). For ordinary
+-- use see 'Sound.OSC.Coding.Encode.Builder'.
+module Sound.OSC.Coding.Encode.Base (encodeMessage
+ ,encodeBundle
+ ,encodePacket) where
+
+import Data.Binary {- base -}
+import qualified Data.ByteString.Char8 as C {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+
+import Sound.OSC.Coding.Byte
+import Sound.OSC.Type
+import Sound.OSC.Time
+
+-- Align a byte string if required.
+extend :: Word8 -> B.ByteString -> B.ByteString
+extend p s = B.append s (B.replicate (align (B.length s)) p)
+
+-- Encode an OSC datum.
+encode_datum :: Datum -> B.ByteString
+encode_datum dt =
+ case dt of
+ Int32 i -> encode i
+ Int64 i -> encode i
+ Float f -> encode_f32 f
+ Double d -> encode_f64 d
+ TimeStamp t -> encode_u64 $ ntpr_to_ntpi t
+ ASCII_String s -> extend 0 (B.snoc (encode_str s) 0)
+ Midi (MIDI b0 b1 b2 b3) -> B.pack [b0,b1,b2,b3]
+ Blob b -> let n = encode_i32 (fromIntegral (B.length b))
+ in B.append n (extend 0 b)
+
+-- | Encode an OSC 'Message'.
+encodeMessage :: Message -> B.ByteString
+encodeMessage (Message c l) =
+ B.concat [encode_datum (ASCII_String (C.pack c))
+ ,encode_datum (ASCII_String (descriptor l))
+ ,B.concat (map encode_datum l) ]
+
+-- Encode an OSC 'Message' as an OSC blob.
+encode_message_blob :: Message -> Datum
+encode_message_blob = Blob . encodeMessage
+
+-- | Encode an OSC 'Bundle'.
+encodeBundle :: Bundle -> B.ByteString
+encodeBundle (Bundle t m) =
+ B.concat [bundleHeader
+ ,encode_u64 (ntpr_to_ntpi t)
+ ,B.concat (map (encode_datum . encode_message_blob) m)]
+
+-- | Encode an OSC 'Packet'.
+encodePacket :: Packet -> B.ByteString
+encodePacket o =
+ case o of
+ Packet_Message m -> encodeMessage m
+ Packet_Bundle b -> encodeBundle b
diff --git a/Sound/OSC/Coding/Encode/Builder.hs b/Sound/OSC/Coding/Encode/Builder.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Coding/Encode/Builder.hs
@@ -0,0 +1,95 @@
+-- | Optimised encode function for OSC packets.
+module Sound.OSC.Coding.Encode.Builder
+ (build_packet
+ ,encodeMessage
+ ,encodeBundle
+ ,encodePacket
+ ,encodePacket_strict) where
+
+import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -}
+import qualified Data.ByteString as S {- bytestring -}
+import qualified Data.ByteString.Lazy as L {- bytestring -}
+import qualified Blaze.ByteString.Builder as B {- bytestring -}
+import qualified Blaze.ByteString.Builder.Char8 as B {- bytestring -}
+import Data.Monoid (mappend, mconcat) {- base -}
+import Data.Word (Word8) {- base -}
+
+import Sound.OSC.Coding.Byte (align, bundleHeader)
+import Sound.OSC.Time
+import Sound.OSC.Type
+
+-- Generate a list of zero bytes for padding.
+padding :: Integral i => i -> [Word8]
+padding n = replicate (fromIntegral n) 0
+
+-- Encode a string with zero padding.
+build_ascii :: ASCII -> B.Builder
+build_ascii s = B.fromByteString s `mappend` B.fromWord8s (0:padding (align (S.length s + 1)))
+
+-- Encode a string with zero padding.
+build_string :: String -> B.Builder
+build_string s = B.fromString s `mappend` B.fromWord8s (0:padding (align (length s + 1)))
+
+-- Encode a byte string with prepended length and zero padding.
+build_bytes :: L.ByteString -> B.Builder
+build_bytes s = B.fromInt32be (fromIntegral (L.length s))
+ `mappend` B.fromLazyByteString s
+ `mappend` B.fromWord8s (padding (align (L.length s)))
+
+-- Encode an OSC datum.
+build_datum :: Datum -> B.Builder
+build_datum d =
+ case d of
+ Int32 i -> B.fromInt32be (fromIntegral i)
+ Int64 i -> B.fromInt64be (fromIntegral i)
+ Float n -> B.fromWord32be (I.floatToWord (realToFrac n))
+ Double n -> B.fromWord64be (I.doubleToWord n)
+ TimeStamp t -> B.fromWord64be (fromIntegral (ntpr_to_ntpi t))
+ ASCII_String s -> build_ascii s
+ Midi (MIDI b0 b1 b2 b3) -> B.fromWord8s [b0,b1,b2,b3]
+ Blob b -> build_bytes b
+
+-- Encode an OSC 'Message'.
+build_message :: Message -> B.Builder
+build_message (Message c l) =
+ mconcat [build_string c
+ ,build_ascii (descriptor l)
+ ,mconcat $ map build_datum l]
+
+-- 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 . build_message) 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 t m) -> build_bundle_ntpi (ntpr_to_ntpi t) m
+
+{-# 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
+encodePacket :: Packet -> L.ByteString
+encodePacket = B.toLazyByteString . build_packet
+
+-- | Encode an Packet packet to a strict ByteString.
+encodePacket_strict :: Packet -> S.ByteString
+encodePacket_strict = B.toByteString . build_packet
diff --git a/Sound/OSC/Core.hs b/Sound/OSC/Core.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Core.hs
@@ -0,0 +1,22 @@
+-- | Composite of non-transport related modules.
+--
+-- Provides the 'Datum', 'Message', 'Bundle' and 'Packet' types and
+-- the 'Datem', 'OSC' and 'Coding' type-classes.
+--
+-- The basic constructors are 'message' and 'bundle', the basic coding
+-- functions are 'encodePacket' and 'decodePacket'.
+--
+-- > import Sound.OSC.Core
+-- >
+-- > let {o = bundle immediately [message "/g_free" [Int32 0]]
+-- > ;e = encodeBundle o :: String}
+-- > in decodeBundle e == o
+module Sound.OSC.Core (module M) where
+
+import Sound.OSC.Class as M
+import Sound.OSC.Coding as M
+import Sound.OSC.Datum as M
+import Sound.OSC.Normalise as M
+import Sound.OSC.Time as M
+import Sound.OSC.Type as M
+import Sound.OSC.Wait as M
diff --git a/Sound/OSC/Datum.hs b/Sound/OSC/Datum.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Datum.hs
@@ -0,0 +1,63 @@
+-- | 'Datum' related functions.
+module Sound.OSC.Datum where
+
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import qualified Data.ByteString.Char8 as C {- bytestring -}
+import Data.Int {- base -}
+import Data.Word {- base -}
+
+import Sound.OSC.Type
+
+-- | Type specialised 'd_get'.
+--
+-- > map datum_int32 [Int32 1,Float 1] == [Just 1,Nothing]
+datum_int32 :: Datum -> Maybe Int32
+datum_int32 = d_get
+
+-- | Type specialised 'd_get'.
+datum_int64 :: Datum -> Maybe Int64
+datum_int64 = d_get
+
+-- | Type specialised 'd_get'.
+datum_float :: Datum -> Maybe Float
+datum_float = d_get
+
+-- | Type specialised 'd_get'.
+datum_double :: Datum -> Maybe Double
+datum_double = d_get
+
+-- | Type specialised 'd_get'.
+--
+-- > datum_ascii (d_put (C.pack "string")) == Just (C.pack "string")
+datum_ascii :: Datum -> Maybe ASCII
+datum_ascii = d_get
+
+-- | 'C.unpack' of 'd_get'.
+--
+-- > datum_string (d_put (C.pack "string")) == Just "string"
+datum_string :: Datum -> Maybe String
+datum_string = fmap C.unpack . datum_ascii
+
+-- | Type specialised 'd_get'.
+datum_blob :: Datum -> Maybe B.ByteString
+datum_blob = d_get
+
+-- | 'Maybe' variant of 'd_timestamp'.
+datum_timestamp :: Datum -> Maybe Time
+datum_timestamp d = case d of {TimeStamp x -> Just x;_ -> Nothing}
+
+-- | Type specialised 'd_get'.
+datum_midi :: Datum -> Maybe MIDI
+datum_midi = d_get
+
+-- | 'Datum' as sequence of 'Word8' if 'ASCII_String', 'Blob' or 'Midi'.
+--
+-- > let d = [string "5",Blob (B.pack [53]),midi (0x00,0x90,0x40,0x60)]
+-- > in Data.Maybe.mapMaybe datum_sequence d == [[53],[53],[0,144,64,96]]
+datum_sequence :: Datum -> Maybe [Word8]
+datum_sequence d =
+ case d of
+ ASCII_String s -> Just (map (fromIntegral . fromEnum) (C.unpack s))
+ Blob s -> Just (B.unpack s)
+ Midi (MIDI p q r s) -> Just [p,q,r,s]
+ _ -> Nothing
diff --git a/Sound/OSC/FD.hs b/Sound/OSC/FD.hs
--- a/Sound/OSC/FD.hs
+++ b/Sound/OSC/FD.hs
@@ -1,8 +1,7 @@
--- | Composite of "Sound.OpenSoundControl" and
--- "Sound.OSC.Transport.FD".
+-- | Composite of "Sound.OSC.Core" and "Sound.OSC.Transport.FD".
module Sound.OSC.FD (module M) where
-import Sound.OpenSoundControl as M
+import Sound.OSC.Core 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
diff --git a/Sound/OSC/Normalise.hs b/Sound/OSC/Normalise.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Normalise.hs
@@ -0,0 +1,64 @@
+-- | Datum normalisation.
+module Sound.OSC.Normalise where
+
+import Sound.OSC.Type as O
+
+-- | Lift 'O.Int32' to 'O.Int64' and 'O.Float' to 'O.Double'.
+--
+-- > map normalise_datum [Int32 1,Float 1] == [Int64 1,Double 1]
+normalise_datum :: Datum -> Datum
+normalise_datum d =
+ case d of
+ Int32 n -> Int64 (fromIntegral n)
+ Float n -> Double (realToFrac n)
+ _ -> d
+
+-- | A normalised 'O.Message' has only 'O.Int64' and 'O.Double'
+-- numerical values.
+--
+-- > let m = message "/m" [Int32 0,Float 0]
+-- > in normalise_message m == message "/m" [Int64 0,Double 0]
+normalise_message :: Message -> Message
+normalise_message = message_coerce normalise_datum
+
+-- | A normalised 'O.Bundle' has only 'O.Int64' and 'O.Double'
+-- numerical values.
+normalise_bundle :: Bundle -> Bundle
+normalise_bundle = bundle_coerce normalise_datum
+
+-- * Coercion
+
+-- | Map a normalising 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 normalising 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)
+
+-- * Promotion
+
+-- | Coerce 'Int32', 'Int64' and 'Float' to 'Double'.
+--
+-- > map datum_promote [Int32 5,Float 5] == [Double 5,Double 5]
+datum_promote :: Datum -> Datum
+datum_promote d =
+ case d of
+ Int32 n -> Double (fromIntegral n)
+ Int64 n -> Double (fromIntegral n)
+ Float n -> Double (realToFrac n)
+ _ -> d
+
+-- | 'O.Datum' as 'O.Int64' if 'O.Int32', 'O.Int64', 'O.Float' or
+-- 'O.Double'.
+--
+-- > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5,string "5"]
+-- > in map datum_floor d == [Int64 5,Int64 5,Int64 5,Int64 5,string "5"]
+datum_floor :: Datum -> Datum
+datum_floor d =
+ case d of
+ Int32 x -> Int64 (fromIntegral x)
+ Float x -> Int64 (fromInteger (floor x))
+ Double x -> Int64 (fromInteger (floor x))
+ _ -> d
+
diff --git a/Sound/OSC/Time.hs b/Sound/OSC/Time.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Time.hs
@@ -0,0 +1,111 @@
+-- | OSC related timing functions. OSC timestamps are @NTP@ values,
+-- .
+module Sound.OSC.Time where
+
+import Control.Concurrent {- base -}
+import Control.Monad {- base -}
+import Control.Monad.IO.Class {- transformers -}
+import Data.Word {- base -}
+import qualified Data.Time as T {- time -}
+import qualified Data.Time.Clock.POSIX as T {- time -}
+
+import Sound.OSC.Type
+
+-- * Temporal types
+
+-- | Type for integer (binary) representation of @NTP@ time.
+type NTPi = Word64
+
+-- | @Unix/Posix@ epoch time in real-valued (fractional) form.
+type UT = Double
+
+-- * Time conversion
+
+-- | Convert a real-valued NTP timestamp to an 'NTPi' timestamp.
+ntpr_to_ntpi :: RealFrac n => n -> NTPi
+ntpr_to_ntpi t = round (t * 2^(32::Int))
+
+-- | Convert an 'NTPi' timestamp to a real-valued NTP timestamp.
+ntpi_to_ntpr :: Fractional n => NTPi -> n
+ntpi_to_ntpr t = fromIntegral t / 2^(32::Int)
+
+-- | Difference (in seconds) between /NTP/ and /UT/ epochs.
+--
+-- > ntp_ut_epoch_diff / (24 * 60 * 60) == 25567
+ntp_ut_epoch_diff :: Num n => n
+ntp_ut_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60
+
+-- | Convert a 'UT' timestamp to an 'NTPi' timestamp.
+ut_to_ntpi :: UT -> NTPi
+ut_to_ntpi t = ntpr_to_ntpi (t + ntp_ut_epoch_diff)
+
+-- | Convert @Unix/Posix@ to @NTP@.
+ut_to_ntpr :: Num n => n -> n
+ut_to_ntpr = (+) ntp_ut_epoch_diff
+
+-- | Convert @NTP@ to @Unix/Posix@.
+ntpr_to_ut :: Num n => n -> n
+ntpr_to_ut = (+) (negate ntp_ut_epoch_diff)
+
+-- | Convert 'NTPi' to @Unix/Posix@.
+ntpi_to_ut :: NTPi -> UT
+ntpi_to_ut = ntpr_to_ut . ntpi_to_ntpr
+
+-- * 'Data.Time' inter-operation.
+
+-- | The time at 1970-01-01:00:00:00.
+ut_epoch :: T.UTCTime
+ut_epoch =
+ let d = T.fromGregorian 1970 1 1
+ s = T.secondsToDiffTime 0
+ in T.UTCTime d s
+
+-- | Convert 'T.UTCTime' to @Unix/Posix@.
+utc_to_ut :: Fractional n => T.UTCTime -> n
+utc_to_ut t = realToFrac (T.diffUTCTime t ut_epoch)
+
+-- * Clock operations
+
+-- | Read current real-valued @NTP@ timestamp.
+--
+-- > do {ct <- fmap utc_to_ut T.getCurrentTime
+-- > ;pt <- fmap realToFrac T.getPOSIXTime
+-- > ;print (pt - ct,pt - ct < 1e-5)}
+time :: MonadIO m => m Time
+time = liftIO (fmap (ut_to_ntpr . realToFrac) T.getPOSIXTime)
+
+-- * 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@.
+pauseThreadLimit :: Fractional n => n
+pauseThreadLimit = fromIntegral (maxBound::Int) / 1e6
+
+-- | Pause current thread for the indicated duration (in seconds), see
+-- 'pauseThreadLimit'.
+pauseThread :: (MonadIO m,Ord n,RealFrac n) => n -> m ()
+pauseThread n = when (n > 0) (liftIO (threadDelay (floor (n * 1e6))))
+
+-- | Type restricted 'pauseThread'.
+wait :: MonadIO m => Double -> m ()
+wait = pauseThread
+
+-- | Pause current thread until the given 'Time', see
+-- 'pauseThreadLimit'.
+pauseThreadUntil :: MonadIO m => Time -> m ()
+pauseThreadUntil t = pauseThread . (t -) =<< time
+
+-- | Sleep current thread for the indicated duration (in seconds).
+-- Divides long sleeps into parts smaller than 'pauseThreadLimit'.
+sleepThread :: (RealFrac n, MonadIO m) => n -> m ()
+sleepThread n =
+ if n >= pauseThreadLimit
+ then let n' = pauseThreadLimit - 1
+ in pauseThread n >> sleepThread (n - n')
+ else pauseThread n
+
+-- | Sleep current thread until the given 'Time'. Divides long sleeps
+-- into parts smaller than 'pauseThreadLimit'.
+sleepThreadUntil :: MonadIO m => Time -> m ()
+sleepThreadUntil t = sleepThread . (t -) =<< time
diff --git a/Sound/OSC/Transport/FD.hs b/Sound/OSC/Transport/FD.hs
--- a/Sound/OSC/Transport/FD.hs
+++ b/Sound/OSC/Transport/FD.hs
@@ -2,12 +2,13 @@
-- @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
+import Control.Exception {- base -}
+import Data.List {- base -}
+import Data.Maybe {- base -}
+
+import Sound.OSC.Class
+import Sound.OSC.Type
+import Sound.OSC.Wait
-- | Abstract over the underlying transport protocol.
class Transport t where
diff --git a/Sound/OSC/Transport/FD/TCP.hs b/Sound/OSC/Transport/FD/TCP.hs
--- a/Sound/OSC/Transport/FD/TCP.hs
+++ b/Sound/OSC/Transport/FD/TCP.hs
@@ -2,13 +2,14 @@
module Sound.OSC.Transport.FD.TCP where
import qualified Data.ByteString.Lazy as B {- bytestring -}
-import Control.Monad
+import Control.Monad {- base -}
import Network {- network -}
-import Sound.OpenSoundControl.Class
-import Sound.OpenSoundControl.Coding
-import Sound.OpenSoundControl.Coding.Byte
+import System.IO {- base -}
+
+import Sound.OSC.Class
+import Sound.OSC.Coding
+import Sound.OSC.Coding.Byte
import Sound.OSC.Transport.FD
-import System.IO
-- | The TCP transport handle data type.
data TCP = TCP {tcpHandle :: Handle}
diff --git a/Sound/OSC/Transport/FD/UDP.hs b/Sound/OSC/Transport/FD/UDP.hs
--- a/Sound/OSC/Transport/FD/UDP.hs
+++ b/Sound/OSC/Transport/FD/UDP.hs
@@ -1,15 +1,13 @@
-- | 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 Control.Monad {- base -}
+import qualified Network.Socket as N {- network -}
+import qualified Network.Socket.ByteString as C {- network -}
+
+import Sound.OSC.Class
+import Sound.OSC.Coding
+import Sound.OSC.Type
import Sound.OSC.Transport.FD
-- | The UDP transport handle data type.
@@ -20,6 +18,7 @@
udpPort (UDP fd) = fmap fromIntegral (N.socketPort fd)
instance Transport UDP where
+ -- C.L.send is not implemented for W32
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
@@ -57,14 +56,12 @@
-- | 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)
+ -- C.L.sendTo does not exist
+ void (C.sendTo fd (encodeOSC 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
+ -- C.L.recvFrom does not exist
(s,a) <- C.recvFrom fd 8192
- let s' = B.pack (S.unpack s)
- return (decodePacket s',a)
+ return (decodePacket s,a)
diff --git a/Sound/OSC/Transport/Monad.hs b/Sound/OSC/Transport/Monad.hs
--- a/Sound/OSC/Transport/Monad.hs
+++ b/Sound/OSC/Transport/Monad.hs
@@ -1,15 +1,16 @@
-- | Monad class implementing an Open Sound Control transport.
module Sound.OSC.Transport.Monad where
-import Control.Monad (liftM)
+import Control.Monad (liftM) {- base -}
import Control.Monad.Trans.Reader {- transformers -}
-import Control.Monad.IO.Class as M
-import Data.List
-import Data.Maybe
-import Sound.OpenSoundControl.Class
+import Control.Monad.IO.Class as M {- transformers -}
+import Data.List {- base -}
+import Data.Maybe {- base -}
+
+import Sound.OSC.Class
import qualified Sound.OSC.Transport.FD as T
-import Sound.OpenSoundControl.Type
-import Sound.OpenSoundControl.Wait
+import Sound.OSC.Type
+import Sound.OSC.Wait
-- | Sender monad.
class Monad m => SendOSC m where
diff --git a/Sound/OSC/Type.hs b/Sound/OSC/Type.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Type.hs
@@ -0,0 +1,377 @@
+-- | Alegbraic data types for OSC datum and packets.
+module Sound.OSC.Type where
+
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import qualified Data.ByteString.Char8 as C {- bytestring -}
+import Data.Int {- base -}
+import Data.List {- base -}
+import Data.Word {- base -}
+import Numeric {- base -}
+
+-- * Time
+
+-- | @NTP@ time in real-valued (fractional) form.
+type Time = Double
+
+-- | Constant indicating a bundle to be executed immediately.
+immediately :: Time
+immediately = 1 / 2^(32::Int)
+
+-- * Datum
+
+-- | Type enumerating Datum categories.
+type Datum_Type = Char
+
+-- | Type for ASCII strings (strict 'Char'8 'C.ByteString').
+type ASCII = C.ByteString
+
+-- | Four-byte midi message.
+data MIDI = MIDI Word8 Word8 Word8 Word8
+ deriving (Eq,Show,Read)
+
+-- | The basic elements of OSC messages.
+data Datum = Int32 {d_int32 :: Int32}
+ | Int64 {d_int64 :: Int64}
+ | Float {d_float :: Float}
+ | Double {d_double :: Double}
+ | ASCII_String {d_ascii_string :: ASCII}
+ | Blob {d_blob :: B.ByteString}
+ | TimeStamp {d_timestamp :: Time}
+ | Midi {d_midi :: MIDI}
+ deriving (Eq,Read,Show)
+
+-- | Single character identifier of an OSC datum.
+datum_tag :: Datum -> Datum_Type
+datum_tag dt =
+ case dt of
+ Int32 _ -> 'i'
+ Int64 _ -> 'h'
+ Float _ -> 'f'
+ Double _ -> 'd'
+ ASCII_String _ -> 's'
+ Blob _ -> 'b'
+ TimeStamp _ -> 't'
+ Midi _ -> 'm'
+
+-- | 'Datum' as 'Integral' if 'Sound.OSC.Type.Int32' or
+-- 'Sound.OSC.Type.Int64'.
+--
+-- > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5]
+-- > in map datum_integral d == [Just (5::Int),Just 5,Nothing,Nothing]
+datum_integral :: Integral i => Datum -> Maybe i
+datum_integral d =
+ case d of
+ Int32 x -> Just (fromIntegral x)
+ Int64 x -> Just (fromIntegral x)
+ _ -> Nothing
+
+-- | 'Datum' as 'Floating' if 'Sound.OSC.Type.Int32',
+-- 'Sound.OSC.Type.Int64', 'Sound.OSC.Type.Float',
+-- 'Sound.OSC.Type.Double' or 'TimeStamp'.
+--
+-- > let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5]
+-- > in Data.Maybe.mapMaybe datum_floating d == replicate 5 (5::Double)
+datum_floating :: Floating n => Datum -> Maybe n
+datum_floating d =
+ case d of
+ Int32 n -> Just (fromIntegral n)
+ Int64 n -> Just (fromIntegral n)
+ Float n -> Just (realToFrac n)
+ Double n -> Just (realToFrac n)
+ TimeStamp n -> Just (realToFrac n)
+ _ -> Nothing
+
+-- | Class for translating to and from 'Datum'. There are instances
+-- for the direct 'Datum' field types.
+--
+-- > d_put (1::Int32) == Int32 1
+-- > d_put (1::Int64) == Int64 1
+-- > d_put (1::Float) == Float 1
+-- > d_put (1::Double) == Double 1
+-- > d_put (C.pack "str") == ASCII_String (C.pack "str")
+-- > d_put (B.pack [37,37]) == Blob (B.pack [37,37])
+-- > d_put (MIDI 0 0 0 0) == Midi (MIDI 0 0 0 0)
+--
+-- There are also instances for standard Haskell types.
+--
+-- > d_put (1::Int) == Int64 1
+-- > d_put (1::Integer) == Int64 1
+class Datem a where
+ d_put :: a -> Datum
+ d_get :: Datum -> Maybe a
+
+instance Datem Int32 where
+ d_put = Int32
+ d_get d = case d of {Int32 x -> Just x;_ -> Nothing}
+
+instance Datem Int64 where
+ d_put = Int64
+ d_get d = case d of {Int64 x -> Just x;_ -> Nothing}
+
+instance Datem Int where
+ d_put = Int64 . fromIntegral
+ d_get = datum_integral
+
+instance Datem Integer where
+ d_put = Int64 . fromIntegral
+ d_get = datum_integral
+
+instance Datem Float where
+ d_put = Float
+ d_get d = case d of {Float x -> Just x;_ -> Nothing}
+
+instance Datem Double where
+ d_put = Double
+ d_get d = case d of {Double x -> Just x;_ -> Nothing}
+
+instance Datem C.ByteString where
+ d_put = ASCII_String
+ d_get d = case d of {ASCII_String x -> Just x;_ -> Nothing}
+
+instance Datem B.ByteString where
+ d_put = Blob
+ d_get d = case d of {Blob x -> Just x;_ -> Nothing}
+
+instance Datem MIDI where
+ d_put = Midi
+ d_get d = case d of {Midi x -> Just x;_ -> Nothing}
+
+-- | Type generalised 'Sound.OSC.Type.Int32'.
+--
+-- > int32 (1::Int32) == int32 (1::Integer)
+-- > d_int32 (int32 (maxBound::Int32)) == maxBound
+-- > int32 (((2::Int) ^ (64::Int))::Int) == Int32 0
+int32 :: Integral n => n -> Datum
+int32 = Int32 . fromIntegral
+
+-- | Type generalised 'Sound.OSC.Type.Int64'.
+--
+-- > int64 (1::Int32) == int64 (1::Integer)
+-- > d_int64 (int64 (maxBound::Int64)) == maxBound
+int64 :: Integral n => n -> Datum
+int64 = Int64 . fromIntegral
+
+-- | Type generalised 'Sound.OSC.Type.Float'.
+--
+-- > float (1::Int) == float (1::Double)
+-- > floatRange (undefined::Float) == (-125,128)
+-- > isInfinite (d_float (float (encodeFloat 1 256 :: Double))) == True
+float :: Real n => n -> Datum
+float = Float . realToFrac
+
+-- | Type generalised 'Sound.OSC.Type.Double'.
+--
+-- > double (1::Int) == double (1::Double)
+-- > double (encodeFloat 1 256 :: Double) == Double 1.157920892373162e77
+double :: Real n => n -> Datum
+double = Double . realToFrac
+
+-- | 'ASCII_String' of 'C.pack'.
+--
+-- > string "string" == ASCII_String (C.pack "string")
+string :: String -> Datum
+string = ASCII_String . C.pack
+
+-- | Four-tuple variant of 'Midi' '.' 'MIDI'.
+--
+-- > midi (0,0,0,0) == Midi (MIDI 0 0 0 0)
+midi :: (Word8,Word8,Word8,Word8) -> Datum
+midi (p,q,r,s) = Midi (MIDI p q r s)
+
+-- * Message
+
+-- | OSC address pattern. This is strictly an ASCII value, but it is
+-- very common to pattern match on addresses and matching on
+-- 'C.ByteString' requires @OverloadedStrings@.
+type Address_Pattern = String
+
+-- | An OSC message.
+data Message = Message {messageAddress :: Address_Pattern
+ ,messageDatum :: [Datum]}
+ deriving (Eq,Read,Show)
+
+-- | '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"
+
+-- | Message argument types are given by a descriptor.
+--
+-- > C.unpack (descriptor [Int32 1,Float 1,string "1"]) == ",ifs"
+descriptor :: [Datum] -> ASCII
+descriptor l = C.pack (',' : map datum_tag l)
+
+-- | Descriptor tags are @comma@ prefixed.
+descriptor_tags :: ASCII -> ASCII
+descriptor_tags = C.drop 1
+
+-- * Bundle
+
+-- | An OSC bundle.
+data Bundle = Bundle {bundleTime :: Time
+ ,bundleMessages :: [Message]}
+ deriving (Eq,Read,Show)
+
+-- | OSC 'Bundle's can be ordered (time ascending).
+instance Ord Bundle where
+ compare (Bundle a _) (Bundle b _) = compare a b
+
+-- | '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
+
+-- * Packet
+
+-- | An OSC 'Packet' is either a 'Message' or a 'Bundle'.
+data Packet = Packet_Message {packetMessage :: Message}
+ | Packet_Bundle {packetBundle :: Bundle}
+ deriving (Eq,Read,Show)
+
+-- | 'Packet_Bundle' '.' 'bundle'.
+p_bundle :: Time -> [Message] -> Packet
+p_bundle t = Packet_Bundle . bundle t
+
+-- | 'Packet_Message' '.' 'message'.
+p_message :: Address_Pattern -> [Datum] -> Packet
+p_message a = Packet_Message . message a
+
+-- | 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
+
+-- * Address Query
+
+-- | 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
+
+-- | 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)
+
+-- * Pretty printing
+
+-- | Pretty printer for 'Time' (truncate to 4 decimal places).
+--
+-- > timePP (1/3) == "0.3333"
+timePP :: Time -> String
+timePP t = showGFloat (Just 4) t ""
+
+-- | Pretty printer for vectors.
+--
+-- > vecPP [1::Int,2,3] == "<1,2,3>"
+vecPP :: Show a => [a] -> String
+vecPP v = '<' : intercalate "," (map show v) ++ ">"
+
+-- | Pretty printer for 'Datum'.
+--
+-- > let d = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60)]
+-- > in map datumPP d == ["1","1.2","\"str\"","<0,144,64,96>"]
+datumPP :: Datum -> String
+datumPP d =
+ case d of
+ Int32 n -> show n
+ Int64 n -> show n
+ Float n -> show n
+ Double n -> show n
+ ASCII_String s -> show (C.unpack s)
+ Blob s -> show s
+ TimeStamp t -> timePP t
+ Midi (MIDI p q r s) -> vecPP [p,q,r,s]
+
+-- | Pretty printer for 'Message'.
+messagePP :: Message -> String
+messagePP (Message a d) =
+ let d' = map datumPP d
+ in unwords ("#message" : a : 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
+
+-- * Parser
+
+-- | Variant of 'read'.
+readMaybe :: (Read a) => String -> Maybe a
+readMaybe s =
+ case reads s of
+ [(x, "")] -> Just x
+ _ -> Nothing
+
+-- | Given 'Datum_Type' attempt to parse 'Datum' at 'String'.
+--
+-- > parse_datum 'i' "42" == Just (Int32 42)
+-- > parse_datum 'h' "42" == Just (Int64 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' "[112,105]" == 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 Int32 . readMaybe
+ 'h' -> fmap Int64 . readMaybe
+ 'f' -> fmap Float . readMaybe
+ 'd' -> fmap Double . readMaybe
+ 's' -> fmap (ASCII_String . C.pack) . readMaybe
+ 'b' -> fmap (Blob . B.pack) . readMaybe
+ 't' -> error "parse_datum: timestamp"
+ 'm' -> fmap midi . readMaybe
+ _ -> error "parse_datum: type"
diff --git a/Sound/OSC/Wait.hs b/Sound/OSC/Wait.hs
new file mode 100644
--- /dev/null
+++ b/Sound/OSC/Wait.hs
@@ -0,0 +1,28 @@
+-- | Waiting (for replies).
+module Sound.OSC.Wait where
+
+import System.Timeout {- base -}
+
+-- * 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
diff --git a/Sound/OpenSoundControl.hs b/Sound/OpenSoundControl.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl.hs
+++ /dev/null
@@ -1,20 +0,0 @@
--- | Composite of non-transport related modules.
---
--- Provides the 'Datum', 'Message', 'Bundle' and 'Packet' types and
--- the 'OSC' and 'Coding' type-classes.
---
--- The basic constructors are 'message' and 'bundle', the basic coding
--- functions are 'encodePacket' and 'decodePacket'.
---
--- > 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
-
-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
diff --git a/Sound/OpenSoundControl/Class.hs b/Sound/OpenSoundControl/Class.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Class.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- | 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
diff --git a/Sound/OpenSoundControl/Coding.hs b/Sound/OpenSoundControl/Coding.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-}
--- | A type-class to provide coding operations to different data types
--- using the same function names.
-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
-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
- encodePacket :: Packet -> a -- ^ Decode an OSC packet.
- decodePacket :: a -> Packet -- ^ Encode an OSC packet.
-
-instance Coding S.ByteString where
- encodePacket = Builder.encodePacket_strict
- decodePacket = Binary.decodePacket_strict
-
-instance Coding B.ByteString where
- encodePacket = Builder.encodePacket
- decodePacket = Binary.decodePacket
-
-instance Coding String where
- encodePacket = C.unpack . encodePacket
- decodePacket = decodePacket . C.pack
-
--- | 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
diff --git a/Sound/OpenSoundControl/Coding/Byte.hs b/Sound/OpenSoundControl/Coding/Byte.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Byte.hs
+++ /dev/null
@@ -1,96 +0,0 @@
--- | Byte-level coding utility functions.
-module Sound.OpenSoundControl.Coding.Byte where
-
-import Data.Binary
-import Data.Bits
-import qualified Data.ByteString.Lazy as B
-import qualified Data.ByteString.Lazy.Char8 as C
-import Data.Int
-import Sound.OpenSoundControl.Coding.Cast
-
--- | Encode a signed 8-bit integer.
-encode_i8 :: Int -> B.ByteString
-encode_i8 n = encode (fromIntegral n :: Int8)
-
--- | Encode a signed 16-bit integer.
-encode_i16 :: Int -> B.ByteString
-encode_i16 n = encode (fromIntegral n :: Int16)
-
--- | Encode a signed 32-bit integer.
-encode_i32 :: Int -> B.ByteString
-encode_i32 n = encode (fromIntegral n :: Int32)
-
--- | Encode an unsigned 16-bit integer.
-encode_u32 :: Int -> B.ByteString
-encode_u32 n = encode (fromIntegral n :: Word32)
-
--- | Encode a signed 64-bit integer.
-encode_i64 :: Int64 -> B.ByteString
-encode_i64 = encode
-
--- | Encode an unsigned 64-bit integer.
-encode_u64 :: Word64 -> B.ByteString
-encode_u64 = encode
-
--- | Encode a 32-bit IEEE floating point number.
-encode_f32 :: Double -> B.ByteString
-encode_f32 = encode . f32_w32 . realToFrac
-
--- | Encode a 64-bit IEEE floating point number.
-encode_f64 :: Double -> B.ByteString
-encode_f64 = encode . f64_w64
-
--- | Encode an ASCII string.
-encode_str :: String -> B.ByteString
-{-# INLINE encode_str #-}
-encode_str = C.pack
-
--- | Decode a signed 8-bit integer.
-decode_i8 :: B.ByteString -> Int
-decode_i8 b = fromIntegral (decode b :: Int8)
-
--- | Decode a signed 16-bit integer.
-decode_i16 :: B.ByteString -> Int
-decode_i16 b = fromIntegral (decode b :: Int16)
-
--- | Decode a signed 32-bit integer.
-decode_i32 :: B.ByteString -> Int
-decode_i32 b = fromIntegral (decode b :: Int32)
-
--- | Decode an unsigned 32-bit integer.
-decode_u32 :: B.ByteString -> Int
-decode_u32 b = fromIntegral (decode b :: Word32)
-
--- | Decode a signed 64-bit integer.
-decode_i64 :: B.ByteString -> Int64
-decode_i64 = decode
-
--- | Decode an unsigned 64-bit integer.
-decode_u64 :: B.ByteString -> Word64
-decode_u64 = decode
-
--- | Decode a 32-bit IEEE floating point number.
-decode_f32 :: B.ByteString -> Double
-decode_f32 b = realToFrac (w32_f32 (decode b :: Word32))
-
--- | Decode a 64-bit IEEE floating point number.
-decode_f64 :: B.ByteString -> Double
-decode_f64 b = w64_f64 (decode b :: Word64)
-
--- | Decode an ASCII string.
-decode_str :: B.ByteString -> String
-{-# INLINE decode_str #-}
-decode_str = C.unpack
-
--- | Bundle header string.
-bundleHeader :: B.ByteString
-{-# INLINE bundleHeader #-}
-bundleHeader = C.pack "#bundle\0"
-
--- | The number of bytes required to align an OSC value to the next
--- 4-byte boundary.
---
--- > map align [0::Int .. 7] == [0,3,2,1,0,3,2,1]
-align :: (Num i,Bits i) => i -> i
-{-# INLINE align #-}
-align n = ((n + 3) .&. complement 3) - n
diff --git a/Sound/OpenSoundControl/Coding/Cast.hs b/Sound/OpenSoundControl/Coding/Cast.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Cast.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- | Bit-level type casts and byte layout string typecasts.
-module Sound.OpenSoundControl.Coding.Cast (f32_w32,w32_f32
- ,f64_w64,w64_f64
- ,str_cstr,cstr_str
- ,str_pstr,pstr_str) where
-
-import qualified Data.Binary.IEEE754 as I
-import Data.Char
-import Data.Word
-
--- | The IEEE byte representation of a float.
-f32_w32 :: Float -> Word32
-f32_w32 = I.floatToWord
-
--- | Inverse of 'f32_w32'.
-w32_f32 :: Word32 -> Float
-w32_f32 = I.wordToFloat
-
--- | The IEEE byte representation of a double.
-f64_w64 :: Double -> Word64
-f64_w64 = I.doubleToWord
-
--- | Inverse of 'f64_i64'.
-w64_f64 :: Word64 -> Double
-w64_f64 = I.wordToDouble
-
--- | Transform a haskell string into a C string (a null suffixed byte
--- string).
-str_cstr :: String -> [Word8]
-str_cstr s = map (fromIntegral . ord) s ++ [0]
-
--- | Inverse of 'str_cstr'.
-cstr_str :: [Word8] -> String
-cstr_str = map (chr . fromIntegral) . takeWhile (/= 0)
-
--- | Transform a haskell string to a pascal string (a length prefixed
--- byte string).
-str_pstr :: String -> [Word8]
-str_pstr s = fromIntegral (length s) : map (fromIntegral . ord) s
-
--- | Inverse of 'str_pstr'.
-pstr_str :: [Word8] -> String
-pstr_str = map (chr . fromIntegral) . drop 1
diff --git a/Sound/OpenSoundControl/Coding/Coerce.hs b/Sound/OpenSoundControl/Coding/Coerce.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Coerce.hs
+++ /dev/null
@@ -1,39 +0,0 @@
--- | OSC packet coercion and normalization.
-module Sound.OpenSoundControl.Coding.Coerce where
-
-import Sound.OpenSoundControl.Type
-
--- | 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 =
- case d of
- Float n -> Double n
- _ -> d
-
--- | Coerce Int and Float to Double.
-if_to_d :: Datum -> Datum
-if_to_d d =
- case d of
- Int n -> Double (fromIntegral n)
- Float n -> Double n
- _ -> d
-
--- | Coerce Float and Double to Int.
-fd_to_i :: Datum -> Datum
-fd_to_i d =
- case d of
- Float n -> Int (round n)
- Double n -> Int (round n)
- _ -> d
-
--- | A normalized osc packet has only Int and Double numerical values.
---normalize :: OSC -> OSC
---normalize = coerce f_to_d
diff --git a/Sound/OpenSoundControl/Coding/Decode/Base.hs b/Sound/OpenSoundControl/Coding/Decode/Base.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Decode/Base.hs
+++ /dev/null
@@ -1,98 +0,0 @@
--- | Base-level decode function for OSC packets (slow). For ordinary
--- use see 'Sound.OpenSoundControl.Coding.Decode.Binary'.
-module Sound.OpenSoundControl.Coding.Decode.Base (decodeMessage
- ,decodeBundle
- ,decodePacket) where
-
-import qualified Data.ByteString.Lazy as B
-import Data.List
-import Data.Maybe
-import Sound.OpenSoundControl.Coding.Byte
-import Sound.OpenSoundControl.Time
-import Sound.OpenSoundControl.Type
-
--- The plain byte count of an OSC value.
-size :: Datum_Type -> B.ByteString -> Int
-size ty b =
- case ty of
- 'i' -> 4
- 'f' -> 4
- 'd' -> 8
- 't' -> 8 -- timetag
- 'm' -> 4 -- MIDI message
- 's' -> fromIntegral (fromMaybe
- (error ("size: no terminating zero: " ++ show b))
- (B.elemIndex 0 b))
- 'b' -> decode_i32 (B.take 4 b)
- _ -> error "size: illegal type"
-
--- The storage byte count of an OSC value.
-storage :: Datum_Type -> B.ByteString -> Int
-storage ty b =
- case ty of
- 's' -> let n = size 's' b + 1 in n + align n
- 'b' -> let n = size 'b' b in n + align n + 4
- _ -> size ty B.empty
-
--- Decode an OSC datum
-decode_datum :: Datum_Type -> B.ByteString -> Datum
-decode_datum ty b =
- case ty of
- 'i' -> Int (decode_i32 b)
- 'f' -> Float (decode_f32 b)
- '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_to_ntpr (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] ++ ")")
-
--- Decode a sequence of OSC datum given a type descriptor string.
-decode_datum_seq :: String -> B.ByteString -> [Datum]
-decode_datum_seq cs b =
- let swap (x,y) = (y,x)
- 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'.
-decodeMessage :: B.ByteString -> Message
-decodeMessage b =
- let n = storage 's' b
- (String cmd) = decode_datum 's' b
- m = storage 's' (b_drop n b)
- (String dsc) = decode_datum 's' (b_drop n b)
- arg = decode_datum_seq (drop 1 dsc) (b_drop (n + m) b)
- in Message cmd arg
-
--- Decode a sequence of OSC messages, each one headed by its length
-decode_message_seq :: B.ByteString -> [Message]
-decode_message_seq b =
- let s = decode_i32 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 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)
- in Bundle timeStamp ms
-
--- | 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 decodePacket b == Message "/g_free" [Int 0]
-decodePacket :: B.ByteString -> Packet
-decodePacket b =
- if bundleHeader `B.isPrefixOf` b
- then Packet_Bundle (decodeBundle b)
- else Packet_Message (decodeMessage b)
-
-b_take :: Int -> B.ByteString -> B.ByteString
-b_take = B.take . fromIntegral
-
-b_drop :: Int -> B.ByteString -> B.ByteString
-b_drop = B.drop . fromIntegral
diff --git a/Sound/OpenSoundControl/Coding/Decode/Binary.hs b/Sound/OpenSoundControl/Coding/Decode/Binary.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Decode/Binary.hs
+++ /dev/null
@@ -1,115 +0,0 @@
--- | Optimised decode function for OSC packets.
-module Sound.OpenSoundControl.Coding.Decode.Binary
- (getPacket
- ,decodePacket
- ,decodePacket_strict) where
-
-import Control.Applicative
-import Data.Binary.Get
-import qualified Data.Binary.IEEE754 as I
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as C
-import Data.Int (Int32)
-import Data.Word (Word32)
-import Sound.OpenSoundControl.Coding.Byte
-import Sound.OpenSoundControl.Time
-import Sound.OpenSoundControl.Type
-
--- | Isolate an action to operating within a fixed block of bytes. The action
--- is required to consume all the bytes that it is isolated to.
-isolate :: Word32 -> Get a -> Get a
-isolate n m = do
- s <- get_bytes n
- let (a, s', _) = runGetState m s 0
- if L.null s'
- then return a
- else fail "isolate: not all bytes consumed"
-
--- | Get a 32 biut integer in big-endian byte order.
-getInt32be :: Get Int32
-getInt32be = fromIntegral <$> getWord32be
-
--- | Get an aligned OSC string.
-get_string :: Get String
-get_string = do
- s <- getLazyByteStringNul
- skip (fromIntegral (align (L.length s + 1)))
- return $ C.unpack s
-
--- | Get binary data prefixed by byte count.
-get_bytes :: Word32 -> Get L.ByteString
-get_bytes n = do
- b <- getLazyByteString (fromIntegral n)
- if n /= fromIntegral (L.length b)
- then fail "get_bytes: end of stream"
- else skip (fromIntegral (align n))
- return b
-
--- | Get an OSC datum.
-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_to_ntpr <$> 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 Message
-get_message = do
- cmd <- get_string
- dsc <- get_string
- case dsc of
- (',':tags) -> do
- arg <- mapM get_datum tags
- return $ Message cmd arg
- _ -> fail "get_message: invalid type descriptor string"
-
--- | 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_message =<< getWord32be
- ps <- get_message_seq
- return (p:ps)
-
-get_bundle :: Get Bundle
-get_bundle = do
- skip (fromIntegral (L.length bundleHeader))
- t <- ntpi_to_ntpr <$> getWord64be
- ps <- get_message_seq
- return $ Bundle t ps
-
--- | 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]
-decodePacket :: L.ByteString -> Packet
-{-# INLINE decodePacket #-}
-decodePacket = runGet getPacket
-
--- | Decode an OSC packet from a strict ByteString.
-decodePacket_strict :: S.ByteString -> Packet
-{-# INLINE decodePacket_strict #-}
-decodePacket_strict = runGet getPacket . L.fromChunks . (:[])
diff --git a/Sound/OpenSoundControl/Coding/Encode/Base.hs b/Sound/OpenSoundControl/Coding/Encode/Base.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Encode/Base.hs
+++ /dev/null
@@ -1,57 +0,0 @@
--- | Base-level encode function for OSC packets (slow). For ordinary
--- use see 'Sound.OpenSoundControl.Coding.Encode.Builder'.
-module Sound.OpenSoundControl.Coding.Encode.Base (encodeMessage
- ,encodeBundle
- ,encodePacket) where
-
-import qualified Data.ByteString.Lazy as B
-import Data.Word
-import Sound.OpenSoundControl.Coding.Byte
-import Sound.OpenSoundControl.Type
-import Sound.OpenSoundControl.Time
-
--- Command argument types are given by a descriptor.
-descriptor :: [Datum] -> Datum
-descriptor l = String (',' : map datum_tag l)
-
--- Align a byte string if required.
-extend :: Word8 -> B.ByteString -> B.ByteString
-extend p s = B.append s (B.replicate (align (B.length s)) p)
-
--- Encode an OSC datum.
-encode_datum :: Datum -> B.ByteString
-encode_datum dt =
- case dt of
- Int i -> encode_i32 i
- Float f -> encode_f32 f
- Double d -> encode_f64 d
- TimeStamp t -> encode_u64 $ ntpr_to_ntpi t
- String s -> extend 0 (B.snoc (encode_str s) 0)
- Midi (b0,b1,b2,b3) -> B.pack [b0,b1,b2,b3]
- Blob b -> let n = encode_i32 (fromIntegral (B.length b))
- in B.append n (extend 0 b)
-
--- | 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 'Message' as an OSC blob.
-encode_message_blob :: Message -> Datum
-encode_message_blob = Blob . encodeMessage
-
--- | Encode an OSC 'Bundle'.
-encodeBundle :: Bundle -> B.ByteString
-encodeBundle (Bundle t m) =
- B.concat [bundleHeader
- ,encode_u64 (ntpr_to_ntpi t)
- ,B.concat (map (encode_datum . encode_message_blob) m)]
-
--- | Encode an OSC 'Packet'.
-encodePacket :: Packet -> B.ByteString
-encodePacket o =
- case o of
- Packet_Message m -> encodeMessage m
- Packet_Bundle b -> encodeBundle b
diff --git a/Sound/OpenSoundControl/Coding/Encode/Builder.hs b/Sound/OpenSoundControl/Coding/Encode/Builder.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Coding/Encode/Builder.hs
+++ /dev/null
@@ -1,93 +0,0 @@
--- | Optimised encode function for OSC packets.
-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
-import qualified Data.ByteString.Lazy as L
-import qualified Blaze.ByteString.Builder as B
-import qualified Blaze.ByteString.Builder.Char8 as B
-import Data.Monoid (mappend, mconcat)
-import Data.Word (Word8)
-import Sound.OpenSoundControl.Coding.Byte (align, bundleHeader)
-import Sound.OpenSoundControl.Time
-import Sound.OpenSoundControl.Type
-
--- Command argument types are given by a descriptor.
-descriptor :: [Datum] -> String
-descriptor l = ',' : map datum_tag l
-
--- Generate a list of zero bytes for padding.
-padding :: Integral i => i -> [Word8]
-padding n = replicate (fromIntegral n) 0
-
--- Encode a string with zero padding.
-build_string :: String -> B.Builder
-build_string s = B.fromString s `mappend` B.fromWord8s (0:padding (align (length s + 1)))
-
--- Encode a byte string with prepended length and zero padding.
-build_bytes :: L.ByteString -> B.Builder
-build_bytes s = B.fromInt32be (fromIntegral (L.length s))
- `mappend` B.fromLazyByteString s
- `mappend` B.fromWord8s (padding (align (L.length s)))
-
--- Encode an OSC datum.
-build_datum :: Datum -> B.Builder
-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 (ntpr_to_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 :: 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 -> [Message] -> B.Builder
-build_bundle_ntpi t l =
- mconcat [B.fromLazyByteString bundleHeader
- ,B.fromWord64be t
- ,mconcat $ map (build_bytes . B.toLazyByteString . build_message) 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 t m) -> build_bundle_ntpi (ntpr_to_ntpi t) m
-
-{-# 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
-encodePacket :: Packet -> L.ByteString
-encodePacket = B.toLazyByteString . build_packet
-
--- | Encode an Packet packet to a strict ByteString.
-encodePacket_strict :: Packet -> S.ByteString
-encodePacket_strict = B.toByteString . build_packet
diff --git a/Sound/OpenSoundControl/Time.hs b/Sound/OpenSoundControl/Time.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Time.hs
+++ /dev/null
@@ -1,120 +0,0 @@
--- | OSC related timing functions. OSC timestamps are @NTP@ values,
--- .
-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
-import qualified Data.Time.Clock.POSIX as T
-
--- * Temporal types
-
--- | Type for integer (binary) representation of @NTP@ time.
-type NTPi = Word64
-
--- | @NTP@ time in real-valued (fractional) form.
-type Time = Double
-
--- | @Unix/Posix@ epoch time in real-valued (fractional) form.
-type UT = Double
-
--- * Time conversion
-
--- | Convert a real-valued NTP timestamp to an 'NTPi' timestamp.
-ntpr_to_ntpi :: RealFrac n => n -> NTPi
-ntpr_to_ntpi t = round (t * 2^(32::Int))
-
--- | Convert an 'NTPi' timestamp to a real-valued NTP timestamp.
-ntpi_to_ntpr :: Fractional n => NTPi -> n
-ntpi_to_ntpr t = fromIntegral t / 2^(32::Int)
-
--- | Difference (in seconds) between /NTP/ and /UT/ epochs.
---
--- > ntp_ut_epoch_diff / (24 * 60 * 60) == 25567
-ntp_ut_epoch_diff :: Num n => n
-ntp_ut_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60
-
--- | Convert a 'UT' timestamp to an 'NTPi' timestamp.
-ut_to_ntpi :: UT -> NTPi
-ut_to_ntpi t = ntpr_to_ntpi (t + ntp_ut_epoch_diff)
-
--- | Convert @Unix/Posix@ to @NTP@.
-ut_to_ntpr :: Num n => n -> n
-ut_to_ntpr = (+) ntp_ut_epoch_diff
-
--- | Convert @NTP@ to @Unix/Posix@.
-ntpr_to_ut :: Num n => n -> n
-ntpr_to_ut = (+) (negate ntp_ut_epoch_diff)
-
--- | Convert 'NTPi' to @Unix/Posix@.
-ntpi_to_ut :: NTPi -> UT
-ntpi_to_ut = ntpr_to_ut . ntpi_to_ntpr
-
--- * Constants
-
--- | Constant indicating a bundle to be executed immediately.
---
--- > ntpr_to_ntpi immediately == 1
-immediately :: Time
-immediately = ntpi_to_ntpr 1
-
--- * 'Data.Time' inter-operation.
-
--- | The time at 1970-01-01:00:00:00.
-ut_epoch :: T.UTCTime
-ut_epoch =
- let d = T.fromGregorian 1970 1 1
- s = T.secondsToDiffTime 0
- in T.UTCTime d s
-
--- | Convert 'T.UTCTime' to @Unix/Posix@.
-utc_to_ut :: Fractional n => T.UTCTime -> n
-utc_to_ut t = realToFrac (T.diffUTCTime t ut_epoch)
-
--- * Clock operations
-
--- | Read current real-valued @NTP@ timestamp.
---
--- > do {ct <- fmap utc_to_ut T.getCurrentTime
--- > ;pt <- fmap realToFrac T.getPOSIXTime
--- > ;print (pt - ct,pt - ct < 1e-5)}
-time :: MonadIO m => m Time
-time = liftIO (fmap (ut_to_ntpr . realToFrac) T.getPOSIXTime)
-
--- * 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@.
-pauseThreadLimit :: Fractional n => n
-pauseThreadLimit = fromIntegral (maxBound::Int) / 1e6
-
--- | Pause current thread for the indicated duration (in seconds), see
--- 'pauseThreadLimit'.
-pauseThread :: (MonadIO m,Ord n,RealFrac n) => n -> m ()
-pauseThread n = when (n > 0) (liftIO (threadDelay (floor (n * 1e6))))
-
--- | Type restricted 'pauseThread'.
-wait :: MonadIO m => Double -> m ()
-wait = pauseThread
-
--- | Pause current thread until the given 'Time', see
--- 'pauseThreadLimit'.
-pauseThreadUntil :: MonadIO m => Time -> m ()
-pauseThreadUntil t = pauseThread . (t -) =<< time
-
--- | Sleep current thread for the indicated duration (in seconds).
--- Divides long sleeps into parts smaller than 'pauseThreadLimit'.
-sleepThread :: (RealFrac n, MonadIO m) => n -> m ()
-sleepThread n =
- if n >= pauseThreadLimit
- then let n' = pauseThreadLimit - 1
- in pauseThread n >> sleepThread (n - n')
- else pauseThread n
-
--- | Sleep current thread until the given 'Time'. Divides long sleeps
--- into parts smaller than 'pauseThreadLimit'.
-sleepThreadUntil :: MonadIO m => Time -> m ()
-sleepThreadUntil t = sleepThread . (t -) =<< time
diff --git a/Sound/OpenSoundControl/Type.hs b/Sound/OpenSoundControl/Type.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Type.hs
+++ /dev/null
@@ -1,252 +0,0 @@
--- | Alegbraic data types for OSC datum and packets.
-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
- | Double Double
- | String String
- | Blob B.ByteString
- | TimeStamp Time
- | Midi (Word8,Word8,Word8,Word8)
- deriving (Eq,Read,Show)
-
--- | OSC address pattern.
-type Address_Pattern = String
-
--- | 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
-
--- | '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"
-
--- | 'Packet_Bundle' '.' 'bundle'.
-p_bundle :: Time -> [Message] -> Packet
-p_bundle t = Packet_Bundle . bundle t
-
--- | 'Packet_Message' '.' 'message'.
-p_message :: Address_Pattern -> [Datum] -> Packet
-p_message a = Packet_Message . message a
-
--- * Datum
-
--- | Single character identifier of an OSC datum.
-datum_tag :: Datum -> Datum_Type
-datum_tag dt =
- case dt of
- Int _ -> 'i'
- Float _ -> 'f'
- Double _ -> 'd'
- String _ -> 's'
- Blob _ -> 'b'
- TimeStamp _ -> 't'
- Midi _ -> 'm'
-
--- | Variant of 'read'.
-readMaybe :: (Read a) => String -> Maybe a
-readMaybe s =
- case reads s of
- [(x, "")] -> Just x
- _ -> Nothing
-
--- | 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'.
-timePP :: Time -> String
-timePP = (:) 'N' . show
-
--- | 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
diff --git a/Sound/OpenSoundControl/Wait.hs b/Sound/OpenSoundControl/Wait.hs
deleted file mode 100644
--- a/Sound/OpenSoundControl/Wait.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-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
diff --git a/benchmarks/Sound/OSC/NFData.hs b/benchmarks/Sound/OSC/NFData.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/Sound/OSC/NFData.hs
@@ -0,0 +1,26 @@
+module Sound.OSC.NFData () where
+
+import Control.DeepSeq (NFData(..)) {- deepseq -}
+import Sound.OSC.Type
+
+instance NFData Datum where
+ rnf (Int32 x1) = rnf x1 `seq` ()
+ rnf (Float x1) = rnf x1 `seq` ()
+ rnf (Double x1) = rnf x1 `seq` ()
+ rnf (ASCII_String x1) = rnf x1 `seq` ()
+ rnf (Blob x1) = rnf x1 `seq` ()
+ rnf (TimeStamp x1) = rnf x1 `seq` ()
+ rnf (Midi x1) = rnf x1 `seq` ()
+
+instance NFData MIDI where
+ rnf (MIDI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()
+
+instance NFData Message where
+ rnf (Message x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
+
+instance NFData Bundle where
+ rnf (Bundle x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
+
+instance NFData Packet where
+ rnf (Packet_Message x1) = rnf x1 `seq` ()
+ rnf (Packet_Bundle x1) = rnf x1 `seq` ()
diff --git a/benchmarks/benchmark.hs b/benchmarks/benchmark.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/benchmark.hs
@@ -0,0 +1,32 @@
+import Criterion.Main {- criterion -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+
+import Sound.OSC
+import qualified Sound.OSC.Coding.Decode.Binary as Binary
+import qualified Sound.OSC.Coding.Encode.Builder as Builder
+import qualified Sound.OSC.Coding.Decode.Base as Decode
+import qualified Sound.OSC.Coding.Encode.Base as Encode
+import Sound.OSC.NFData ()
+
+type EncodingFunc = Bundle -> B.ByteString
+type DecodingFunc = B.ByteString -> Packet
+
+main :: IO ()
+main =
+ defaultMain [
+ bgroup "encodeOSC" [
+ bench "Encode" (nf (Encode.encodeBundle :: EncodingFunc) b)
+ , bench "Builder" (nf (Builder.encodeBundle :: EncodingFunc) b)
+ ]
+ , bgroup "decodeOSC" [
+ bench "Decode" (nf (Decode.decodePacket :: DecodingFunc) p)
+ , bench "Binary" (nf (Binary.decodePacket :: DecodingFunc) p)
+ ]
+ ]
+ where
+ m = Message "/fooblah" [Float 42.0
+ ,Int32 16
+ ,string "yeah"
+ ,Blob (B.pack [0..128])]
+ b = Bundle pi (replicate 12 m)
+ p = Encode.encodeBundle b
diff --git a/hosc.cabal b/hosc.cabal
--- a/hosc.cabal
+++ b/hosc.cabal
@@ -1,10 +1,10 @@
Name: hosc
-Version: 0.13
+Version: 0.14
Synopsis: Haskell Open Sound Control
Description: @hosc@ implements a subset of the /Open Sound Control/
byte protocol, .
.
- "Sound.OpenSoundControl" implements the actual protocol.
+ "Sound.OSC.Core" implements the actual protocol.
.
"Sound.OSC.Transport.FD" implements a
/file descriptor/ based transport layer for @UDP@
@@ -16,7 +16,7 @@
Composite modules are at "Sound.OSC" and "Sound.OSC.FD".
License: GPL
Category: Sound
-Copyright: (c) Rohan Drape, Stefan Kersten and others, 2006-2012
+Copyright: (c) Rohan Drape, Stefan Kersten and others, 2006-2013
Author: Rohan Drape, Stefan Kersten
Maintainer: rd@slavepianos.org
Stability: Experimental
@@ -28,7 +28,7 @@
Library
Build-Depends: base == 4.*,
- binary,
+ binary >= 0.6,
blaze-builder >= 0.3,
bytestring,
data-binary-ieee754,
@@ -36,26 +36,58 @@
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
- Sound.OpenSoundControl.Coding.Decode.Base
- Sound.OpenSoundControl.Coding.Decode.Binary
- Sound.OpenSoundControl.Coding.Encode.Base
- Sound.OpenSoundControl.Coding.Encode.Builder
- Sound.OpenSoundControl.Type
- Sound.OpenSoundControl.Coding
- Sound.OpenSoundControl.Time
- Sound.OpenSoundControl.Wait
- Sound.OSC
+ Exposed-modules: Sound.OSC
+ Sound.OSC.Class
+ Sound.OSC.Coding
+ Sound.OSC.Coding.Byte
+ Sound.OSC.Coding.Cast
+ Sound.OSC.Coding.Decode.Base
+ Sound.OSC.Coding.Decode.Binary
+ Sound.OSC.Coding.Encode.Base
+ Sound.OSC.Coding.Encode.Builder
+ Sound.OSC.Core
+ Sound.OSC.Datum
Sound.OSC.FD
+ Sound.OSC.Normalise
+ Sound.OSC.Time
Sound.OSC.Transport.FD
Sound.OSC.Transport.FD.TCP
Sound.OSC.Transport.FD.UDP
Sound.OSC.Transport.Monad
+ Sound.OSC.Type
+ Sound.OSC.Wait
Source-Repository head
Type: darcs
Location: http://rd.slavepianos.org/sw/hosc/
+
+Benchmark hosc-benchmark
+ Type: exitcode-stdio-1.0
+ Hs-Source-Dirs: benchmarks
+ Main-Is: benchmark.hs
+ Other-Modules:
+ Sound.OSC.NFData
+ Build-Depends:
+ base == 4.*
+ , hosc == 0.14.*
+ , bytestring
+ , criterion
+ , deepseq
+ GHC-Options: -Wall -fwarn-tabs -rtsopts -fno-warn-orphans
+ GHC-Prof-Options: -Wall -fwarn-tabs -rtsopts -auto-all
+
+Test-Suite hosc-test
+ Type: exitcode-stdio-1.0
+ Hs-Source-Dirs: tests
+ Main-Is: test.hs
+ Other-Modules:
+ Sound.OSC.Arbitrary
+ Build-Depends:
+ base == 4.*
+ , bytestring >= 0.10
+ , hosc == 0.14.*
+ , QuickCheck >= 2
+ , test-framework >= 0.2
+ , test-framework-quickcheck2 >= 0.2
+ GHC-Options: -Wall -fwarn-tabs -rtsopts -fno-warn-orphans
+ GHC-Prof-Options: -Wall -fwarn-tabs -rtsopts -auto-all
diff --git a/tests/Sound/OSC/Arbitrary.hs b/tests/Sound/OSC/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/tests/Sound/OSC/Arbitrary.hs
@@ -0,0 +1,43 @@
+module Sound.OSC.Arbitrary () where
+
+import Control.Applicative {- base -}
+import qualified Data.ByteString.Char8 as C {- bytestring -}
+import qualified Data.ByteString.Lazy as B {- bytestring -}
+import Test.QuickCheck {- QuickCheck -}
+
+import Sound.OSC
+
+-- Avoid floating point representation/conversion errors
+genTime :: Gen Time
+genTime = ntpi_to_ntpr <$> arbitrary
+
+genString :: Gen String
+genString = resize 128 (listOf (arbitrary `suchThat` (/= '\0')))
+
+genASCII :: Gen ASCII
+genASCII = fmap C.pack genString
+
+genMIDI :: Gen MIDI
+genMIDI = do
+ (p,q,r,s) <- arbitrary
+ return (MIDI p q r s)
+
+instance Arbitrary Datum where
+ arbitrary = oneof [
+ Int32 <$> arbitrary
+ , Float <$> realToFrac <$> (arbitrary :: Gen Float)
+ , Double <$> arbitrary
+ , ASCII_String <$> genASCII
+ , Blob <$> B.pack <$> resize 128 arbitrary
+ , TimeStamp <$> genTime
+ , Midi <$> genMIDI
+ ]
+
+genMessage :: Gen Message
+genMessage = message <$> ("/"++) <$> genString <*> resize 32 (listOf1 arbitrary)
+
+instance Arbitrary Packet where
+ arbitrary = oneof [
+ Packet_Message <$> genMessage
+ , p_bundle <$> genTime <*> resize 32 (listOf1 genMessage)
+ ]
diff --git a/tests/test.hs b/tests/test.hs
new file mode 100644
--- /dev/null
+++ b/tests/test.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Sound.OSC.Arbitrary ()
+import qualified Sound.OSC.Coding.Decode.Base as DecodeBase
+import qualified Sound.OSC.Coding.Encode.Base as EncodeBase
+import qualified Sound.OSC.Coding.Decode.Binary as DecodeBinary
+import qualified Sound.OSC.Coding.Encode.Builder as EncodeBuilder
+import Sound.OSC.Type (Packet)
+import Test.Framework (Test, defaultMain)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+
+tests :: [Test]
+tests =
+ [ testProperty "encodePacket (Builder)" $ \(osc :: Packet) ->
+ EncodeBuilder.encodePacket osc == EncodeBase.encodePacket osc
+ , testProperty "encodePacket/decodePacket" $ \(osc :: Packet) ->
+ DecodeBase.decodePacket (EncodeBase.encodePacket osc) == osc
+ , testProperty "decodePacket (Get)" $ \(osc :: Packet) ->
+ DecodeBinary.decodePacket (EncodeBase.encodePacket osc) == osc
+ ]
+
+main :: IO ()
+main = defaultMain tests