hosc 0.19.1 → 0.21.1

raw patch · 44 files changed

Files

README.md +18/−10
Sound/OSC.hs +0/−8
Sound/OSC/Coding/Byte.hs +0/−329
Sound/OSC/Coding/Cast.hs +0/−41
Sound/OSC/Coding/Convert.hs +0/−129
Sound/OSC/Coding/Decode/Base.hs +0/−109
Sound/OSC/Coding/Decode/Binary.hs +0/−136
Sound/OSC/Coding/Encode/Base.hs +0/−58
Sound/OSC/Coding/Encode/Builder.hs +0/−116
Sound/OSC/Core.hs +0/−20
Sound/OSC/Datum.hs +0/−289
Sound/OSC/FD.hs +0/−7
Sound/OSC/Packet.hs +0/−135
Sound/OSC/Time.hs +0/−183
Sound/OSC/Transport/FD.hs +0/−93
Sound/OSC/Transport/FD/TCP.hs +0/−95
Sound/OSC/Transport/FD/UDP.hs +0/−99
Sound/OSC/Transport/Monad.hs +0/−123
Sound/OSC/Wait.hs +0/−26
Sound/Osc.hs +7/−0
Sound/Osc/Coding/Byte.hs +410/−0
Sound/Osc/Coding/Cast.hs +72/−0
Sound/Osc/Coding/Convert.hs +129/−0
Sound/Osc/Coding/Decode/Base.hs +122/−0
Sound/Osc/Coding/Decode/Binary.hs +152/−0
Sound/Osc/Coding/Encode/Base.hs +117/−0
Sound/Osc/Coding/Encode/Builder.hs +115/−0
Sound/Osc/Core.hs +21/−0
Sound/Osc/Datum.hs +264/−0
Sound/Osc/Fd.hs +6/−0
Sound/Osc/Packet.hs +142/−0
Sound/Osc/Text.hs +279/−0
Sound/Osc/Time.hs +116/−0
Sound/Osc/Time/System.hs +25/−0
Sound/Osc/Time/Thread.hs +39/−0
Sound/Osc/Time/Thread/MonadIO.hs +25/−0
Sound/Osc/Time/Timeout.hs +15/−0
Sound/Osc/Transport/Fd.hs +101/−0
Sound/Osc/Transport/Fd/Socket.hs +40/−0
Sound/Osc/Transport/Fd/Tcp.hs +101/−0
Sound/Osc/Transport/Fd/Udp.hs +119/−0
Sound/Osc/Transport/Monad.hs +128/−0
Sound/Osc/Wait.hs +18/−0
hosc.cabal +33/−31

README.md view

@@ -1,26 +1,26 @@ hosc - haskell open sound control --------------------------------- -[hosc][hosc] provides `Sound.OSC`, a [haskell][hs]+[hosc][hosc] provides `Sound.Osc`, a [haskell][hs] module implementing a subset of the [Open Sound Control][osc] byte protocol.-hosc is required by the [hsc3][hsc3] haskell [supercollider][sc3] bindings.+hosc is required by the [hsc3][hsc3] Haskell [SuperCollider][sc3] bindings.  See also: -- [hosc-json](http://rohandrape.net/?t=hosc-json): JSON text encoding of OSC-- [hosc-util](http://rohandrape.net/?t=hosc-util): non-core OSC functions+- [hosc-json](http://rohandrape.net/?t=hosc-json): Json text encoding of Osc+- [hosc-util](http://rohandrape.net/?t=hosc-util): non-core Osc functions -© [rohan drape][rd], [stefan kersten][sk] and others, 2007-2021,-[gpl-3][gpl-3]. with contributions by:+© [Rohan Drape][rd], [Stefan Kersten][sk] and others, 2007-2024,+[Gpl-3][gpl-3]. with contributions by: -- [alex mclean][am]-- [henning thielemann][ht]+- [Alex McLean][am]+- [Henning Thielemann][ht] -see the [git](https://git-scm.com/) [history](http://rohandrape.net/?t=hosc&q=history) for details+Please see the [history](http://rohandrape.net/?t=hosc&q=history) for details  [hosc]: http://rohandrape.net/?t=hosc [hs]: http://haskell.org/-[osc]: http://opensoundcontrol.org/+[osc]: https://opensoundcontrol.stanford.edu/ [hsc3]: http://rohandrape.net/?t=hsc3 [sc3]: http://audiosynth.com/ [rd]:  http://rohandrape.net/@@ -29,3 +29,11 @@ [ht]: http://www.henning-thielemann.de/Research.html [gpl]: http://gnu.org/copyleft/ [gpl-3]: http://gnu.org/licenses/gpl-3.0.html++* * *++```+$ make doctest+Examples: 110  Tried: 110  Errors: 0  Failures: 0+$+```

− Sound/OSC.hs

@@ -1,8 +0,0 @@--- | 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.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

− Sound/OSC/Coding/Byte.hs

@@ -1,329 +0,0 @@--- | Byte-level coding utility functions.---   Plain forms are big-endian, little-endian forms have @_le@ suffix.-module Sound.OSC.Coding.Byte where--import Data.Bits {- base -}-import Data.Int {- base -}-import Data.Word {- base -}-import System.IO {- base -}--import qualified Data.Binary as Binary {- binary -}-import qualified Data.Binary.Get as Get {- binary -}-import qualified Data.Binary.Put as Put {- binary -}-import qualified Data.ByteString as S {- bytestring -}-import qualified Data.ByteString.Char8 as S.C {- bytestring -}-import qualified Data.ByteString.Lazy as L {- bytestring -}-import qualified Data.ByteString.Lazy.Char8 as L.C {- bytestring -}--import qualified Sound.OSC.Coding.Cast as Cast {- hosc -}-import Sound.OSC.Coding.Convert {- hosc -}---- * Encode---- | Type specialised 'Binary.encode' (big-endian).-encode_int8 :: Int8 -> L.ByteString-encode_int8 = Binary.encode---- | Type specialised 'Binary.encode' (big-endian).------ > encode_int16 0x0102 == L.pack [0x01,0x02]-encode_int16 :: Int16 -> L.ByteString-encode_int16 = Binary.encode---- | Little-endian.------ > encode_int16_le 0x0102 == L.pack [0x02,0x01]-encode_int16_le :: Int16 -> L.ByteString-encode_int16_le = Put.runPut . Put.putInt16le---- | Encode a signed 64-bit integer (big-endian).-encode_int64 :: Int64 -> L.ByteString-encode_int64 = Binary.encode---- | Type specialised 'Binary.encode' (big-endian).-encode_word8 :: Word8 -> L.ByteString-encode_word8 = Binary.encode---- | Type specialised 'Binary.encode' (big-endian).------ > encode_word16 0x0102 == L.pack [0x01,0x02]-encode_word16 :: Word16 -> L.ByteString-encode_word16 = Binary.encode---- | Little-endian.------ > encode_word16_le 0x0102 == L.pack [0x02,0x01]-encode_word16_le :: Word16 -> L.ByteString-encode_word16_le = Put.runPut . Put.putWord16le---- | Type specialised 'Binary.encode'.-encode_word32 :: Word32 -> L.ByteString-encode_word32 = Binary.encode---- | Little-endian variant of 'encode_word32'.-encode_word32_le :: Word32 -> L.ByteString-encode_word32_le = Put.runPut . Put.putWord32le---- | Encode an unsigned 64-bit integer.-encode_word64 :: Word64 -> L.ByteString-encode_word64 = Binary.encode---- * Encode/Int---- | Encode a signed 8-bit integer.-encode_i8 :: Int -> L.ByteString-encode_i8 = encode_int8 . int_to_int8---- | Encode an un-signed 8-bit integer.-encode_u8 :: Int -> L.ByteString-encode_u8 = encode_word8 . int_to_word8---- | Encode an un-signed 16-bit integer.------ > encode_u16 0x0102 == L.pack [1,2]-encode_u16 :: Int -> L.ByteString-encode_u16 = encode_word16 . int_to_word16---- | Little-endian.------ > encode_u16_le 0x0102 == L.pack [2,1]-encode_u16_le :: Int -> L.ByteString-encode_u16_le = encode_word16_le . int_to_word16---- | Encode a signed 16-bit integer.-encode_i16 :: Int -> L.ByteString-encode_i16 = Binary.encode . int_to_int16---- | Encode a signed 32-bit integer.-encode_i32 :: Int -> L.ByteString-encode_i32 = Binary.encode . int_to_int32---- | Encode an unsigned 32-bit integer.------ > encode_u32 0x01020304 == L.pack [1,2,3,4]-encode_u32 :: Int -> L.ByteString-encode_u32 = encode_word32 . int_to_word32---- | Little-endian.------ > encode_u32_le 0x01020304 == L.pack [4,3,2,1]-encode_u32_le :: Int -> L.ByteString-encode_u32_le = encode_word32_le . int_to_word32---- * Encode/Float---- | Encode a 32-bit IEEE floating point number.-encode_f32 :: Float -> L.ByteString-encode_f32 = Binary.encode . Cast.f32_w32---- | Little-endian variant of 'encode_f32'.-encode_f32_le :: Float -> L.ByteString-encode_f32_le = Put.runPut . Put.putWord32le . Cast.f32_w32---- | Encode a 64-bit IEEE floating point number.-encode_f64 :: Double -> L.ByteString-encode_f64 = Binary.encode . Cast.f64_w64---- | Little-endian variant of 'encode_f64'.-encode_f64_le :: Double -> L.ByteString-encode_f64_le = Put.runPut . Put.putWord64le . Cast.f64_w64---- * Encode/ASCII---- | Encode an ASCII string (ASCII at Datum is an alias for a Char8 Bytetring).-encode_ascii :: S.C.ByteString -> L.ByteString-encode_ascii = L.pack . S.unpack---- * Decode---- | Type specialised 'Binary.decode'.-decode_word16 :: L.ByteString -> Word16-decode_word16 = Binary.decode---- | Little-endian variant of 'decode_word16'.-decode_word16_le :: L.ByteString -> Word16-decode_word16_le = Get.runGet Get.getWord16le---- | Type specialised 'Binary.decode'.-decode_int16 :: L.ByteString -> Int16-decode_int16 = Binary.decode---- | Type specialised 'Binary.decode'.-decode_word32 :: L.ByteString -> Word32-decode_word32 = Binary.decode---- | Little-endian variant of 'decode_word32'.-decode_word32_le :: L.ByteString -> Word32-decode_word32_le = Get.runGet Get.getWord32le---- | Type specialised 'Binary.decode'.-decode_int64 :: L.ByteString -> Int64-decode_int64 = Binary.decode---- | Type specialised 'Binary.decode'.-decode_word64 :: L.ByteString -> Word64-decode_word64 = Binary.decode---- * Decode/Int---- | Decode an un-signed 8-bit integer.-decode_u8 :: L.ByteString -> Int-decode_u8 = word8_to_int . L.head---- | Decode a signed 8-bit integer.-decode_i8 :: L.ByteString -> Int-decode_i8 = int8_to_int . Binary.decode---- | Decode an unsigned 8-bit integer.-decode_u16 :: L.ByteString -> Int-decode_u16 = word16_to_int . decode_word16---- | Little-endian variant of 'decode_u16'.-decode_u16_le :: L.ByteString -> Int-decode_u16_le = word16_to_int . decode_word16_le---- | Decode a signed 16-bit integer.-decode_i16 :: L.ByteString -> Int-decode_i16 = int16_to_int . decode_int16---- | Little-endian variant of 'decode_i16'.-decode_i16_le :: L.ByteString -> Int-decode_i16_le = decode_i16 . L.reverse---- | Decode a signed 32-bit integer.------ > decode_i32 (L.pack [0x00,0x00,0x03,0xe7]) == 0x03e7-decode_i32 :: L.ByteString -> Int-decode_i32 = int32_to_int . Binary.decode---- | Little-endian variant of 'decode_i32'.------ > decode_i32_le (L.pack [0xe7,0x03,0x00,0x00]) == 0x03e7-decode_i32_le :: L.ByteString -> Int-decode_i32_le = decode_i32 . L.reverse---- | Decode an unsigned 32-bit integer.------ > decode_u32 (L.pack [1,2,3,4]) == 0x01020304-decode_u32 :: L.ByteString -> Int-decode_u32 = word32_to_int . decode_word32---- | Little-endian variant of decode_u32.------ > decode_u32_le (L.pack [1,2,3,4]) == 0x04030201-decode_u32_le :: L.ByteString -> Int-decode_u32_le = word32_to_int . decode_word32_le---- * Decode/Float---- | Decode a 32-bit IEEE floating point number.-decode_f32 :: L.ByteString -> Float-decode_f32 = Cast.w32_f32 . decode_word32---- | Little-endian variant of 'decode_f32'.-decode_f32_le :: L.ByteString -> Float-decode_f32_le = Cast.w32_f32 . decode_word32_le---- | Decode a 64-bit IEEE floating point number.-decode_f64 :: L.ByteString -> Double-decode_f64 b = Cast.w64_f64 (Binary.decode b :: Word64)---- * Decode/ASCII---- | Decode an ASCII string, inverse of 'encode_ascii'.-decode_ascii :: L.ByteString -> S.C.ByteString-{-# INLINE decode_ascii #-}-decode_ascii = S.C.pack . L.C.unpack---- * IO---- | Read /n/ bytes from /h/ and run /f/.-read_decode :: (L.ByteString -> t) -> Int -> Handle -> IO t-read_decode f n = fmap f . flip L.hGet n---- | Type-specialised reader for 'Binary.decode'.-read_word32 :: Handle -> IO Word32-read_word32 = read_decode Binary.decode 4---- | 'read_decode' of 'decode_word32_le'.-read_word32_le :: Handle -> IO Word32-read_word32_le = read_decode decode_word32_le 4---- | 'L.hPut' of 'encode_word32'.-write_word32 :: Handle -> Word32 -> IO ()-write_word32 h = L.hPut h . encode_word32---- | 'L.hPut' of 'encode_word32_le'.-write_word32_le :: Handle -> Word32 -> IO ()-write_word32_le h = L.hPut h . encode_word32_le---- * IO/Int---- | 'decode_i8' of 'L.hGet'.-read_i8 :: Handle -> IO Int-read_i8 = read_decode decode_i8 1---- | 'decode_i16' of 'L.hGet'.-read_i16 :: Handle -> IO Int-read_i16 = read_decode decode_i16 2---- | 'decode_i32' of 'L.hGet'.-read_i32 :: Handle -> IO Int-read_i32 = read_decode decode_i32 4---- | 'decode_i32_le' of 'L.hGet'.-read_i32_le :: Handle -> IO Int-read_i32_le = read_decode decode_i32_le 4---- | 'decode_u32' of 'L.hGet'.-read_u32 :: Handle -> IO Int-read_u32 = read_decode decode_u32 4---- | 'decode_u32_le' of 'L.hGet'.-read_u32_le :: Handle -> IO Int-read_u32_le = read_decode decode_u32_le 4---- | 'L.hPut' of 'encode_u32'.-write_u32 :: Handle -> Int -> IO ()-write_u32 h = L.hPut h . encode_u32---- | 'L.hPut' of 'encode_u32_le'.-write_u32_le :: Handle -> Int -> IO ()-write_u32_le h = L.hPut h . encode_u32_le---- * IO/Float---- | 'decode_f32' of 'L.hGet'.-read_f32 :: Handle -> IO Float-read_f32 = read_decode decode_f32 4---- | 'decode_f32_le' of 'L.hGet'.-read_f32_le :: Handle -> IO Float-read_f32_le = read_decode decode_f32_le 4---- * IO/ASCII---- | Read u8 length prefixed ASCII string (pascal string).-read_pstr :: Handle -> IO S.C.ByteString-read_pstr h = do-  n <- fmap decode_u8 (L.hGet h 1)-  fmap decode_ascii (L.hGet h n)---- * Util---- | 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 :: L.ByteString-{-# INLINE bundleHeader #-}-bundleHeader = L.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

− Sound/OSC/Coding/Cast.hs

@@ -1,41 +0,0 @@--- | Bit-level type casts and byte layout string typecasts.-module Sound.OSC.Coding.Cast where--import Data.Char {- base -}-import Data.Word {- base -}--import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -}--import Sound.OSC.Coding.Convert {- hosc -}---- | 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 (int_to_word8 . ord) s ++ [0]---- | Inverse of 'str_cstr'.-cstr_str :: [Word8] -> String-cstr_str = map (chr . word8_to_int) . takeWhile (/= 0)---- | Transform a haskell string to a pascal string (a length prefixed byte string).-str_pstr :: String -> [Word8]-str_pstr s = int_to_word8 (length s) : map (int_to_word8 . ord) s---- | Inverse of 'str_pstr'.-pstr_str :: [Word8] -> String-pstr_str = map (chr . word8_to_int) . drop 1

− Sound/OSC/Coding/Convert.hs

@@ -1,129 +0,0 @@--- | Type conversion.-module Sound.OSC.Coding.Convert where--import Data.Int {- base -}-import Data.Word {- base -}---- * Int -> N---- | Type specialised 'fromIntegral'-int_to_word8 :: Int -> Word8-int_to_word8 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_word32 :: Int -> Word32-int_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'.-int_to_word16 :: Int -> Word16-int_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int8 :: Int -> Int8-int_to_int8 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int16 :: Int -> Int16-int_to_int16 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int32 :: Int -> Int32-int_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int_to_int64 :: Int -> Int64-int_to_int64 = fromIntegral---- * N -> Int---- | Type specialised 'fromIntegral'-int8_to_int :: Int8 -> Int-int8_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int16_to_int :: Int16 -> Int-int16_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int32_to_int :: Int32 -> Int-int32_to_int = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int :: Int64 -> Int-int64_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word8_to_int :: Word8 -> Int-word8_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word16_to_int :: Word16 -> Int-word16_to_int = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int :: Word32 -> Int-word32_to_int = fromIntegral---- * N -> N---- | Type specialised 'fromIntegral'-word16_to_word32 :: Word16 -> Word32-word16_to_word32 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_word16 :: Word32 -> Word16-word32_to_word16 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int32 :: Word32 -> Int32-word32_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-word32_to_int64 :: Word32 -> Int64-word32_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-word64_to_int64 :: Word64 -> Int64-word64_to_int64 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_int32 :: Int64 -> Int32-int64_to_int32 = fromIntegral---- | Type specialised 'fromIntegral'-int64_to_word32 :: Int64 -> Word32-int64_to_word32 = fromIntegral---- * N -> Real---- | Type specialised 'fromIntegral'-word64_to_double :: Word64 -> Double-word64_to_double = fromIntegral---- * Enum---- | Type-specialised 'toEnum' of 'fromIntegral'-word8_to_enum :: Enum e => Word8 -> e-word8_to_enum = toEnum . fromIntegral---- | Type-specialised 'toEnum' of 'fromIntegral'-word16_to_enum :: Enum e => Word16 -> e-word16_to_enum = toEnum . fromIntegral---- | Type-specialised 'fromIntegral' of 'fromEnum'.-enum_to_word8 :: Enum e => e -> Word8-enum_to_word8 = fromIntegral . fromEnum---- | Type-specialised 'fromIntegral' of 'fromEnum'.-enum_to_word16 :: Enum e => e -> Word16-enum_to_word16 = fromIntegral . fromEnum---- * Enum/Char---- | Type-specialised 'word8_to_enum'.-word8_to_char :: Word8 -> Char-word8_to_char = word8_to_enum---- | Type-specialised 'enum_to_word8'.-char_to_word8 :: Char -> Word8-char_to_word8 = enum_to_word8

− Sound/OSC/Coding/Decode/Base.hs

@@ -1,109 +0,0 @@--- | Base-level decode function for OSC packets.---   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 {- hosc -}-import Sound.OSC.Coding.Convert {- hosc -}-import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Packet {- hosc -}-import Sound.OSC.Time {- hosc -}---- | The plain byte count of an OSC value.-size :: Datum_Type -> B.ByteString -> Int-size ty b =-    case ty of-      'i' -> 4 -- Int32-      'f' -> 4 -- Float-      'd' -> 8 -- Double-      't' -> 8 -- Time (NTP)-      'm' -> 4 -- MIDI-      's' -> int64_to_int (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 (aligned) 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_ascii (b_take (size 's' b) b))-      'b' -> Blob (b_take (size 'b' b) (B.drop 4 b))-      't' -> TimeStamp (ntpi_to_ntpr (decode_word64 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 (int_to_int64 (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 length prefixed (Int32) OSC messages.-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-        (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]--- > decodePacket b == Packet_Message (Message "/g_free" [Int32 0])-decodePacket :: B.ByteString -> Packet-decodePacket b =-    if bundleHeader `B.isPrefixOf` b-    then Packet_Bundle (decodeBundle b)-    else Packet_Message (decodeMessage b)---- * UTIL---- | 'B.take' with 'Int' count.-b_take :: Int -> B.ByteString -> B.ByteString-b_take = B.take . int_to_int64---- | 'B.drop' with 'Int' count.-b_drop :: Int -> B.ByteString -> B.ByteString-b_drop = B.drop . int_to_int64

− Sound/OSC/Coding/Decode/Binary.hs

@@ -1,136 +0,0 @@--- | Optimised decode function for OSC packets.-module Sound.OSC.Coding.Decode.Binary-    (get_packet-    ,decodeMessage-    ,decodeBundle-    ,decodePacket-    ,decodePacket_strict) where--import Control.Applicative {- base -}-import Control.Monad {- base -}-import Data.Int {- base -}-import Data.Word {- base -}--import qualified Data.Binary.Get as G {- 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 qualified Sound.OSC.Coding.Byte as Byte {- hosc -}-import Sound.OSC.Coding.Convert {- hosc -}-import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Packet {- hosc -}-import qualified Sound.OSC.Time as Time {- hosc -}---- | Get a 32 bit integer in big-endian byte order.-getInt32be :: G.Get Int32-getInt32be = fmap word32_to_int32 G.getWord32be---- | Get a 64 bit integer in big-endian byte order.-getInt64be :: G.Get Int64-getInt64be = fmap word64_to_int64 G.getWord64be---- | Get an aligned OSC string.-get_string :: G.Get String-get_string = do-    s <- G.getLazyByteStringNul-    G.skip (int64_to_int (Byte.align (B.length s + 1)))-    return (C.unpack s)---- | Get an aligned OSC string.-get_ascii :: G.Get ASCII-get_ascii = do-    s <- G.getLazyByteStringNul-    G.skip (int64_to_int (Byte.align (B.length s + 1)))-    return (S.C.pack (C.unpack s))---- | Get binary data prefixed by byte count.-get_bytes :: Word32 -> G.Get B.ByteString-get_bytes n = do-    b <- G.getLazyByteString (word32_to_int64 n)-    if n /= int64_to_word32 (B.length b)-        then fail "get_bytes: end of stream"-        else G.skip (word32_to_int (Byte.align n))-    return b---- | Get an OSC datum.-get_datum :: Datum_Type -> G.Get Datum-get_datum ty =-    case ty of-      'i' -> fmap Int32 getInt32be-      'h' -> fmap Int64 getInt64be-      'f' -> fmap Float I.getFloat32be-      'd' -> fmap Double I.getFloat64be-      's' -> fmap ASCII_String get_ascii-      'b' -> fmap Blob (get_bytes =<< G.getWord32be)-      't' -> fmap (TimeStamp . Time.ntpi_to_ntpr) G.getWord64be-      'm' -> do b0 <- G.getWord8-                b1 <- G.getWord8-                b2 <- G.getWord8-                b3 <- G.getWord8-                return (Midi (MIDI b0 b1 b2 b3))-      _ -> fail ("get_datum: illegal type " ++ show ty)---- | Get an OSC 'Message', fail if type descriptor is invalid.-get_message :: G.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)-        e -> fail ("get_message: invalid type descriptor string: " ++ e)---- | Get a sequence of OSC 'Message's, each one headed by its length.-get_message_seq :: G.Get [Message]-get_message_seq = do-    b <- G.isEmpty-    if b-        then return []-        else do-            p <- flip G.isolate get_message . word32_to_int =<< G.getWord32be-            ps <- get_message_seq-            return (p:ps)---- | Get a bundle. Fail if bundle header is not found in packet.-get_bundle :: G.Get Bundle-get_bundle = do-    h <- G.getByteString (S.C.length Byte.bundleHeader_strict)-    when (h /= Byte.bundleHeader_strict) (fail "get_bundle: not a bundle")-    t <- fmap Time.ntpi_to_ntpr G.getWord64be-    fmap (Bundle t) get_message_seq---- | Get an OSC 'Packet'.-get_packet :: G.Get Packet-get_packet = fmap Packet_Bundle get_bundle <|> fmap Packet_Message get_message--{-# INLINE decodeMessage #-}-{-# INLINE decodeBundle #-}-{-# INLINE decodePacket #-}-{-# INLINE decodePacket_strict #-}--{- | Decode an OSC 'Message' from a lazy ByteString.--> let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]-> decodeMessage b == Message "/g_free" [Int32 0]--}-decodeMessage :: B.ByteString -> Message-decodeMessage = G.runGet get_message---- | Decode an OSC 'Bundle' from a lazy ByteString.-decodeBundle :: B.ByteString -> Bundle-decodeBundle = G.runGet get_bundle--{- | 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]-> decodePacket b == Packet_Message (Message "/g_free" [Int32 0])--}-decodePacket :: B.ByteString -> Packet-decodePacket = G.runGet get_packet---- | Decode an OSC packet from a strict Char8 ByteString.-decodePacket_strict :: S.C.ByteString -> Packet-decodePacket_strict = G.runGet get_packet . B.fromChunks . (:[])

− Sound/OSC/Coding/Encode/Base.hs

@@ -1,58 +0,0 @@--- | Base-level encode function for OSC packets (slow).---   For ordinary use see 'Sound.OSC.Coding.Encode.Builder'.-module Sound.OSC.Coding.Encode.Base 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 {- hosc -}-import Sound.OSC.Coding.Convert {- hosc -}-import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Packet {- hosc -}-import Sound.OSC.Time {- hosc -}---- | Align byte string, if required.-extend :: Word8 -> B.ByteString -> B.ByteString-extend p s = B.append s (B.replicate (align (B.length s)) p)---- | Encode OSC 'Datum'.------ MIDI: Bytes from MSB to LSB are: port id, status byte, data1, data2.-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_word64 $ ntpr_to_ntpi t-      ASCII_String s -> extend 0 (B.snoc (encode_ascii s) 0)-      Midi (MIDI b0 b1 b2 b3) -> B.pack [b0,b1,b2,b3]-      Blob b -> let n = encode (int64_to_int32 (B.length b))-                in B.append n (extend 0 b)---- | Encode 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 OSC 'Message' as an OSC blob.-encode_message_blob :: Message -> Datum-encode_message_blob = Blob . encodeMessage---- | Encode OSC 'Bundle'.-encodeBundle :: Bundle -> B.ByteString-encodeBundle (Bundle t m) =-    B.concat [bundleHeader-             ,encode_word64 (ntpr_to_ntpi t)-             ,B.concat (map (encode_datum . encode_message_blob) m)]---- | Encode OSC 'Packet'.-encodePacket :: Packet -> B.ByteString-encodePacket o =-    case o of-      Packet_Message m -> encodeMessage m-      Packet_Bundle b -> encodeBundle b

− Sound/OSC/Coding/Encode/Builder.hs

@@ -1,116 +0,0 @@--- | Optimised encode function for OSC packets.-{-# LANGUAGE CPP #-}--module Sound.OSC.Coding.Encode.Builder-    (build_packet-    ,encodeMessage-    ,encodeBundle-    ,encodePacket-    ,encodePacket_strict) where--import Data.Word {- base -}--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 -}--#ifdef IMPORT_SEMIGROUP-import Data.Semigroup-#endif--import qualified Sound.OSC.Coding.Byte as Byte {- hosc -}-import qualified Sound.OSC.Coding.Convert as Convert {- hosc -}-import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Packet {- hosc -}-import Sound.OSC.Time {- hosc -}---- | Generate a list of zero bytes for padding.-padding :: Int -> [Word8]-padding n = replicate n 0---- | Nul byte (0) and then zero padding.-nul_and_padding :: Int -> B.Builder-nul_and_padding n = B.fromWord8s (0 : padding (Byte.align n))---- Encode a string with zero padding.-build_ascii :: ASCII -> B.Builder-build_ascii s = B.fromByteString s <> nul_and_padding (S.length s + 1)---- Encode a string with zero padding.-build_string :: String -> B.Builder-build_string s = B.fromString s <> nul_and_padding (length s + 1)---- Encode a byte string with prepended length and zero padding.-build_bytes :: L.ByteString -> B.Builder-build_bytes s =-  B.fromInt32be (Convert.int64_to_int32 (L.length s)) <>-  B.fromLazyByteString s <>-  B.fromWord8s (padding (Convert.int64_to_int (Byte.align (L.length s))))---- Encode an OSC datum.-build_datum :: Datum -> B.Builder-build_datum d =-    case d of-      Int32 i -> B.fromInt32be i-      Int64 i -> B.fromInt64be i-      Float n -> B.fromWord32be (I.floatToWord n)-      Double n -> B.fromWord64be (I.doubleToWord n)-      TimeStamp t -> B.fromWord64be (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 :: NTP64 -> [Message] -> B.Builder-build_bundle_ntpi t l =-    mconcat [B.fromLazyByteString Byte.bundleHeader-            ,B.fromWord64be t-            ,mconcat (map (build_bytes . B.toLazyByteString . build_message) l)]---- | Builder 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 encodePacket #-}-{-# INLINE encodeMessage #-}-{-# INLINE encodeBundle #-}-{-# INLINE encodePacket_strict #-}---- | Encode an OSC 'Packet'.-encodePacket :: Packet -> L.ByteString-encodePacket = B.toLazyByteString . build_packet--{- | Encode an OSC 'Message', ie. 'encodePacket' of 'Packet_Message'.--> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]-> encodeMessage (Message "/g_free" [Int32 0]) == L.pack m---}-encodeMessage :: Message -> L.ByteString-encodeMessage = encodePacket . Packet_Message--{- | Encode an OSC 'Bundle', ie. 'encodePacket' of 'Packet_Bundle'.--> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]-> let b = [35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,1,0,0,0,16] ++ m-> encodeBundle (Bundle immediately [Message "/g_free" [Int32 0]]) == L.pack b---}-encodeBundle :: Bundle -> L.ByteString-encodeBundle = encodePacket . Packet_Bundle---- | Encode an OSC 'Packet' to a strict 'S.ByteString'.-encodePacket_strict :: Packet -> S.ByteString-encodePacket_strict = B.toByteString . build_packet

− Sound/OSC/Core.hs

@@ -1,20 +0,0 @@-{- | Composite of non-transport related modules.--Provides the 'Datum', 'Message', 'Time', 'Bundle' and 'Packet' types-and the coding functions 'encodePacket' and 'decodePacket'.--> import Sound.OSC.Core {- hosc -}->-> let o = bundle immediately [message "/g_free" [Int32 0]]-> let e = encodeBundle o-> decodePacket e == Packet_Bundle o---}-module Sound.OSC.Core (module M) where--import Sound.OSC.Coding.Decode.Binary as M-import Sound.OSC.Coding.Encode.Builder as M-import Sound.OSC.Datum as M-import Sound.OSC.Packet as M-import Sound.OSC.Time as M-import Sound.OSC.Wait as M

− Sound/OSC/Datum.hs

@@ -1,289 +0,0 @@--- | Data type for OSC datum.-module Sound.OSC.Datum where--import Data.Char {- base -}-import Data.Int {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}-import Data.Word {- base -}-import Numeric {- base -}-import Text.Printf {- base -}-import Text.Read {- base -}--import qualified Data.ByteString.Lazy as Lazy {- bytestring -}-import qualified Data.ByteString.Char8 as Char8 {- bytestring -}--import qualified Sound.OSC.Time as Time {- hosc -}---- * Datum---- | Type enumerating Datum categories.-type Datum_Type = Char---- | Type for ASCII strings (strict 'Char'8 'Char8.ByteString').-type ASCII = Char8.ByteString---- | Type-specialised 'Char8.pack'.-ascii :: String -> ASCII-ascii = Char8.pack---- | Type-specialised 'Char8.unpack'.-ascii_to_string :: ASCII -> String-ascii_to_string = Char8.unpack---- | Type for 'Word8' arrays, these are stored with an 'Int32' length prefix.-type BLOB = Lazy.ByteString---- | Type-specialised 'Lazy.pack'.-blob_pack ::  [Word8] -> BLOB-blob_pack = Lazy.pack---- | Type-specialised 'Lazy.unpack'.-blob_unpack :: BLOB -> [Word8]-blob_unpack = Lazy.unpack---- | Four-byte midi message: port-id, status-byte, data, data.-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 :: !BLOB}-           | TimeStamp {d_timestamp :: !Time.Time} -- ie. NTPr-           | Midi {d_midi :: !MIDI}-             deriving (Eq,Read,Show)---- * Datum types---- | List of required data types (tag,name).-osc_types_required :: [(Datum_Type,String)]-osc_types_required =-    [('i',"Int32")-    ,('f',"Float")-    ,('s',"ASCII_String") -- ASCII-    ,('b',"ByteArray") -- Blob-    ]---- | List of optional data types (tag,name).-osc_types_optional :: [(Datum_Type,String)]-osc_types_optional =-    [('h',"Int64")-    ,('t',"TimeStamp")-    ,('d',"Double")-    -- ,('S',"Symbol")-    -- ,('c',"ASCII_Character")-    -- ,('r',"RGBA")-    ,('m',"MIDI")-    -- ,('T',"True")-    -- ,('F',"False")-    -- ,('N',"Nil")-    -- ,('I',"Infinitum")-    -- ,('[',"Array_Begin")-    -- ,(']',"Array_End")-    ]---- | List of all data types (tag,name).-osc_types :: [(Datum_Type,String)]-osc_types = osc_types_required ++ osc_types_optional---- | Lookup name of type.-osc_type_name :: Datum_Type -> Maybe String-osc_type_name c = lookup c osc_types---- | Erroring variant.-osc_type_name_err :: Datum_Type -> String-osc_type_name_err = fromMaybe (error "osc_type_name") . osc_type_name---- | Single character identifier of an OSC datum.-datum_tag :: Datum -> Datum_Type-datum_tag d =-    case d of-      Int32 _ -> 'i'-      Int64 _ -> 'h'-      Float _ -> 'f'-      Double _ -> 'd'-      ASCII_String _ -> 's'-      Blob _ -> 'b'-      TimeStamp _ -> 't'-      Midi _ -> 'm'---- | Type and name of 'Datum'.-datum_type_name :: Datum -> (Datum_Type,String)-datum_type_name d = let c = datum_tag d in (c,osc_type_name_err c)---- * Generalised element access---- | 'Datum' as 'Integral' if Int32 or Int64.------ > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5]--- > 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 Int32, Int64, Float, Double or TimeStamp.------ > let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5]--- > 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---- * Constructors---- | Type generalised '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 Int64.------ > int64 (1::Int32) == int64 (1::Integer)--- > d_int64 (int64 (maxBound::Int64)) == maxBound-int64 :: Integral n => n -> Datum-int64 = Int64 . fromIntegral---- | Type generalised 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 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 'Char8.pack'.------ > string "string" == ASCII_String (Char8.pack "string")-string :: String -> Datum-string = ASCII_String . Char8.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)---- | 'Blob' of 'blob_pack'.-blob :: [Word8] -> Datum-blob = Blob . blob_pack---- * Descriptor---- | Message argument types are given by a descriptor.------ > descriptor [Int32 1,Float 1,string "1"] == ascii ",ifs"-descriptor :: [Datum] -> ASCII-descriptor l = Char8.pack (',' : map datum_tag l)---- | Descriptor tags are @comma@ prefixed.-descriptor_tags :: ASCII -> ASCII-descriptor_tags = Char8.drop 1---- * Pretty printing---- | Perhaps a precision value for floating point numbers.-type FP_Precision = Maybe Int---- | Variant of 'showFFloat' that deletes trailing zeros.------ > map (floatPP (Just 4)) [1,pi] == ["1.0","3.1416"]-floatPP :: RealFloat n => FP_Precision -> n -> String-floatPP p n =-    let s = showFFloat p n ""-        s' = dropWhile (== '0') (reverse s)-    in case s' of-         '.':_ -> reverse ('0' : s')-         _ -> reverse s'---- | Pretty printer for 'Time'.------ > timePP (Just 4) (1/3) == "0.3333"-timePP :: FP_Precision -> Time.Time -> String-timePP = floatPP---- | Pretty printer for vectors.------ > vecPP show [1::Int,2,3] == "<1,2,3>"-vecPP :: (a -> String) -> [a] -> String-vecPP f v = '<' : intercalate "," (map f v) ++ ">"---- | Pretty printer for blobs, two-digit zero-padded hexadecimal.-blobPP :: BLOB -> String-blobPP = ('B':) . vecPP (printf "%02X") . Lazy.unpack---- | Print strings in double quotes iff they contain white space.-stringPP :: String -> String-stringPP x = if any isSpace x then show x else x--{- | Pretty printer for 'Datum'.--> let d = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60),blob [12,16]]-> map (datumPP (Just 5)) d==  ["1","1.2","str","M<0,144,64,96>","B<0C,10>"]---}-datumPP :: FP_Precision -> Datum -> String-datumPP p d =-    case d of-      Int32 n -> show n-      Int64 n -> show n-      Float n -> floatPP p n-      Double n -> floatPP p n-      ASCII_String s -> stringPP (Char8.unpack s)-      Blob s -> blobPP s-      TimeStamp t -> timePP p t-      Midi (MIDI b1 b2 b3 b4) -> 'M': vecPP show [b1,b2,b3,b4]---- | Variant of 'datumPP' that appends the 'datum_type_name'.-datum_pp_typed :: FP_Precision -> Datum -> String-datum_pp_typed fp d = datumPP fp d ++ ":" ++ snd (datum_type_name d)---- * Parser---- | 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 (blob_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 . Char8.pack) . readMaybe-      'b' -> fmap (Blob . blob_pack) . readMaybe-      't' -> error "parse_datum: timestamp not implemented"-      'm' -> fmap midi . readMaybe-      _ -> error "parse_datum: unknown type"---- | Erroring variant of 'parse_datum'.-parse_datum_err :: Datum_Type -> String -> Datum-parse_datum_err ty = fromMaybe (error "parse_datum") . parse_datum ty

− Sound/OSC/FD.hs

@@ -1,7 +0,0 @@--- | Composite of "Sound.OSC.Core" and "Sound.OSC.Transport.FD".-module Sound.OSC.FD (module M) where--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

− Sound/OSC/Packet.hs

@@ -1,135 +0,0 @@--- | Data types for OSC messages, bundles and packets.-module Sound.OSC.Packet where--import Data.List {- base -}--import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Time {- hosc -}---- * Message---- | OSC address pattern.  This is strictly an ASCII value, however it---   is very common to pattern match on addresses and matching on---   Data.ByteString.Char8 requires @OverloadedStrings@.-type Address_Pattern = String---- | An OSC message, an 'Address_Pattern' and a sequence of 'Datum'.-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"---- * Bundle---- | An OSC bundle, a 'Time' and a sequence of 'Message's.-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' of 'bundle'.-p_bundle :: Time -> [Message] -> Packet-p_bundle t = Packet_Bundle . bundle t---- | 'Packet_Message' of '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 'Message'.--> messagePP Nothing (Message "/m" [int32 0,float 1.0,string "s",midi (1,2,3,4),blob [1,2,3]])--}-messagePP :: FP_Precision -> Message -> String-messagePP p (Message a d) = let d' = map (datumPP p) d in unwords (a : d')---- | Pretty printer for 'Bundle'.-bundlePP :: FP_Precision -> Bundle -> String-bundlePP p (Bundle t m) = let m' = intersperse ";" (map (messagePP p) m) in unwords (timePP p t : m')---- | Pretty printer for 'Packet'.-packetPP :: FP_Precision -> Packet -> String-packetPP p pkt =-    case pkt of-      Packet_Message m -> messagePP p m-      Packet_Bundle b -> bundlePP p b

− Sound/OSC/Time.hs

@@ -1,183 +0,0 @@--- | OSC related timing functions.---   OSC timestamps are 64-bit @NTP@ values, <http://ntp.org/>.-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.Coding.Convert {- hosc -}---- * Temporal types---- | Type for binary (integeral) representation of a 64-bit @NTP@ timestamp (ie. @ntpi@).---   The NTP epoch is January 1, 1900.---   NTPv4 also includes a 128-bit format, which is not used by OSC.-type NTP64 = Word64---- | @NTP@ time in real-valued (fractional) form (ie. @ntpr@).---   This is the primary form of timestamp used by hosc.-type Time = Double---- | Constant indicating a bundle to be executed immediately.---   It has the NTP64 representation of @1@.-immediately :: Time-immediately = 1 / 2^(32::Int)---- | @Unix/Posix@ time in real-valued (fractional) form.---   The Unix/Posix epoch is January 1, 1970.-type UT = Double---- * Time conversion---- | Convert a real-valued NTP timestamp to an 'NTPi' timestamp.------ > ntpr_to_ntpi immediately == 1--- > fmap ntpr_to_ntpi time-ntpr_to_ntpi :: Time -> NTP64-ntpr_to_ntpi t = round (t * (2 ^ (32::Int)))---- | Convert an 'NTPi' timestamp to a real-valued NTP timestamp.-ntpi_to_ntpr :: NTP64 -> Time-ntpi_to_ntpr t = word64_to_double t / 2^(32::Int)---- | Difference (in seconds) between /NTP/ and /UT/ epochs.------ > ntp_ut_epoch_diff / (24 * 60 * 60) == 25567--- > 25567 `div` 365 == 70-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 -> NTP64-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 :: NTP64 -> UT-ntpi_to_ut = ntpr_to_ut . ntpi_to_ntpr---- | Convert 'Time' to 'T.POSIXTime'.-ntpr_to_posixtime :: Time -> T.POSIXTime-ntpr_to_posixtime = realToFrac . ntpr_to_ut---- | Convert 'T.POSIXTime' to 'Time'.-posixtime_to_ntpr :: T.POSIXTime -> Time-posixtime_to_ntpr = ut_to_ntpr . realToFrac---- * '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.--> get_ct = fmap utc_to_ut T.getCurrentTime-> get_pt = fmap realToFrac T.getPOSIXTime-> (ct,pt) <- get_ct >>= \t0 -> get_pt >>= \t1 -> return (t0,t1)-> print (pt - ct,pt - ct < 1e-5)---}-time :: MonadIO m => m Time-time = liftIO (fmap posixtime_to_ntpr 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,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---- * Pretty printing---- | Detailed 37-character ISO 8601 format, including fractional seconds and '+0000' suffix.-iso_8601_fmt :: String-iso_8601_fmt = "%Y-%m-%dT%H:%M:%S,%q+0000"---- | Parse time according to 'iso_8601_fmt'------ > iso_8601_to_utctime "2015-11-26T00:29:37,145875000000+0000"-iso_8601_to_utctime :: String -> Maybe T.UTCTime-iso_8601_to_utctime = T.parseTimeM True T.defaultTimeLocale iso_8601_fmt---- | UTC time in 'iso_8601_fmt'.------ > tm <- fmap (utctime_to_iso_8601 . T.posixSecondsToUTCTime) T.getPOSIXTime--- > (length tm,sum [4+1+2+1+2,1,2+1+2+1+2,1,12,1,4],sum [10,1,8,1,12,1,4]) == (37,37,37)-utctime_to_iso_8601 :: T.UTCTime -> String-utctime_to_iso_8601 = T.formatTime T.defaultTimeLocale iso_8601_fmt---- | ISO 8601 of 'Time'.------ > tm <- fmap ntpr_to_iso_8601 time--- > import System.Process {- process -}--- > rawSystem "date" ["-d",tm]------ > t = 15708783354150518784--- > s = "2015-11-26T00:22:19,366058349609+0000"--- > ntpr_to_iso_8601 (ntpi_to_ntpr t) == s-ntpr_to_iso_8601 :: Time -> String-ntpr_to_iso_8601 = utctime_to_iso_8601 . T.posixSecondsToUTCTime . ntpr_to_posixtime---- | 'Time' of ISO 8601.------ > t = 15708783354150518784--- > s = "2015-11-26T00:22:19,366058349609+0000"--- > fmap ntpr_to_ntpi (iso_8601_to_ntpr s) == Just t-iso_8601_to_ntpr :: String -> Maybe Time-iso_8601_to_ntpr = fmap (posixtime_to_ntpr . T.utcTimeToPOSIXSeconds) . iso_8601_to_utctime---- | Alias for 'ntpr_to_iso_8601'.------ > time_pp immediately == "1900-01-01T00:00:00,000000000000+0000"--- > fmap time_pp time-time_pp :: Time -> String-time_pp = ntpr_to_iso_8601

− Sound/OSC/Transport/FD.hs

@@ -1,93 +0,0 @@--- | An abstract transport layer with implementations for @UDP@ and @TCP@ transport.-module Sound.OSC.Transport.FD where--import Control.Exception {- base -}-import Data.List {- base -}-import Data.Maybe {- base -}--import Sound.OSC.Datum {- hosc -}-import Sound.OSC.Packet {- hosc -}-import qualified Sound.OSC.Wait as Wait {- hosc -}---- | Abstract over the underlying transport protocol.-class Transport t where-   -- | Encode and send an OSC packet.-   sendPacket :: t -> Packet -> 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---- | 'sendPacket' of 'Packet_Message'.-sendMessage :: Transport t => t -> Message -> IO ()-sendMessage t = sendPacket t . Packet_Message---- | 'sendPacket' of 'Packet_Bundle'.-sendBundle :: Transport t => t -> Bundle -> IO ()-sendBundle t = sendPacket t . Packet_Bundle---- * Receive---- | 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 = Wait.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 = Wait.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 = Wait.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

− Sound/OSC/Transport/FD/TCP.hs

@@ -1,95 +0,0 @@--- | OSC over TCP implementation.-module Sound.OSC.Transport.FD.TCP where--import qualified Control.Exception as Exception {- base -}-import qualified Data.ByteString.Lazy as B {- bytestring -}-import qualified Network.Socket as N {- network -}-import qualified System.IO as IO {- base -}--import qualified Sound.OSC.Coding.Decode.Binary as Binary {- hosc -}-import qualified Sound.OSC.Coding.Encode.Builder as Builder {- hosc -}-import qualified Sound.OSC.Coding.Byte as Byte {- hosc -}-import qualified Sound.OSC.Coding.Convert as Convert {- hosc -}-import qualified Sound.OSC.Packet as Packet {- hosc -}-import qualified Sound.OSC.Transport.FD as FD {- hosc -}---- | The TCP transport handle data type.-newtype TCP = TCP {tcpHandle :: IO.Handle}---- | Send packet over TCP.-tcp_send_packet :: TCP -> Packet.Packet -> IO ()-tcp_send_packet (TCP fd) p = do-  let b = Builder.encodePacket p-      n = Convert.int64_to_word32 (B.length b)-  B.hPut fd (B.append (Byte.encode_word32 n) b)-  IO.hFlush fd---- | Receive packet over TCP.-tcp_recv_packet :: TCP -> IO Packet.Packet-tcp_recv_packet (TCP fd) = do-  b0 <- B.hGet fd 4-  b1 <- B.hGet fd (Convert.word32_to_int (Byte.decode_word32 b0))-  return (Binary.decodePacket b1)---- | Close TCP.-tcp_close :: TCP -> IO ()-tcp_close = IO.hClose . tcpHandle---- | 'TCP' is an instance of 'Transport'.-instance FD.Transport TCP where-   sendPacket = tcp_send_packet-   recvPacket = tcp_recv_packet-   close = tcp_close---- | Bracket UDP communication.-with_tcp :: IO TCP -> (TCP -> IO t) -> IO t-with_tcp u = Exception.bracket u tcp_close---- | Create and initialise TCP socket.-tcp_socket :: (N.Socket -> N.SockAddr -> IO ()) -> Maybe String -> Int -> IO N.Socket-tcp_socket f host port = do-  fd <- N.socket N.AF_INET N.Stream 0-  let hints = N.defaultHints {N.addrFamily = N.AF_INET} -- localhost=ipv4-  i:_ <- N.getAddrInfo (Just hints) host (Just (show port))-  let sa = N.addrAddress i-  _ <- f fd sa-  return fd---- | Convert 'N.Socket' to 'TCP'.-socket_to_tcp :: N.Socket -> IO TCP-socket_to_tcp fd = fmap TCP (N.socketToHandle fd IO.ReadWriteMode)---- | Create and initialise TCP.-tcp_handle :: (N.Socket -> N.SockAddr -> IO ()) -> String -> Int -> IO TCP-tcp_handle f host port = tcp_socket f (Just host) port >>= socket_to_tcp--{- | Make a 'TCP' connection.--> import Sound.OSC.Datum {- hosc -}-> import Sound.OSC.Time {- hosc -}-> let t = openTCP "127.0.0.1" 57110-> let m1 = Packet.message "/dumpOSC" [Int32 1]-> let m2 = Packet.message "/g_new" [Int32 1]-> FD.withTransport t (\fd -> let f = FD.sendMessage fd in f m1 >> pauseThread 0.25 >> f m2)---}-openTCP :: String -> Int -> IO TCP-openTCP = tcp_handle N.connect---- | 'N.accept' connection at /s/ and run /f/.-tcp_server_f :: N.Socket -> (TCP -> IO ()) -> IO ()-tcp_server_f s f = do-  (fd, _) <- N.accept s-  h <- socket_to_tcp fd-  f h---- | 'sequence_' of 'repeat'.-repeatM_ :: (Monad m) => m a -> m ()-repeatM_ = sequence_ . repeat---- | A trivial 'TCP' /OSC/ server.-tcp_server :: Int -> (TCP -> IO ()) -> IO ()-tcp_server port f = do-  s <- tcp_socket N.bind Nothing port-  N.listen s 1-  repeatM_ (tcp_server_f s f)

− Sound/OSC/Transport/FD/UDP.hs

@@ -1,99 +0,0 @@--- | OSC over UDP implementation.-module Sound.OSC.Transport.FD.UDP where--import Control.Exception {- base -}-import Data.Bifunctor {- base -}--import qualified Network.Socket as N {- network -}-import qualified Network.Socket.ByteString as C {- network -}--import qualified Sound.OSC.Coding.Decode.Binary as Binary {- hosc -}-import qualified Sound.OSC.Coding.Encode.Builder as Builder {- hosc -}-import qualified Sound.OSC.Packet as Packet {- hosc -}-import qualified Sound.OSC.Transport.FD as FD {- hosc -}---- | The UDP transport handle data type.-newtype UDP = UDP {udpSocket :: N.Socket}---- | Return the port number associated with the UDP socket.-udpPort :: Integral n => UDP -> IO n-udpPort = fmap fromIntegral . N.socketPort . udpSocket---- | Send packet over UDP using 'C.sendAll'.-upd_send_packet :: UDP -> Packet.Packet -> IO ()-upd_send_packet (UDP fd) p = C.sendAll fd (Builder.encodePacket_strict p)---- | Receive packet over UDP.-udp_recv_packet :: UDP -> IO Packet.Packet-udp_recv_packet (UDP fd) = fmap Binary.decodePacket_strict (C.recv fd 8192)---- | Close UDP.-udp_close :: UDP -> IO ()-udp_close (UDP fd) = N.close fd---- | 'UDP' is an instance of 'FD.Transport'.-instance FD.Transport UDP where-   sendPacket = upd_send_packet-   recvPacket = udp_recv_packet-   close = udp_close---- | Bracket UDP communication.-with_udp :: IO UDP -> (UDP -> IO t) -> IO t-with_udp u = bracket u udp_close---- | 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-  let hints = N.defaultHints {N.addrFamily = N.AF_INET} -- localhost=ipv4-  i:_ <- N.getAddrInfo (Just hints) (Just host) (Just (show port))-  let sa = N.addrAddress i-  f fd sa-  return (UDP fd)---- | Set option, ie. 'N.Broadcast' or 'N.RecvTimeOut'.-set_udp_opt :: N.SocketOption -> Int -> UDP -> IO ()-set_udp_opt k v (UDP s) = N.setSocketOption s k v---- | Get option.-get_udp_opt :: N.SocketOption -> UDP -> IO Int-get_udp_opt k (UDP s) = N.getSocketOption s k---- | Make a 'UDP' connection.-openUDP :: String -> Int -> IO UDP-openUDP = udp_socket N.connect--{- | Trivial 'UDP' server socket.--> import Control.Concurrent {- base -}--> let u0 = udpServer "127.0.0.1" 57300-> t0 <- forkIO (FD.withTransport u0 (\fd -> forever (FD.recvMessage fd >>= print)))--> let u1 = openUDP "127.0.0.1" 57300-> FD.withTransport u1 (\fd -> FD.sendMessage fd (Packet.message "/n" []))--}-udpServer :: String -> Int -> IO UDP-udpServer = udp_socket N.bind---- | Variant of 'udpServer' that doesn't require the host address.-udp_server :: Int -> IO UDP-udp_server p = do-  let hints =-        N.defaultHints-        {N.addrFamily = N.AF_INET -- localhost=ipv4-        ,N.addrFlags = [N.AI_PASSIVE,N.AI_NUMERICSERV]-        ,N.addrSocketType = N.Datagram}-  a:_ <- N.getAddrInfo (Just hints) Nothing (Just (show p))-  s <- N.socket (N.addrFamily a) (N.addrSocketType a) (N.addrProtocol a)-  N.setSocketOption s N.ReuseAddr 1-  N.bind s (N.addrAddress a)-  return (UDP s)---- | Send to specified address using 'C.sendAllTo.-sendTo :: UDP -> Packet.Packet -> N.SockAddr -> IO ()-sendTo (UDP fd) p = C.sendAllTo fd (Builder.encodePacket_strict p)---- | Recv variant to collect message source address.-recvFrom :: UDP -> IO (Packet.Packet, N.SockAddr)-recvFrom (UDP fd) = fmap (first Binary.decodePacket_strict) (C.recvFrom fd 8192)

− Sound/OSC/Transport/Monad.hs

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

− Sound/OSC/Wait.hs

@@ -1,26 +0,0 @@--- | Waiting (for replies).-module Sound.OSC.Wait where--import System.Timeout {- base -}---- * Timeout---- | Variant of 'timeout' where time is given in fractional seconds.-timeout_r :: Double -> IO a -> IO (Maybe a)-timeout_r = timeout . floor . (* 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 recur else return p-        recur = act >>= g-    in recur---- | 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 = maybe recur return (f p)-        recur = act >>= g-    in recur

+ Sound/Osc.hs view

@@ -0,0 +1,7 @@+-- | 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.Osc.Core as M+import Sound.Osc.Transport.Fd.Socket as M+import Sound.Osc.Transport.Monad as M

+ Sound/Osc/Coding/Byte.hs view

@@ -0,0 +1,410 @@+{- | Byte-level coding utility functions.+Plain forms are big-endian, little-endian forms have @_le@ suffix.+-}+module Sound.Osc.Coding.Byte where++import Data.Bits {- base -}+import Data.Int {- base -}+import Data.Word {- base -}+import System.IO {- base -}++import qualified GHC.ByteOrder {- base -}++import qualified Data.Binary as Binary {- binary -}+import qualified Data.Binary.Get as Binary.Get {- binary -}+import qualified Data.Binary.Put as Binary.Put {- binary -}++import qualified Data.ByteString as ByteString {- bytestring -}+import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -}+import qualified Data.ByteString.Internal as ByteString.Internal {- bytestring -}+import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -}+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 {- bytestring -}+import qualified Data.ByteString.Unsafe as ByteString.Unsafe {- bytestring -}++import qualified Sound.Osc.Coding.Convert as Convert {- hosc -}++-- * Encode++-- | Type specialised 'Binary.encode' (big-endian).+encode_int8 :: Int8 -> ByteString.Lazy.ByteString+encode_int8 = Binary.encode++{- | Type specialised 'Binary.encode' (big-endian).++>>> encode_int16 0x0102 == ByteString.Lazy.pack [0x01,0x02]+True+-}+encode_int16 :: Int16 -> ByteString.Lazy.ByteString+encode_int16 = Binary.encode++{- | Little-endian.++>>> encode_int16_le 0x0102 == ByteString.Lazy.pack [0x02,0x01]+True+-}+encode_int16_le :: Int16 -> ByteString.Lazy.ByteString+encode_int16_le = Binary.Put.runPut . Binary.Put.putInt16le++-- | Encode a signed 64-bit integer (big-endian).+encode_int64 :: Int64 -> ByteString.Lazy.ByteString+encode_int64 = Binary.encode++-- | Type specialised 'Binary.encode' (big-endian).+encode_word8 :: Word8 -> ByteString.Lazy.ByteString+encode_word8 = Binary.encode++{- | Type specialised 'Binary.encode' (big-endian).++>>> encode_word16 0x0102 == ByteString.Lazy.pack [0x01,0x02]+True+-}+encode_word16 :: Word16 -> ByteString.Lazy.ByteString+encode_word16 = Binary.encode++{- | Little-endian.++>>> encode_word16_le 0x0102 == ByteString.Lazy.pack [0x02,0x01]+True+-}+encode_word16_le :: Word16 -> ByteString.Lazy.ByteString+encode_word16_le = Binary.Put.runPut . Binary.Put.putWord16le++-- | Type specialised 'Binary.encode'.+encode_word32 :: Word32 -> ByteString.Lazy.ByteString+encode_word32 = Binary.encode++-- | Little-endian variant of 'encode_word32'.+encode_word32_le :: Word32 -> ByteString.Lazy.ByteString+encode_word32_le = Binary.Put.runPut . Binary.Put.putWord32le++-- | Encode an unsigned 64-bit integer.+encode_word64 :: Word64 -> ByteString.Lazy.ByteString+encode_word64 = Binary.encode++-- * Encode/Int++-- | Encode a signed 8-bit integer.+encode_i8 :: Int -> ByteString.Lazy.ByteString+encode_i8 = encode_int8 . Convert.int_to_int8++-- | Encode an un-signed 8-bit integer.+encode_u8 :: Int -> ByteString.Lazy.ByteString+encode_u8 = encode_word8 . Convert.int_to_word8++{- | Encode an un-signed 16-bit integer.++>>> encode_u16 0x0102 == ByteString.Lazy.pack [1,2]+True+-}+encode_u16 :: Int -> ByteString.Lazy.ByteString+encode_u16 = encode_word16 . Convert.int_to_word16++{- | Little-endian.++>>> encode_u16_le 0x0102 == ByteString.Lazy.pack [2,1]+True+-}+encode_u16_le :: Int -> ByteString.Lazy.ByteString+encode_u16_le = encode_word16_le . Convert.int_to_word16++-- | Encode a signed 16-bit integer.+encode_i16 :: Int -> ByteString.Lazy.ByteString+encode_i16 = Binary.encode . Convert.int_to_int16++-- | Encode a signed 32-bit integer.+encode_i32 :: Int -> ByteString.Lazy.ByteString+encode_i32 = Binary.encode . Convert.int_to_int32++{- | Encode an unsigned 32-bit integer.++>>> ByteString.Lazy.unpack (encode_u32 0x01020304)+[1,2,3,4]+-}+encode_u32 :: Int -> ByteString.Lazy.ByteString+encode_u32 = encode_word32 . Convert.int_to_word32++{- | Little-endian.++>>> ByteString.Lazy.unpack (encode_u32_le 0x01020304)+[4,3,2,1]+-}+encode_u32_le :: Int -> ByteString.Lazy.ByteString+encode_u32_le = encode_word32_le . Convert.int_to_word32++-- * Encode/Float++{- | Encode a 32-bit IEEE floating point number.++>>> ByteString.Lazy.unpack (encode_f32 3.141)+[64,73,6,37]+-}+encode_f32 :: Float -> ByteString.Lazy.ByteString+encode_f32 = Binary.Put.runPut . Binary.Put.putFloatbe++{- | Little-endian variant of 'encode_f32'.++>>> ByteString.Lazy.unpack (encode_f32_le 3.141)+[37,6,73,64]+-}+encode_f32_le :: Float -> ByteString.Lazy.ByteString+encode_f32_le = Binary.Put.runPut . Binary.Put.putFloatle++{- | Encode a 64-bit IEEE floating point number.++>>> ByteString.Lazy.unpack (encode_f64 3.141)+[64,9,32,196,155,165,227,84]+-}+encode_f64 :: Double -> ByteString.Lazy.ByteString+encode_f64 = Binary.Put.runPut . Binary.Put.putDoublebe++{- | Little-endian variant of 'encode_f64'.++>>> ByteString.Lazy.unpack (encode_f64_le 3.141)+[84,227,165,155,196,32,9,64]+-}+encode_f64_le :: Double -> ByteString.Lazy.ByteString+encode_f64_le = Binary.Put.runPut . Binary.Put.putDoublele++-- * Encode/Ascii++-- | Encode an Ascii string (Ascii at Datum is an alias for a Char8 Bytetring).+encode_ascii :: ByteString.Char8.ByteString -> ByteString.Lazy.ByteString+encode_ascii = ByteString.Lazy.pack . ByteString.unpack++-- * Decode++-- | Type specialised 'Binary.decode'.+decode_word16 :: ByteString.Lazy.ByteString -> Word16+decode_word16 = Binary.decode++-- | Little-endian variant of 'decode_word16'.+decode_word16_le :: ByteString.Lazy.ByteString -> Word16+decode_word16_le = Binary.Get.runGet Binary.Get.getWord16le++-- | Type specialised 'Binary.decode'.+decode_int16 :: ByteString.Lazy.ByteString -> Int16+decode_int16 = Binary.decode++-- | Type specialised 'Binary.decode'.+decode_word32 :: ByteString.Lazy.ByteString -> Word32+decode_word32 = Binary.decode++-- | Little-endian variant of 'decode_word32'.+decode_word32_le :: ByteString.Lazy.ByteString -> Word32+decode_word32_le = Binary.Get.runGet Binary.Get.getWord32le++-- | Type specialised 'Binary.decode'.+decode_int64 :: ByteString.Lazy.ByteString -> Int64+decode_int64 = Binary.decode++-- | Type specialised 'Binary.decode'.+decode_word64 :: ByteString.Lazy.ByteString -> Word64+decode_word64 = Binary.decode++-- * Decode/Int++-- | Decode an un-signed 8-bit integer.+decode_u8 :: ByteString.Lazy.ByteString -> Int+decode_u8 = Convert.word8_to_int . ByteString.Lazy.head++-- | Decode a signed 8-bit integer.+decode_i8 :: ByteString.Lazy.ByteString -> Int+decode_i8 = Convert.int8_to_int . Binary.decode++-- | Decode an unsigned 8-bit integer.+decode_u16 :: ByteString.Lazy.ByteString -> Int+decode_u16 = Convert.word16_to_int . decode_word16++-- | Little-endian variant of 'decode_u16'.+decode_u16_le :: ByteString.Lazy.ByteString -> Int+decode_u16_le = Convert.word16_to_int . decode_word16_le++-- | Decode a signed 16-bit integer.+decode_i16 :: ByteString.Lazy.ByteString -> Int+decode_i16 = Convert.int16_to_int . decode_int16++-- | Little-endian variant of 'decode_i16'.+decode_i16_le :: ByteString.Lazy.ByteString -> Int+decode_i16_le = decode_i16 . ByteString.Lazy.reverse++{- | Decode a signed 32-bit integer.++>>> decode_i32 (ByteString.Lazy.pack [0x00,0x00,0x03,0xe7]) == 0x03e7+True+-}+decode_i32 :: ByteString.Lazy.ByteString -> Int+decode_i32 = Convert.int32_to_int . Binary.decode++{- | Little-endian variant of 'decode_i32'.++>>> decode_i32_le (ByteString.Lazy.pack [0xe7,0x03,0x00,0x00]) == 0x03e7+True+-}+decode_i32_le :: ByteString.Lazy.ByteString -> Int+decode_i32_le = decode_i32 . ByteString.Lazy.reverse++{- | Decode an unsigned 32-bit integer.++>>> decode_u32 (ByteString.Lazy.pack [1,2,3,4]) == 0x01020304+True+-}+decode_u32 :: ByteString.Lazy.ByteString -> Int+decode_u32 = Convert.word32_to_int . decode_word32++{- | Little-endian variant of decode_u32.++>>> decode_u32_le (ByteString.Lazy.pack [1,2,3,4]) == 0x04030201+True+-}+decode_u32_le :: ByteString.Lazy.ByteString -> Int+decode_u32_le = Convert.word32_to_int . decode_word32_le++-- * Decode/Float++{- | Decode a 32-bit IEEE floating point number.++>>> decode_f32 (ByteString.Lazy.pack [64,73,6,37])+3.141+-}+decode_f32 :: ByteString.Lazy.ByteString -> Float+decode_f32 = Binary.Get.runGet Binary.Get.getFloatbe++-- | Little-endian variant of 'decode_f32'.+decode_f32_le :: ByteString.Lazy.ByteString -> Float+decode_f32_le = Binary.Get.runGet Binary.Get.getFloatle++-- | Decode a 64-bit IEEE floating point number.+decode_f64 :: ByteString.Lazy.ByteString -> Double+decode_f64 = Binary.Get.runGet Binary.Get.getDoublebe++-- * Decode/Ascii++-- | Decode an Ascii string, inverse of 'encode_ascii'.+decode_ascii :: ByteString.Lazy.ByteString -> ByteString.Char8.ByteString+{-# INLINE decode_ascii #-}+decode_ascii = ByteString.Char8.pack . ByteString.Lazy.Char8.unpack++-- * IO++-- | Read /n/ bytes from /h/ and run /f/.+read_decode :: (ByteString.Lazy.ByteString -> t) -> Int -> Handle -> IO t+read_decode f n = fmap f . flip ByteString.Lazy.hGet n++-- | Type-specialised reader for 'Binary.decode'.+read_word32 :: Handle -> IO Word32+read_word32 = read_decode Binary.decode 4++-- | 'read_decode' of 'decode_word32_le'.+read_word32_le :: Handle -> IO Word32+read_word32_le = read_decode decode_word32_le 4++-- | 'ByteString.Lazy.hPut' of 'encode_word32'.+write_word32 :: Handle -> Word32 -> IO ()+write_word32 h = ByteString.Lazy.hPut h . encode_word32++-- | 'ByteString.Lazy.hPut' of 'encode_word32_le'.+write_word32_le :: Handle -> Word32 -> IO ()+write_word32_le h = ByteString.Lazy.hPut h . encode_word32_le++-- * Io/Int++-- | 'decode_i8' of 'ByteString.Lazy.hGet'.+read_i8 :: Handle -> IO Int+read_i8 = read_decode decode_i8 1++-- | 'decode_i16' of 'ByteString.Lazy.hGet'.+read_i16 :: Handle -> IO Int+read_i16 = read_decode decode_i16 2++-- | 'decode_i32' of 'ByteString.Lazy.hGet'.+read_i32 :: Handle -> IO Int+read_i32 = read_decode decode_i32 4++-- | 'decode_i32_le' of 'ByteString.Lazy.hGet'.+read_i32_le :: Handle -> IO Int+read_i32_le = read_decode decode_i32_le 4++-- | 'decode_u32' of 'ByteString.Lazy.hGet'.+read_u32 :: Handle -> IO Int+read_u32 = read_decode decode_u32 4++-- | 'decode_u32_le' of 'ByteString.Lazy.hGet'.+read_u32_le :: Handle -> IO Int+read_u32_le = read_decode decode_u32_le 4++-- | 'ByteString.Lazy.hPut' of 'encode_u32'.+write_u32 :: Handle -> Int -> IO ()+write_u32 h = ByteString.Lazy.hPut h . encode_u32++-- | 'ByteString.Lazy.hPut' of 'encode_u32_le'.+write_u32_le :: Handle -> Int -> IO ()+write_u32_le h = ByteString.Lazy.hPut h . encode_u32_le++-- * Io/Float++-- | 'decode_f32' of 'ByteString.Lazy.hGet'.+read_f32 :: Handle -> IO Float+read_f32 = read_decode decode_f32 4++-- | 'decode_f32_le' of 'ByteString.Lazy.hGet'.+read_f32_le :: Handle -> IO Float+read_f32_le = read_decode decode_f32_le 4++-- * Io/Ascii++-- | Read u8 length prefixed Ascii string (pascal string).+read_pstr :: Handle -> IO ByteString.Char8.ByteString+read_pstr h = do+  n <- fmap decode_u8 (ByteString.Lazy.hGet h 1)+  fmap decode_ascii (ByteString.Lazy.hGet h n)++-- * Util++{- | Bundle header as a (strict) 'ByteString.Char8.ByteString'.++>>> ByteString.Char8.length bundleHeader_strict+8+-}+bundleHeader_strict :: ByteString.Char8.ByteString+bundleHeader_strict = ByteString.Char8.pack "#bundle\0"++{- | Bundle header as a lazy ByteString.++>>> ByteString.Lazy.length bundleHeader+8+-}+bundleHeader :: ByteString.Lazy.ByteString+{-# INLINE bundleHeader #-}+bundleHeader = ByteString.Lazy.Char8.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]++>>> map align [512::Int .. 519]+[0,3,2,1,0,3,2,1]+-}+align :: (Num i, Bits i) => i -> i+{-# INLINE align #-}+align n = ((n + 3) .&. complement 3) - n++-- * ByteString++-- | Is machine little endian?+isLittleEndian :: Bool+isLittleEndian = GHC.ByteOrder.targetByteOrder == GHC.ByteOrder.LittleEndian++-- | Byte-swap byte string in four-byte segments.+byteStringSwap32BitWords :: ByteString.ByteString -> ByteString.ByteString+byteStringSwap32BitWords xs =+  ByteString.Internal.unsafePackLenBytes+    (ByteString.length xs `quot` 4 * 4)+    [ ByteString.Unsafe.unsafeIndex xs $ i * 4 + j+    | i <- [0 .. ByteString.length xs `quot` 4 - 1]+    , j <- [3, 2, 1, 0]+    ]++-- | If target is little-endian, swap bytes to be in network order, else identity.+byteString32BitNetworkOrder :: ByteString.ByteString -> ByteString.ByteString+byteString32BitNetworkOrder x = if isLittleEndian then byteStringSwap32BitWords x else x

+ Sound/Osc/Coding/Cast.hs view

@@ -0,0 +1,72 @@+-- | Bit-level type casts and byte layout string typecasts.+module Sound.Osc.Coding.Cast where++import Data.Char {- base -}+import Data.Word {- base -}++import Sound.Osc.Coding.Byte {- hosc3 -}+import Sound.Osc.Coding.Convert {- hosc -}++{- | The IEEE byte representation of a float.++>>> f32_w32 pi+1078530011++>>> f32_w32 (-7913907.5)+3404825447++>>> 23 ^ 7+3404825447+-}+f32_w32 :: Float -> Word32+f32_w32 = decode_word32 . encode_f32++{- | Inverse of 'f32_w32'.++>>> w32_f32 1078530011+3.1415927++>>> w32_f32 (23 ^ 7)+-7913907.5+-}+w32_f32 :: Word32 -> Float+w32_f32 = decode_f32 . encode_word32++{- | The IEEE byte representation of a double.+++>>> f64_w64 pi+4614256656552045848++>>> f64_w64 1.6822072834e-314+3404825447+-}+f64_w64 :: Double -> Word64+f64_w64 = decode_word64 . encode_f64++{- | Inverse of 'f64_w64'.++>>> w64_f64 4614256656552045848+3.141592653589793++>>> w64_f64 (23 ^ 7)+1.6822072834e-314+-}+w64_f64 :: Word64 -> Double+w64_f64 = decode_f64 . encode_word64++-- | Transform a haskell string into a C string (a null suffixed byte string).+str_cstr :: String -> [Word8]+str_cstr s = map (int_to_word8 . ord) s ++ [0]++-- | Inverse of 'str_cstr'.+cstr_str :: [Word8] -> String+cstr_str = map (chr . word8_to_int) . takeWhile (/= 0)++-- | Transform a haskell string to a pascal string (a length prefixed byte string).+str_pstr :: String -> [Word8]+str_pstr s = int_to_word8 (length s) : map (int_to_word8 . ord) s++-- | Inverse of 'str_pstr'.+pstr_str :: [Word8] -> String+pstr_str = map (chr . word8_to_int) . drop 1

+ Sound/Osc/Coding/Convert.hs view

@@ -0,0 +1,129 @@+-- | Type conversion.+module Sound.Osc.Coding.Convert where++import Data.Int {- base -}+import Data.Word {- base -}++-- * Int -> N++-- | Type specialised 'fromIntegral'+int_to_word8 :: Int -> Word8+int_to_word8 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_word32 :: Int -> Word32+int_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'.+int_to_word16 :: Int -> Word16+int_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int8 :: Int -> Int8+int_to_int8 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int16 :: Int -> Int16+int_to_int16 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int32 :: Int -> Int32+int_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int_to_int64 :: Int -> Int64+int_to_int64 = fromIntegral++-- * N -> Int++-- | Type specialised 'fromIntegral'+int8_to_int :: Int8 -> Int+int8_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int16_to_int :: Int16 -> Int+int16_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int32_to_int :: Int32 -> Int+int32_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int :: Int64 -> Int+int64_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word8_to_int :: Word8 -> Int+word8_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word16_to_int :: Word16 -> Int+word16_to_int = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int :: Word32 -> Int+word32_to_int = fromIntegral++-- * N -> N++-- | Type specialised 'fromIntegral'+word16_to_word32 :: Word16 -> Word32+word16_to_word32 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_word16 :: Word32 -> Word16+word32_to_word16 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int32 :: Word32 -> Int32+word32_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+word32_to_int64 :: Word32 -> Int64+word32_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+word64_to_int64 :: Word64 -> Int64+word64_to_int64 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_int32 :: Int64 -> Int32+int64_to_int32 = fromIntegral++-- | Type specialised 'fromIntegral'+int64_to_word32 :: Int64 -> Word32+int64_to_word32 = fromIntegral++-- * N -> Real++-- | Type specialised 'fromIntegral'+word64_to_double :: Word64 -> Double+word64_to_double = fromIntegral++-- * Enum++-- | Type-specialised 'toEnum' of 'fromIntegral'+word8_to_enum :: Enum e => Word8 -> e+word8_to_enum = toEnum . fromIntegral++-- | Type-specialised 'toEnum' of 'fromIntegral'+word16_to_enum :: Enum e => Word16 -> e+word16_to_enum = toEnum . fromIntegral++-- | Type-specialised 'fromIntegral' of 'fromEnum'.+enum_to_word8 :: Enum e => e -> Word8+enum_to_word8 = fromIntegral . fromEnum++-- | Type-specialised 'fromIntegral' of 'fromEnum'.+enum_to_word16 :: Enum e => e -> Word16+enum_to_word16 = fromIntegral . fromEnum++-- * Enum/Char++-- | Type-specialised 'word8_to_enum'.+word8_to_char :: Word8 -> Char+word8_to_char = word8_to_enum++-- | Type-specialised 'enum_to_word8'.+char_to_word8 :: Char -> Word8+char_to_word8 = enum_to_word8

+ Sound/Osc/Coding/Decode/Base.hs view

@@ -0,0 +1,122 @@+{- | Base-level decode function for Osc packets.+  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 {- hosc -}+import Sound.Osc.Coding.Convert {- hosc -}+import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc -}+import Sound.Osc.Time {- hosc -}++-- | The plain byte count of an Osc value.+size :: DatumType -> B.ByteString -> Int+size ty b =+  case ty of+    'i' -> 4 -- Int32+    'f' -> 4 -- Float+    'd' -> 8 -- Double+    't' -> 8 -- Time (NTP)+    'm' -> 4 -- MIDI+    's' ->+      int64_to_int+        ( 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 (aligned) of an Osc value.+storage :: DatumType -> 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 :: DatumType -> 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' -> AsciiString (decode_ascii (b_take (size 's' b) b))+    'b' -> Blob (b_take (size 'b' b) (B.drop 4 b))+    't' -> TimeStamp (ntpi_to_ntpr (decode_word64 b))+    'm' ->+      case B.unpack (B.take 4 b) of+        [b0, b1, b2, b3] -> midi (b0, b1, b2, b3)+        _ -> error "decode_datum: illegal midi data"+    _ -> 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 (int_to_int64 (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+      cmd = decode_datum 's' b+      m = storage 's' (b_drop n b)+  in case (cmd, decode_datum 's' (b_drop n b)) of+      (AsciiString cmd', AsciiString dsc) ->+        let arg = decode_datum_seq (descriptor_tags dsc) (b_drop (n + m) b)+        in Message (C.unpack cmd') arg+      _ -> error "decodeMessage"++-- | Decode a sequence of length prefixed (Int32) Osc messages.+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 -> BundleOf Message+decodeBundle b =+  let h = storage 's' b -- header (should be '#bundle')+      t = storage 't' (b_drop h b) -- time+  in case decode_datum 't' (b_drop h b) of+      TimeStamp timeStamp -> Bundle timeStamp (decode_message_seq (b_drop (h + t) b))+      _ -> error "decodeBundle"++{- | Decode an Osc 'Packet'.++>>> let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]+>>> decodePacket b == Packet_Message (Message "/g_free" [Int32 0])+True+-}+decodePacket :: B.ByteString -> PacketOf Message+decodePacket b =+  if bundleHeader `B.isPrefixOf` b+    then Packet_Bundle (decodeBundle b)+    else Packet_Message (decodeMessage b)++-- * Util++-- | 'B.take' with 'Int' count.+b_take :: Int -> B.ByteString -> B.ByteString+b_take = B.take . int_to_int64++-- | 'B.drop' with 'Int' count.+b_drop :: Int -> B.ByteString -> B.ByteString+b_drop = B.drop . int_to_int64

+ Sound/Osc/Coding/Decode/Binary.hs view

@@ -0,0 +1,152 @@+-- | Optimised decode function for Osc packets.+module Sound.Osc.Coding.Decode.Binary (+  get_packet,+  decodeMessage,+  decodeBundle,+  decodePacket,+  decodePacket_strict,+  decodeMessageOr,+  decodeBundleOr,+  decodePacketOr,+) where++import Control.Applicative {- base -}+import Control.Monad {- base -}+import Data.Word {- base -}++import qualified Data.Binary.Get as Binary {- binary -}++import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -}+import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -}+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 {- bytestring -}++import qualified Sound.Osc.Coding.Byte as Byte {- hosc -}+import qualified Sound.Osc.Coding.Convert as Convert {- hosc -}+import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc -}+import qualified Sound.Osc.Time as Time {- hosc -}++-- | Get an aligned Osc string.+get_string :: Binary.Get String+get_string = do+  s <- Binary.getLazyByteStringNul+  Binary.skip (Convert.int64_to_int (Byte.align (ByteString.Lazy.length s + 1)))+  return (ByteString.Lazy.Char8.unpack s)++-- | Get an aligned Osc string.+get_ascii :: Binary.Get Ascii+get_ascii = do+  s <- Binary.getLazyByteStringNul+  Binary.skip (Convert.int64_to_int (Byte.align (ByteString.Lazy.length s + 1)))+  return (ByteString.Char8.pack (ByteString.Lazy.Char8.unpack s))++-- | Get binary data prefixed by byte count.+get_bytes :: Word32 -> Binary.Get ByteString.Lazy.ByteString+get_bytes n = do+  b <- Binary.getLazyByteString (Convert.word32_to_int64 n)+  if n /= Convert.int64_to_word32 (ByteString.Lazy.length b)+    then fail "get_bytes: end of stream"+    else Binary.skip (Convert.word32_to_int (Byte.align n))+  return b++-- | Get an Osc datum.+get_datum :: DatumType -> Binary.Get Datum+get_datum ty =+  case ty of+    'i' -> fmap Int32 Binary.getInt32be+    'h' -> fmap Int64 Binary.getInt64be+    'f' -> fmap Float Binary.getFloatbe+    'd' -> fmap Double Binary.getDoublebe+    's' -> fmap AsciiString get_ascii+    'b' -> fmap Blob (get_bytes =<< Binary.getWord32be)+    't' -> fmap (TimeStamp . Time.ntpi_to_ntpr) Binary.getWord64be+    'm' -> fmap Midi (liftM4 MidiData Binary.getWord8 Binary.getWord8 Binary.getWord8 Binary.getWord8)+    _ -> fail ("get_datum: illegal type " ++ show ty)++-- | Get an Osc 'Message', fail if type descriptor is invalid.+get_message :: Binary.Get Message+get_message = do+  cmd <- get_string+  dsc <- get_ascii+  case ByteString.Char8.unpack dsc of+    ',' : tags -> do+      arg <- mapM get_datum tags+      return (Message cmd arg)+    e -> fail ("get_message: invalid type descriptor string: " ++ e)++-- | Get a sequence of Osc 'Message's, each one headed by its length.+get_message_seq :: Binary.Get [Message]+get_message_seq = do+  b <- Binary.isEmpty+  if b+    then return []+    else do+      p <- flip Binary.isolate get_message . Convert.word32_to_int =<< Binary.getWord32be+      ps <- get_message_seq+      return (p : ps)++-- | Get a bundle. Fail if bundle header is not found in packet.+get_bundle :: Binary.Get (BundleOf Message)+get_bundle = do+  h <- Binary.getByteString (ByteString.Char8.length Byte.bundleHeader_strict)+  when (h /= Byte.bundleHeader_strict) (fail "get_bundle: not a bundle")+  t <- fmap Time.ntpi_to_ntpr Binary.getWord64be+  fmap (Bundle t) get_message_seq++-- | Get an Osc 'Packet'.+get_packet :: Binary.Get (PacketOf Message)+get_packet = fmap Packet_Bundle get_bundle <|> fmap Packet_Message get_message++{-# INLINE decodeMessage #-}+{-# INLINE decodeBundle #-}+{-# INLINE decodePacket #-}+{-# INLINE decodePacket_strict #-}++{- | Decode an Osc 'Message' from a lazy ByteString.++>>> let b = ByteString.Lazy.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]+>>> decodeMessage b == Message "/g_free" [Int32 0]+True+-}+decodeMessage :: ByteString.Lazy.ByteString -> Message+decodeMessage = Binary.runGet get_message++-- | Decode an Osc 'Bundle' from a lazy ByteString.+decodeBundle :: ByteString.Lazy.ByteString -> BundleOf Message+decodeBundle = Binary.runGet get_bundle++-- | Run decoder and report any error.+runDecoder :: Binary.Get t -> ByteString.Lazy.Char8.ByteString -> Either String t+runDecoder f p =+  case Binary.runGetOrFail f p of+    Left (_, _, err) -> Left err+    Right (_, _, decoded) -> Right decoded++{- | Decode an Osc packet from a lazy ByteString.++>>> let b = ByteString.Lazy.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]+>>> decodePacket b == Packet_Message (Message "/g_free" [Int32 0])+True+-}+decodePacket :: ByteString.Lazy.ByteString -> PacketOf Message+decodePacket = Binary.runGet get_packet++-- | Decode an Osc packet from a strict Char8 ByteString.+decodePacket_strict :: ByteString.Char8.ByteString -> PacketOf Message+decodePacket_strict = Binary.runGet get_packet . ByteString.Lazy.fromChunks . (: [])++{- | Either decode Osc message or return an error message.+Prevents application halt for non-valid message/bundle/packet arrives.++>>> let b = ByteString.Lazy.pack [1,2,3,2,1]+>>> decodePacketOr b+Left "not enough bytes"+-}+decodeMessageOr :: ByteString.Lazy.ByteString -> Either String Message+decodeMessageOr = runDecoder get_message++decodeBundleOr :: ByteString.Lazy.ByteString -> Either String Bundle+decodeBundleOr = runDecoder get_bundle++decodePacketOr :: ByteString.Lazy.ByteString -> Either String Packet+decodePacketOr = runDecoder get_packet

+ Sound/Osc/Coding/Encode/Base.hs view

@@ -0,0 +1,117 @@+{- | Base-level encode function for Osc packets (slow).+  For ordinary use see 'Sound.Osc.Coding.Encode.Builder'.+-}+module Sound.Osc.Coding.Encode.Base 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 {- hosc -}+import Sound.Osc.Coding.Convert {- hosc -}+import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc -}+import Sound.Osc.Time {- hosc -}++-- | Align byte string, if required.+extend :: Word8 -> B.ByteString -> B.ByteString+extend p s = B.append s (B.replicate (align (B.length s)) p)++{- | Encode Osc 'Datum'.++MidiData: Bytes from MSB to LSB are: port id, status byte, data1, data2.++>>> encode_datum (blob [1, 2, 3, 4]) == B.pack [0, 0, 0, 4, 1, 2, 3, 4]+True++>>> encode_datum (Float 1) == B.pack [63, 128, 0, 0]+True++>>> encode_datum (Float 2) == B.pack [64, 0, 0, 0]+True++>>> encode_datum (Float 3) == B.pack [64, 64, 0, 0]+True++>>> encode_datum (Float 4) == B.pack [64, 128, 0, 0]+True++>>> encode_datum (Float 5) == B.pack [64, 160, 0, 0]+True++>>> encode_datum (Int32 65536) == B.pack [0, 1, 0, 0]+True++>>> encode_datum (Int32 (-65536)) == B.pack [255, 255, 0, 0]+True+-}+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_word64 $ ntpr_to_ntpi t+    AsciiString s -> extend 0 (B.snoc (encode_ascii s) 0)+    Midi (MidiData b0 b1 b2 b3) -> B.pack [b0, b1, b2, b3]+    Blob b ->+      let n = encode (int64_to_int32 (B.length b))+      in B.append n (extend 0 b)++{- | Encode Osc 'Message'.++>>> blob_unpack (encodeMessage (Message "/x" []))+[47,120,0,0,44,0,0,0]++>>> blob_unpack (encodeMessage (Message "/y" [float 3.141]))+[47,121,0,0,44,102,0,0,64,73,6,37]++>>> let m = Message "/n_set" [int32 (-1), string "freq", float 440, string "amp", float 0.1]+>>> let e = blob_unpack (encodeMessage m)+>>> length e+40++>>> take 20 e+[47,110,95,115,101,116,0,0,44,105,115,102,115,102,0,0,255,255,255,255]+-}+encodeMessage :: Message -> B.ByteString+encodeMessage (Message c l) =+  B.concat+    [ encode_datum (AsciiString (C.pack c))+    , encode_datum (AsciiString (descriptor l))+    , B.concat (map encode_datum l)+    ]++-- | Encode Osc 'Message' as an Osc blob.+encode_message_blob :: Message -> Datum+encode_message_blob = Blob . encodeMessage++{- | Encode Osc 'Bundle'.++>>> blob_unpack (encodeBundle (Bundle immediately [Message "/x" []]))+[35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,1,0,0,0,8,47,120,0,0,44,0,0,0]++>>> let m = Message "/n_set" [int32 (-1), string "freq", float 440, string "amp", float 0.1]+>>> let b = Bundle 0.0 [m]+>>> let e = blob_unpack (encodeBundle b)+>>> length e+60++>> take 20 e+[35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,0,0,0,0,40]+-}+encodeBundle :: BundleOf Message -> B.ByteString+encodeBundle (Bundle t m) =+  B.concat+    [ bundleHeader+    , encode_word64 (ntpr_to_ntpi t)+    , B.concat (map (encode_datum . encode_message_blob) m)+    ]++-- | Encode Osc 'Packet'.+encodePacket :: PacketOf Message -> B.ByteString+encodePacket o =+  case o of+    Packet_Message m -> encodeMessage m+    Packet_Bundle b -> encodeBundle b

+ Sound/Osc/Coding/Encode/Builder.hs view

@@ -0,0 +1,115 @@+-- | Optimised encode function for Osc packets.+module Sound.Osc.Coding.Encode.Builder (+  build_packet,+  encodeMessage,+  encodeBundle,+  encodePacket,+  encodePacket_strict,+) where++import Data.Word {- base -}++import qualified Blaze.ByteString.Builder as B {- bytestring -}+import qualified Blaze.ByteString.Builder.Char8 as B {- bytestring -}+import qualified Data.ByteString as S {- bytestring -}+import qualified Data.ByteString.Lazy as L {- bytestring -}++import qualified Sound.Osc.Coding.Byte as Byte {- hosc -}+import qualified Sound.Osc.Coding.Cast as Cast {- hosc -}+import qualified Sound.Osc.Coding.Convert as Convert {- hosc -}+import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc -}+import Sound.Osc.Time {- hosc -}++-- | Generate a list of zero bytes for padding.+padding :: Int -> [Word8]+padding n = replicate n 0++-- | Nul byte (0) and then zero padding.+nul_and_padding :: Int -> B.Builder+nul_and_padding n = B.fromWord8s (0 : padding (Byte.align n))++-- Encode a string with zero padding.+build_ascii :: Ascii -> B.Builder+build_ascii s = B.fromByteString s <> nul_and_padding (S.length s + 1)++-- Encode a string with zero padding.+build_string :: String -> B.Builder+build_string s = B.fromString s <> nul_and_padding (length s + 1)++-- Encode a byte string with prepended length and zero padding.+build_bytes :: L.ByteString -> B.Builder+build_bytes s =+  B.fromInt32be (Convert.int64_to_int32 (L.length s))+    <> B.fromLazyByteString s+    <> B.fromWord8s (padding (Convert.int64_to_int (Byte.align (L.length s))))++-- Encode an Osc datum.+build_datum :: Datum -> B.Builder+build_datum d =+  case d of+    Int32 i -> B.fromInt32be i+    Int64 i -> B.fromInt64be i+    Float n -> B.fromWord32be (Cast.f32_w32 n)+    Double n -> B.fromWord64be (Cast.f64_w64 n)+    TimeStamp t -> B.fromWord64be (ntpr_to_ntpi t)+    AsciiString s -> build_ascii s+    Midi (MidiData 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 :: Ntp64 -> [Message] -> B.Builder+build_bundle_ntpi t l =+  mconcat+    [ B.fromLazyByteString Byte.bundleHeader+    , B.fromWord64be t+    , mconcat (map (build_bytes . B.toLazyByteString . build_message) l)+    ]++-- | Builder for an Osc 'Packet'.+build_packet :: PacketOf Message -> 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 encodePacket #-}+{-# INLINE encodeMessage #-}+{-# INLINE encodeBundle #-}+{-# INLINE encodePacket_strict #-}++-- | Encode an Osc 'Packet'.+encodePacket :: PacketOf Message -> L.ByteString+encodePacket = B.toLazyByteString . build_packet++{- | Encode an Osc 'Message', ie. 'encodePacket' of 'Packet_Message'.++>>> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]+>>> encodeMessage (Message "/g_free" [Int32 0]) == L.pack m+True+-}+encodeMessage :: Message -> L.ByteString+encodeMessage = encodePacket . Packet_Message++{- | Encode an Osc 'Bundle', ie. 'encodePacket' of 'Packet_Bundle'.++>>> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0]+>>> let b = [35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,1,0,0,0,16] ++ m+>>> encodeBundle (Bundle immediately [Message "/g_free" [Int32 0]]) == L.pack b+True+-}+encodeBundle :: BundleOf Message -> L.ByteString+encodeBundle = encodePacket . Packet_Bundle++-- | Encode an Osc 'Packet' to a strict 'S.ByteString'.+encodePacket_strict :: PacketOf Message -> S.ByteString+encodePacket_strict = B.toByteString . build_packet

+ Sound/Osc/Core.hs view

@@ -0,0 +1,21 @@+{- | Composite of non-transport related modules.++Provides the 'Datum', 'Message', 'Time', 'Bundle' and 'Packet' types+and the coding functions 'encodePacket' and 'decodePacket'.++>>> let o = bundle immediately [message "/g_free" [Int32 0]]+>>> let e = encodeBundle o+>>> decodePacket e == Packet_Bundle o+True+-}+module Sound.Osc.Core (module M) where++import Sound.Osc.Coding.Decode.Binary as M+import Sound.Osc.Coding.Encode.Builder as M+import Sound.Osc.Datum as M+import Sound.Osc.Packet as M+import Sound.Osc.Time as M+import Sound.Osc.Time.System as M+import Sound.Osc.Time.Thread as M+import Sound.Osc.Time.Thread.MonadIO as M+import Sound.Osc.Wait as M

+ Sound/Osc/Datum.hs view

@@ -0,0 +1,264 @@+-- | Osc data types.+module Sound.Osc.Datum where++import Data.Int {- base -}+import Data.Maybe {- base -}+import Data.Word {- base -}++import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -}+import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -}++-- * Datum++-- | Type enumerating Datum categories.+type DatumType = Char++-- | Type for Ascii strings (strict Char8 ByteString)+type Ascii = ByteString.Char8.ByteString++-- | Type-specialised pack.+ascii :: String -> Ascii+ascii = ByteString.Char8.pack++-- | Type-specialised unpack.+ascii_to_string :: Ascii -> String+ascii_to_string = ByteString.Char8.unpack++-- | Type for 'Word8' arrays, these are stored with an 'Int32' length prefix.+type Blob = ByteString.Lazy.ByteString++-- | Type-specialised pack.+blob_pack :: [Word8] -> Blob+blob_pack = ByteString.Lazy.pack++-- | Type-specialised pack.+blob_pack_int :: [Int] -> Blob+blob_pack_int = ByteString.Lazy.pack . map fromIntegral++-- | Type-specialised unpack.+blob_unpack :: Blob -> [Word8]+blob_unpack = ByteString.Lazy.unpack++-- | Type-specialised unpack.+blob_unpack_int :: Blob -> [Int]+blob_unpack_int = map fromIntegral . blob_unpack++-- | Four-byte midi message: port-id, status-byte, data, data.+data MidiData = MidiData !Word8 !Word8 !Word8 !Word8+  deriving (Ord, Eq, Show, Read)++midi_pack :: [Word8] -> MidiData+midi_pack w =+  case w of+    [m1, m2, m3, m4] -> MidiData m1 m2 m3 m4+    _ -> error "midi_pack?"++-- | Type-specialised pack.+midi_pack_int :: [Int] -> MidiData+midi_pack_int = midi_pack . map fromIntegral++-- | Type-specialised unpack.+midi_unpack_int :: MidiData -> [Int]+midi_unpack_int (MidiData m1 m2 m3 m4) = map fromIntegral [m1, m2, m3, m4]++{- | A real-valued time stamp.+For Osc proper this is an Ntp64 time in real-valued (fractional) form.+For SuperCollider Nrt programs this is elapsed time since the start of the score.+This is the primary form of timestamp used by hosc.+-}+type Time = Double++-- | The basic elements of Osc messages.+data Datum+  = Int32 {d_int32 :: !Int32}+  | Int64 {d_int64 :: !Int64}+  | Float {d_float :: !Float}+  | Double {d_double :: !Double}+  | AsciiString {d_ascii_string :: !Ascii}+  | Blob {d_blob :: !Blob}+  | TimeStamp {d_timestamp :: !Time} -- ie. real valued Ntp+  | Midi {d_midi :: !MidiData}+  deriving (Ord, Eq, Read, Show)++-- * Datum types++-- | List of required data types (tag, name).+osc_types_required :: [(DatumType, String)]+osc_types_required =+  [ ('i', "Int32")+  , ('f', "Float")+  , ('s', "String") -- Ascii+  , ('b', "Blob")+  ]++-- | List of optional data types (tag,name).+osc_types_optional :: [(DatumType, String)]+osc_types_optional =+  [ ('h', "Int64")+  , ('t', "TimeStamp")+  , ('d', "Double")+  , -- ,('S',"Symbol")+    -- ,('c',"Character")+    -- ,('r',"RGBA")+    ('m', "Midi")+    -- ,('T',"True")+    -- ,('F',"False")+    -- ,('N',"Nil")+    -- ,('I',"Infinitum")+    -- ,('[',"Array_Begin")+    -- ,(']',"Array_End")+  ]++-- | List of all data types (tag,name).+osc_types :: [(DatumType, String)]+osc_types = osc_types_required ++ osc_types_optional++-- | Lookup name of type.+osc_type_name :: DatumType -> Maybe String+osc_type_name c = lookup c osc_types++-- | Erroring variant.+osc_type_name_err :: DatumType -> String+osc_type_name_err = fromMaybe (error "osc_type_name") . osc_type_name++-- | Single character identifier of an Osc datum.+datum_tag :: Datum -> DatumType+datum_tag d =+  case d of+    Int32 _ -> 'i'+    Int64 _ -> 'h'+    Float _ -> 'f'+    Double _ -> 'd'+    AsciiString _ -> 's'+    Blob _ -> 'b'+    TimeStamp _ -> 't'+    Midi _ -> 'm'++-- | Type and name of 'Datum'.+datum_type_name :: Datum -> (DatumType, String)+datum_type_name d = let c = datum_tag d in (c, osc_type_name_err c)++-- * Generalised element access++{- | 'Datum' as 'Integral' if Int32 or Int64.++>>> let d = [Int32 5,Int64 5,Float 5.5,Double 5.5]+>>> map datum_integral d == [Just (5::Int),Just 5,Nothing,Nothing]+True+-}+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 Int32, Int64, Float, Double or TimeStamp.++>>> let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5]+>>> mapMaybe datum_floating d == replicate 5 (5::Double)+True+-}+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++-- * Constructors++{- | Type generalised 'Int32'.++>>> int32 (1::Int32) == int32 (1::Integer)+True++>>> d_int32 (int32 (maxBound::Int32)) == maxBound+True++>>> int32 (((2::Int) ^ (64::Int))::Int) == Int32 0+True+-}+int32 :: Integral n => n -> Datum+int32 = Int32 . fromIntegral++{- | Type generalised Int64.++>>> int64 (1::Int32) == int64 (1::Integer)+True++>>> d_int64 (int64 (maxBound::Int64)) == maxBound+True+-}+int64 :: Integral n => n -> Datum+int64 = Int64 . fromIntegral++{- | Type generalised Float.++>>> float (1::Int) == float (1::Double)+True++>>> floatRange (undefined::Float)+(-125,128)++>>> isInfinite (d_float (float (encodeFloat 1 256 :: Double)))+True+-}+float :: Real n => n -> Datum+float = Float . realToFrac++{- | Type generalised Double.++>>> double (1::Int) == double (1::Double)+True++>>> double (encodeFloat 1 256 :: Double) == Double 1.157920892373162e77+True+-}+double :: Real n => n -> Datum+double = Double . realToFrac++{- | 'AsciiString' of pack.++>>> string "string" == AsciiString (ByteString.Char8.pack "string")+True+-}+string :: String -> Datum+string = AsciiString . ascii++{- | Four-tuple variant of 'Midi' '.' 'MidiData'.++>>> midi (0,0,0,0) == Midi (MidiData 0 0 0 0)+True+-}+midi :: (Word8, Word8, Word8, Word8) -> Datum+midi (p, q, r, s) = Midi (MidiData p q r s)++-- | 'Blob' of 'blob_pack'.+blob :: [Word8] -> Datum+blob = Blob . blob_pack++-- * Descriptor++{- | Message argument types are given by a signature.++>>> signatureFor [Int32 1,Float 1,string "1"]+",ifs"+-}+signatureFor :: [Datum] -> String+signatureFor = (',' :) . map datum_tag++{- | The descriptor is an Ascii encoded signature.++>>> descriptor [Int32 1,Float 1,string "1"] == ascii ",ifs"+True+-}+descriptor :: [Datum] -> Ascii+descriptor = ascii . signatureFor++-- | Descriptor tags are @comma@ prefixed.+descriptor_tags :: Ascii -> Ascii+descriptor_tags = ByteString.Char8.drop 1

+ Sound/Osc/Fd.hs view

@@ -0,0 +1,6 @@+-- | Composite of "Sound.Osc.Core" and "Sound.Osc.Transport.Fd".+module Sound.Osc.Fd (module M) where++import Sound.Osc.Core as M+import Sound.Osc.Transport.Fd as M+import Sound.Osc.Transport.Fd.Socket as M

+ Sound/Osc/Packet.hs view

@@ -0,0 +1,142 @@+-- | Data types for Osc messages, bundles and packets.+module Sound.Osc.Packet where++import Sound.Osc.Datum {- hosc -}++-- * Message++{- | Osc address pattern.  This is strictly an Ascii value, however it+  is very common to pattern match on addresses and matching on+  Data.ByteString.Char8 requires @OverloadedStrings@.+-}+type Address_Pattern = String++-- | An Osc message, an 'Address_Pattern' and a sequence of 'Datum'.+data Message = Message+  { messageAddress :: !Address_Pattern+  , messageDatum :: ![Datum]+  }+  deriving (Ord, 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"++messageSignature :: Message -> String+messageSignature = signatureFor . messageDatum++messageDescriptor :: Message -> Ascii+messageDescriptor = descriptor . messageDatum++-- * Bundle++{- | An Osc bundle, a 'Time' and a sequence of 'Message's.+The type parameter specifies the element type.+Ordinarily this is Message, which does not allow recursion.+-}+data BundleOf t = Bundle+  { bundleTime :: !Time+  , bundleMessages :: ![t]+  }+  deriving (Eq, Read, Show)++type Bundle = BundleOf Message++-- | Osc 'Bundle's can be ordered (time ascending).+instance Eq t => Ord (BundleOf t) where+  compare (Bundle a _) (Bundle b _) = compare a b++-- | 'Bundle' constructor. It is an 'error' if the 'Message' list is empty.+bundle :: Time -> [t] -> BundleOf t+bundle t xs =+  case xs of+    [] -> error "bundle: empty?"+    _ -> Bundle t xs++-- * Packet++-- | An Osc 'Packet' is either a 'Message' or a 'Bundle t'.+data PacketOf t+  = Packet_Message {packetMessage :: !Message}+  | Packet_Bundle {packetBundle :: !(BundleOf t)}+  deriving (Eq, Read, Show)++type Packet = PacketOf Message++-- | 'Packet_Bundle' of 'bundle'.+p_bundle :: Time -> [t] -> PacketOf t+p_bundle t = Packet_Bundle . bundle t++-- | 'Packet_Message' of 'message'.+p_message :: Address_Pattern -> [Datum] -> PacketOf t+p_message a = Packet_Message . message a++{- | Constant indicating a bundle to be executed immediately.+It has the Ntp64 representation of @1@.++>>> immediately == (1 / (2 ^ 32))+True+-}+immediately :: Time+immediately = 1 / 2 ^ (32 :: Int)++-- | The 'Time' of 'Packet', if the 'Packet' is a 'Message' this is 'immediately'.+packetTime :: PacketOf t -> Time+packetTime = at_packet (const immediately) bundleTime++-- | Retrieve the set of 'Message's from a 'Packet'.+packetMessages :: PacketOf Message -> [Message]+packetMessages = at_packet return bundleMessages++-- | If 'Packet' is a 'Message' add 'immediately' timestamp, else 'id'.+packet_to_bundle :: PacketOf Message -> BundleOf Message+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 :: PacketOf Message -> 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 :: PacketOf t -> Bool+packet_is_immediate = (== immediately) . packetTime++-- | Variant of 'either' for 'Packet'.+at_packet :: (Message -> a) -> (BundleOf t -> a) -> PacketOf t -> 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 Message' have the specified+'Address_Pattern'.+-}+bundle_has_address :: Address_Pattern -> BundleOf Message -> 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 -> PacketOf Message -> Bool+packet_has_address x =+  at_packet+    (message_has_address x)+    (bundle_has_address x)

+ Sound/Osc/Text.hs view

@@ -0,0 +1,279 @@+-- | A simple and unambigous text encoding for Osc.+module Sound.Osc.Text where++import Control.Monad {- base -}+import Data.Char {- base -}+import Numeric {- base -}+import Text.Printf {- base -}++import qualified Safe {- safe -}++import qualified Text.ParserCombinators.Parsec as P {- parsec -}++import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc3 -}+import qualified Sound.Osc.Time as Time {- hosc3 -}++-- | Precision value for floating point numbers.+type FpPrecision = Maybe Int++{- | Variant of 'showFFloat' that deletes trailing zeros.++>>> map (showFloatWithPrecision (Just 4)) [1, 2.0, pi]+["1.0","2.0","3.1416"]+-}+showFloatWithPrecision :: RealFloat n => FpPrecision -> n -> String+showFloatWithPrecision p n =+  let s = showFFloat p n ""+      s' = dropWhile (== '0') (reverse s)+  in case s' of+      '.' : _ -> reverse ('0' : s')+      _ -> reverse s'++{- | Hex encoded byte sequence.++>>> showBytes [0, 15, 16, 144, 255]+"000f1090ff"+-}+showBytes :: [Int] -> String+showBytes = concatMap (printf "%02x")++{- | Escape whites space (space, tab, newline) and the escape character (backslash).++>>> map escapeString ["str", "str ", "st r", "s\tr", "s\\tr", "\nstr"]+["str","str\\ ","st\\ r","s\\\tr","s\\\\tr","\\\nstr"]+-}+escapeString :: String -> String+escapeString txt =+  case txt of+    [] -> []+    c : txt' -> if c `elem` "\\\t\n " then '\\' : c : escapeString txt' else c : escapeString txt'++{- | Printer for Datum.++>>> let aDatumSeq = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60),blob [12,16], TimeStamp 100.0]+>>> map (showDatum (Just 5)) aDatumSeq+["1","1.2","str","00904060","0c10","429496729600"]+-}+showDatum :: FpPrecision -> Datum -> String+showDatum p d =+  case d of+    Int32 n -> show n+    Int64 n -> show n+    Float n -> showFloatWithPrecision p n+    Double n -> showFloatWithPrecision p n+    AsciiString s -> escapeString (ascii_to_string s)+    Blob s -> showBytes (blob_unpack_int s)+    TimeStamp t -> show (Time.ntpr_to_ntpi t)+    Midi m -> showBytes (midi_unpack_int m)++{- | Printer for Message.++>>> let aMessage = Message "/addr" [Int32 1, Int64 2, Float 3, Double 4, string "five", blob [6, 7], midi (8, 9, 10, 11)]+>>> showMessage (Just 4) aMessage+"/addr ,ihfdsbm 1 2 3.0 4.0 five 0607 08090a0b"++>>> let aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3], Message "/s_new" [string "sine", Int32 (-1), Int32 1, Int32 1]]+>>> map (showMessage (Just 4)) aMessageSeq+["/c_set ,if 1 2.3","/s_new ,siii sine -1 1 1"]+-}+showMessage :: FpPrecision -> Message -> String+showMessage precision aMessage =+  unwords+    [ messageAddress aMessage+    , messageSignature aMessage+    , unwords (map (showDatum precision) (messageDatum aMessage))+    ]++{- | Printer for Bundle++>>> let aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]+>>> showBundle (Just 4) aBundle+"#bundle 4294967296 2 /c_set ,ifhd 1 2.3 4 5.6 /memset ,sb addr 0708"+-}+showBundle :: FpPrecision -> BundleOf Message -> String+showBundle precision aBundle =+  let messages = bundleMessages aBundle+  in unwords+      [ "#bundle"+      , show (Time.ntpr_to_ntpi (bundleTime aBundle))+      , show (length messages)+      , unwords (map (showMessage precision) messages)+      ]++-- | Printer for Packet.+showPacket :: FpPrecision -> PacketOf Message -> String+showPacket precision = at_packet (showMessage precision) (showBundle precision)++-- * Parser++-- | A character parser with no user state.+type P a = P.GenParser Char () a++-- | Run p then q, returning result of p.+(>>~) :: Monad m => m t -> m u -> m t+p >>~ q = p >>= \x -> q >> return x++-- | /p/ as lexeme, i.e. consuming any trailing white space.+lexemeP :: P t -> P t+lexemeP p = p >>~ P.many P.space++-- | Any non-space character.  Allow escaped space.+stringCharP :: P Char+stringCharP = (P.char '\\' >> P.space) P.<|> P.satisfy (\c -> not (isSpace c))++-- | Parser for string.+stringP :: P String+stringP = lexemeP (P.many1 stringCharP)++-- | Parser for Osc address.+oscAddressP :: P String+oscAddressP = do+  forwardSlash <- P.char '/'+  address <- stringP+  return (forwardSlash : address)++-- | Parser for Osc signature.+oscSignatureP :: P String+oscSignatureP =+  lexemeP+    ( do+        comma <- P.char ','+        types <- P.many1 (P.oneOf "ifsbhtdm") -- 1.0 = ifsb 2.0 = htdm+        return (comma : types)+    )++-- | Parser for decimal digit.+digitP :: P Char+digitP = P.oneOf "0123456789"++allowNegativeP :: Num n => P n -> P n+allowNegativeP p = do+  let optionMaybe x = P.option Nothing (liftM Just x) -- hugs...+  maybeNegative <- optionMaybe (P.char '-')+  number <- p+  return (maybe number (const (negate number)) maybeNegative)++-- | Parser for non-negative integer.+nonNegativeIntegerP :: (Integral n, Read n) => P n+nonNegativeIntegerP = lexemeP (fmap read (P.many1 digitP))++-- | Parser for integer.+integerP :: (Integral n, Read n) => P n+integerP = allowNegativeP nonNegativeIntegerP++-- | Parser for non-negative float.+nonNegativeFloatP :: (Fractional n, Read n) => P n+nonNegativeFloatP =+  lexemeP+    ( do+        integerPart <- P.many1 digitP+        _ <- P.char '.'+        fractionalPart <- P.many1 digitP+        return (read (concat [integerPart, ".", fractionalPart]))+    )++-- | Parser for non-negative float.+floatP :: (Fractional n, Read n) => P n+floatP = allowNegativeP nonNegativeFloatP++-- | Parser for hexadecimal digit.+hexdigitP :: P Char+hexdigitP = P.oneOf "0123456789abcdef"++-- | Byte parser.+byteP :: (Integral n, Read n) => P n+byteP = do+  c1 <- hexdigitP+  c2 <- hexdigitP+  case readHex [c1, c2] of+    [(r, "")] -> return r+    _ -> error "byteP?"++-- | Byte sequence parser.+byteSeqP :: (Integral n, Read n) => P [n]+byteSeqP = lexemeP (P.many1 byteP)++-- | Datum parser.+datumP :: Char -> P Datum+datumP typeChar = do+  case typeChar of+    'i' -> fmap Int32 integerP+    'f' -> fmap Float floatP+    's' -> fmap string stringP+    'b' -> fmap blob byteSeqP+    'h' -> fmap Int64 integerP+    'd' -> fmap Double floatP+    'm' -> fmap (Midi . midi_pack) (replicateM 4 byteP)+    't' -> fmap (TimeStamp . Time.ntpi_to_ntpr) integerP+    _ -> error "datumP: type?"++-- | Message parser.+messageP :: P Message+messageP = do+  address <- oscAddressP+  typeSignature <- oscSignatureP+  datum <- mapM datumP (Safe.tailNote "messageP" typeSignature)+  return (Message address datum)++-- | Bundle tag parser.+bundleTagP :: P String+bundleTagP = lexemeP (P.string "#bundle")++-- | Bundle parser.+bundleP :: P (BundleOf Message)+bundleP = do+  _ <- bundleTagP+  timestamp <- fmap Time.ntpi_to_ntpr integerP+  messageCount <- integerP+  messages <- replicateM messageCount messageP+  return (Bundle timestamp messages)++-- | Packet parser.+packetP :: P (PacketOf Message)+packetP = (fmap Packet_Bundle bundleP) P.<|> (fmap Packet_Message messageP)++-- | Run parser.+runP :: P t -> String -> t+runP p txt =+  case P.parse p "" txt of+    Left err -> error (show err)+    Right r -> r++{- | Run datum parser.++>>> parseDatum 'i' "-1" == Int32 (-1)+True++>>> parseDatum 'f' "-2.3" == Float (-2.3)+True+-}+parseDatum :: Char -> String -> Datum+parseDatum typ = runP (datumP typ)++{- | Run message parser.++>>> let aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]+>>> map (parseMessage . showMessage (Just 4)) aMessageSeq  == aMessageSeq+True+-}+parseMessage :: String -> Message+parseMessage = runP messageP++{- | Run bundle parser.++>>> let aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]+>>> parseBundle (showBundle (Just 4) aBundle) == aBundle+True+-}+parseBundle :: String -> BundleOf Message+parseBundle = runP bundleP++{- | Run packet parser.++>>> let aPacket = Packet_Bundle (Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]])+>>> parsePacket (showPacket (Just 4) aPacket) == aPacket+True+-}+parsePacket :: String -> PacketOf Message+parsePacket = runP packetP

+ Sound/Osc/Time.hs view

@@ -0,0 +1,116 @@+{- | Osc related timing functions.+  Osc timestamps are 64-bit @Ntp@ values, <http://ntp.org/>.+-}+module Sound.Osc.Time where++import Data.Word {- base -}++import qualified Data.Time as Time {- time -}+import qualified Data.Time.Clock as Clock {- time -}+import qualified Data.Time.Clock.POSIX as Clock.Posix {- time -}++import Sound.Osc.Coding.Convert {- hosc -}++-- * Temporal types++{- | Type for binary (integeral) representation of a 64-bit Ntp timestamp (ie. ntpi).+  The Ntp epoch is January 1, 1900.+  Ntp v4 also includes a 128-bit format, which is not used by Osc.+-}+type Ntp64 = Word64++-- | @Ntp@ time in real-valued (fractional) form.+type NtpReal = Double++{- | @Unix/Posix@ time in real-valued (fractional) form.+  The Unix/Posix epoch is January 1, 1970.+-}+type PosixReal = Double++-- * Time conversion++{- | Convert an NtpReal timestamp to an Ntp64 timestamp.++>>> ntpr_to_ntpi 0+0++> fmap ntpr_to_ntpi time+-}+ntpr_to_ntpi :: NtpReal -> Ntp64+ntpr_to_ntpi t = round (t * (2 ^ (32 :: Int)))++{- | Convert an 'Ntp64' timestamp to a real-valued Ntp timestamp.++>>> ntpi_to_ntpr 0+0.0+-}+ntpi_to_ntpr :: Ntp64 -> NtpReal+ntpi_to_ntpr t = word64_to_double t / 2 ^ (32 :: Int)++{- | Difference (in seconds) between /Ntp/ and /Posix/ epochs.++>>> ntp_posix_epoch_diff / (24 * 60 * 60)+25567.0++>>> 25567 `div` 365+70+-}+ntp_posix_epoch_diff :: Num n => n+ntp_posix_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60++-- | Convert a PosixReal timestamp to an Ntp64 timestamp.+posix_to_ntpi :: PosixReal -> Ntp64+posix_to_ntpi t = ntpr_to_ntpi (t + ntp_posix_epoch_diff)++-- | Convert @Unix/Posix@ to @Ntp@.+posix_to_ntpr :: Num n => n -> n+posix_to_ntpr = (+) ntp_posix_epoch_diff++-- | Convert @Ntp@ to @Unix/Posix@.+ntpr_to_posix :: Num n => n -> n+ntpr_to_posix = (+) (negate ntp_posix_epoch_diff)++-- | Convert 'Ntp64' to @Unix/Posix@.+ntpi_to_posix :: Ntp64 -> PosixReal+ntpi_to_posix = ntpr_to_posix . ntpi_to_ntpr++-- | Convert 'Time' to 'Clock.Posix.POSIXTime'.+ntpr_to_posixtime :: NtpReal -> Clock.Posix.POSIXTime+ntpr_to_posixtime = realToFrac . ntpr_to_posix++-- | Convert 'Clock.Posix.POSIXTime' to 'Time'.+posixtime_to_ntpr :: Clock.Posix.POSIXTime -> NtpReal+posixtime_to_ntpr = posix_to_ntpr . realToFrac++-- * 'Data.Time' inter-operation.++-- | The time at 1970-01-01:00:00:00 which is the Unix/Posix epoch.+posix_epoch :: Time.UTCTime+posix_epoch =+  let d = Time.fromGregorian 1970 1 1+      s = fromInteger 0 -- Time.secondsToDiffTime+  in Time.UTCTime d s++-- | Convert 'Time.UTCTime' to @Unix/Posix@.+utc_to_posix :: Fractional n => Time.UTCTime -> n+utc_to_posix t = realToFrac (Time.diffUTCTime t posix_epoch)++-- * Clock operations++-- | utc_to_posix of Clock.getCurrentTime.+getCurrentTimeAsPosix :: IO PosixReal+getCurrentTimeAsPosix = fmap utc_to_posix Clock.getCurrentTime++{- | realToFrac of Clock.Posix.getPOSIXTime++> get_ct = getCurrentTimeAsPosix+> get_pt = getPosixTimeAsPosix+> (ct,pt) <- get_ct >>= \t0 -> get_pt >>= \t1 -> return (t0,t1)+> print (pt - ct,pt - ct < 1e-5)+-}+getPosixTimeAsPosix :: IO PosixReal+getPosixTimeAsPosix = fmap realToFrac Clock.Posix.getPOSIXTime++-- | Read current real-valued @Ntp@ timestamp.+currentTime :: IO NtpReal+currentTime = fmap posixtime_to_ntpr Clock.Posix.getPOSIXTime

+ Sound/Osc/Time/System.hs view

@@ -0,0 +1,25 @@+-- | System time+module Sound.Osc.Time.System where++import Data.Int {- base -}+import Data.Word {- base -}++import qualified Data.Time.Clock.System as Clock.System {- time >= 1.8 -}++import qualified Sound.Osc.Time as Time {- hosc -}++{- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored.+  getSystemTime is typically much faster than getCurrentTime, however it is not available in Hugs.+-}+getSystemTimeAsNtpReal :: IO Time.NtpReal+getSystemTimeAsNtpReal = do+  tm <- Clock.System.getSystemTime+  return (fromIntegral (Clock.System.systemSeconds tm) + (fromIntegral (Clock.System.systemNanoseconds tm) * 1.0e-9))++-- | System time with fractional part in microseconds (us) instead of nanoseconds (ns).+getSystemTimeInMicroseconds :: IO (Int64, Word32)+getSystemTimeInMicroseconds = do+  tm <- Clock.System.getSystemTime+  let sec = Clock.System.systemSeconds tm+      usec = Clock.System.systemNanoseconds tm `div` 1000+  return (sec, usec)

+ Sound/Osc/Time/Thread.hs view

@@ -0,0 +1,39 @@+-- | Thread operations.+module Sound.Osc.Time.Thread where++import Control.Concurrent {- base -}+import Control.Monad {- base -}++import qualified Sound.Osc.Time as Time {- hosc -}++{- | 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'.+pauseThreadFor :: RealFrac n => n -> IO ()+pauseThreadFor n = when (n > 0) (threadDelay (floor (n * 1e6)))++-- | Pause current thread until the given time, see 'pauseThreadLimit'.+pauseThreadUntilTime :: RealFrac n => n -> IO ()+pauseThreadUntilTime t = pauseThreadFor . (t -) . realToFrac =<< Time.currentTime++{- | Sleep current thread for the indicated duration (in seconds).+  Divides long sleeps into parts smaller than 'pauseThreadLimit'.+-}+sleepThreadFor :: RealFrac n => n -> IO ()+sleepThreadFor n =+  if n >= pauseThreadLimit+    then+      let n' = pauseThreadLimit - 1+      in pauseThreadFor n' >> sleepThreadFor (n - n')+    else pauseThreadFor n++{- | Sleep current thread until the given time.+  Divides long sleeps into parts smaller than 'pauseThreadLimit'.+-}+sleepThreadUntilTime :: RealFrac n => n -> IO ()+sleepThreadUntilTime t = sleepThreadFor . (t -) . realToFrac =<< Time.currentTime

+ Sound/Osc/Time/Thread/MonadIO.hs view

@@ -0,0 +1,25 @@+-- | MonadIO lifted forms of Sound.Osc.Time.Thread functions+module Sound.Osc.Time.Thread.MonadIO where++import Control.Monad.IO.Class {- base >= 4.9 -}++import qualified Sound.Osc.Time as Time {- hosc -}+import qualified Sound.Osc.Time.Thread as Time.Thread {- hosc -}++time :: MonadIO m => m Time.NtpReal+time = liftIO Time.currentTime++pauseThread :: (MonadIO m, RealFrac n) => n -> m ()+pauseThread = liftIO . Time.Thread.pauseThreadFor++wait :: MonadIO m => Double -> m ()+wait = pauseThread++pauseThreadUntil :: (MonadIO m, RealFrac n) => n -> m ()+pauseThreadUntil = liftIO . Time.Thread.pauseThreadUntilTime++sleepThread :: (RealFrac n, MonadIO m) => n -> m ()+sleepThread = liftIO . Time.Thread.sleepThreadFor++sleepThreadUntil :: (RealFrac n, MonadIO m) => n -> m ()+sleepThreadUntil = liftIO . Time.Thread.sleepThreadUntilTime

+ Sound/Osc/Time/Timeout.hs view

@@ -0,0 +1,15 @@+-- | Timeout, implemented independently of socket timeout setting.+module Sound.Osc.Time.Timeout where++import System.Timeout {- base -}++import Sound.Osc.Packet {- hsoc -}+import Sound.Osc.Transport.Fd {- hosc -}++-- | Variant of 'timeout' where time is given in fractional seconds.+timeout_r :: Double -> IO a -> IO (Maybe a)+timeout_r = timeout . floor . (* 1000000)++-- | Variant of 'recvPacket' that implements an /n/ second 'timeout'.+recvPacketTimeout :: Transport t => Double -> t -> IO (Maybe (PacketOf Message))+recvPacketTimeout n fd = timeout_r n (recvPacket fd)

+ Sound/Osc/Transport/Fd.hs view

@@ -0,0 +1,101 @@+-- | An abstract transport layer with implementations for @Udp@ and @Tcp@ transport.+module Sound.Osc.Transport.Fd where++import Control.Exception {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}++import Sound.Osc.Datum {- hosc -}+import Sound.Osc.Packet {- hosc -}+import qualified Sound.Osc.Wait as Wait {- hosc -}++-- | Abstract over the underlying transport protocol.+class Transport t where+  -- | Encode and send an Osc packet.+  sendPacket :: t -> PacketOf Message -> IO ()++  -- | Receive and decode an Osc packet.+  recvPacket :: t -> IO (PacketOf Message)++  -- | Receive and either decode an Osc packet.+  recvPacketOr :: t -> IO (Either String 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++-- | 'sendPacket' of 'Packet_Message'.+sendMessage :: Transport t => t -> Message -> IO ()+sendMessage t = sendPacket t . Packet_Message++-- | 'sendPacket' of 'Packet_Bundle'.+sendBundle :: Transport t => t -> BundleOf Message -> IO ()+sendBundle t = sendPacket t . Packet_Bundle++-- * Receive++-- | Variant of 'recvPacket' that runs 'packet_to_bundle'.+recvBundle :: (Transport t) => t -> IO (BundleOf Message)+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++-- | Erroring variant.+recvMessage_err :: (Transport t) => t -> IO Message+recvMessage_err = fmap (fromMaybe (error "recvMessage")) . recvMessage++-- | Variant of 'recvPacket' that runs 'packetMessages'.+recvMessages :: (Transport t) => t -> IO [Message]+recvMessages = fmap packetMessages . recvPacket++-- * Wait++{- | Wait for a 'Packet' where the supplied predicate is 'True',+discarding intervening packets.+-}+waitUntil :: (Transport t) => t -> (PacketOf Message -> Bool) -> IO (PacketOf Message)+waitUntil t f = Wait.untilPredicate f (recvPacket t)++{- | Wait for a 'Packet' where the supplied function does not give+'Nothing', discarding intervening packets.+-}+waitFor :: (Transport t) => t -> (PacketOf Message -> Maybe a) -> IO a+waitFor t f = Wait.untilMaybe f (recvPacket t)++-- | 'waitUntil' 'packet_is_immediate'.+waitImmediate :: Transport t => t -> IO (PacketOf Message)+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 (PacketOf Message)+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

+ Sound/Osc/Transport/Fd/Socket.hs view

@@ -0,0 +1,40 @@+-- | Osc over Udp/Tcp implementation.+module Sound.Osc.Transport.Fd.Socket where++import qualified Sound.Osc.Transport.Fd as Fd {- hosc -}+import qualified Sound.Osc.Transport.Fd.Tcp as Fd.Tcp {- hosc -}+import qualified Sound.Osc.Transport.Fd.Udp as Fd.Udp {- hosc -}++-- | Protocol, either Udp or Tcp+data OscProtocol = Udp | Tcp+  deriving (Eq, Read, Show)++-- | Hostname+type OscHostname = String++-- | Port number+type OscPort = Int++-- | Socket address+type OscSocketAddress = (OscProtocol, OscHostname, OscPort)++-- | Socket+data OscSocket = OscUdpSocket Fd.Udp.Udp | OscTcpSocket Fd.Tcp.Tcp++-- | Open socket at address+openOscSocket :: OscSocketAddress -> IO OscSocket+openOscSocket address =+  case address of+    (Tcp, hostname, port) -> fmap OscTcpSocket (Fd.Tcp.openTcp hostname port)+    (Udp, hostname, port) -> fmap OscUdpSocket (Fd.Udp.openUdp hostname port)++-- | 'OscSocket' is an instance of 'Fd.Transport'.+instance Fd.Transport OscSocket where+  sendPacket (OscTcpSocket fd) = Fd.Tcp.tcp_send_packet fd+  sendPacket (OscUdpSocket fd) = Fd.Udp.udp_send_packet fd+  recvPacket (OscTcpSocket fd) = Fd.Tcp.tcp_recv_packet fd+  recvPacket (OscUdpSocket fd) = Fd.Udp.udp_recv_packet fd+  recvPacketOr (OscTcpSocket fd) = Fd.Tcp.tcp_recv_packet_or fd+  recvPacketOr (OscUdpSocket fd) = Fd.Udp.udp_recv_packet_or fd+  close (OscTcpSocket fd) = Fd.Tcp.tcp_close fd+  close (OscUdpSocket fd) = Fd.Udp.udp_close fd

+ Sound/Osc/Transport/Fd/Tcp.hs view

@@ -0,0 +1,101 @@+-- | Osc over Tcp implementation.+module Sound.Osc.Transport.Fd.Tcp where++import qualified Control.Exception as Exception {- base -}+import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -}+import qualified Network.Socket as Socket {- network -}+import qualified System.IO as Io {- base -}++import qualified Sound.Osc.Coding.Byte as Byte {- hosc -}+import qualified Sound.Osc.Coding.Convert as Convert {- hosc -}+import qualified Sound.Osc.Coding.Decode.Binary as Decode.Binary {- hosc -}+import qualified Sound.Osc.Coding.Encode.Builder as Encode.Builder {- hosc -}+import qualified Sound.Osc.Packet as Packet {- hosc -}+import qualified Sound.Osc.Transport.Fd as Fd {- hosc -}++-- | The Tcp transport handle data type.+newtype Tcp = Tcp {tcpHandle :: Io.Handle}++-- | Send data over Tcp.+tcp_send_data :: Tcp -> ByteString.Lazy.ByteString -> IO ()+tcp_send_data (Tcp fd) d = do+  let n = Convert.int64_to_word32 (ByteString.Lazy.length d)+  ByteString.Lazy.hPut fd (ByteString.Lazy.append (Byte.encode_word32 n) d)+  Io.hFlush fd++-- | Send packet over Tcp.+tcp_send_packet :: Tcp -> Packet.PacketOf Packet.Message -> IO ()+tcp_send_packet tcp p = tcp_send_data tcp (Encode.Builder.encodePacket p)++-- | Receive packet over Tcp.+tcp_recv_packet :: Tcp -> IO (Packet.PacketOf Packet.Message)+tcp_recv_packet (Tcp fd) = do+  b0 <- ByteString.Lazy.hGet fd 4+  b1 <- ByteString.Lazy.hGet fd (Convert.word32_to_int (Byte.decode_word32 b0))+  return (Decode.Binary.decodePacket b1)++tcp_recv_packet_or :: Tcp -> IO (Either String Packet.Packet)+tcp_recv_packet_or (Tcp fd) = do+  b0 <- ByteString.Lazy.hGet fd 4+  b1 <- ByteString.Lazy.hGet fd (Convert.word32_to_int (Byte.decode_word32 b0))+  return (Decode.Binary.decodePacketOr b1)++-- | Close Tcp.+tcp_close :: Tcp -> IO ()+tcp_close = Io.hClose . tcpHandle++-- | 'Tcp' is an instance of 'Transport'.+instance Fd.Transport Tcp where+  sendPacket = tcp_send_packet+  recvPacket = tcp_recv_packet+  recvPacketOr = tcp_recv_packet_or+  close = tcp_close++-- | Bracket Tcp communication.+with_tcp :: IO Tcp -> (Tcp -> IO t) -> IO t+with_tcp u = Exception.bracket u tcp_close++-- | Create and initialise Tcp socket.+tcp_socket :: (Socket.Socket -> Socket.SockAddr -> IO ()) -> Maybe String -> Int -> IO Socket.Socket+tcp_socket f host port = do+  fd <- Socket.socket Socket.AF_INET Socket.Stream 0+  let hints = Socket.defaultHints {Socket.addrFamily = Socket.AF_INET} -- localhost=ipv4+  i : _ <- Socket.getAddrInfo (Just hints) host (Just (show port))+  let sa = Socket.addrAddress i+  _ <- f fd sa+  return fd++-- | Convert 'Socket.Socket' to 'Tcp'.+socket_to_tcp :: Socket.Socket -> IO Tcp+socket_to_tcp fd = fmap Tcp (Socket.socketToHandle fd Io.ReadWriteMode)++-- | Create and initialise Tcp.+tcp_handle :: (Socket.Socket -> Socket.SockAddr -> IO ()) -> String -> Int -> IO Tcp+tcp_handle f host port = tcp_socket f (Just host) port >>= socket_to_tcp++{- | Make a 'Tcp' connection.++> import Sound.Osc.Datum+> import Sound.Osc.Time+> let t = openTcp "127.0.0.1" 57110+> let m1 = Packet.message "/dumpOsc" [Int32 1]+> let m2 = Packet.message "/g_new" [Int32 1]+> Fd.withTransport t (\fd -> let f = Fd.sendMessage fd in f m1 >> pauseThread 0.25 >> f m2)+-}+openTcp :: String -> Int -> IO Tcp+openTcp = tcp_handle Socket.connect++-- | 'Socket.accept' connection at /s/ and run /f/.+tcp_server_f :: Socket.Socket -> (Tcp -> IO ()) -> IO ()+tcp_server_f s f = do+  (fd, _) <- Socket.accept s+  h <- socket_to_tcp fd+  f h++-- | A trivial 'Tcp' /Osc/ server.+tcp_server :: Int -> (Tcp -> IO ()) -> IO ()+tcp_server port f = do+  s <- tcp_socket Socket.bind Nothing port+  Socket.listen s 1+  let repeatM_ = sequence_ . repeat+  repeatM_ (tcp_server_f s f)

+ Sound/Osc/Transport/Fd/Udp.hs view

@@ -0,0 +1,119 @@+-- | Osc over Udp implementation.+module Sound.Osc.Transport.Fd.Udp where++import Control.Exception {- base -}+import Control.Monad {- base -}+import Data.Bifunctor {- base -}++import qualified Data.ByteString as B {- bytestring -}+import qualified Data.ByteString.Lazy as BL {- bytestring -}+import qualified Network.Socket as N {- network -}+import qualified Network.Socket.ByteString as C {- network -}++import qualified Sound.Osc.Coding.Decode.Binary as Binary {- hosc -}+import qualified Sound.Osc.Coding.Encode.Builder as Builder {- hosc -}+import qualified Sound.Osc.Packet as Packet {- hosc -}+import qualified Sound.Osc.Transport.Fd as Fd {- hosc -}++-- | The Udp transport handle data type.+newtype Udp = Udp {udpSocket :: N.Socket}++-- | Return the port number associated with the Udp socket.+udpPort :: Integral n => Udp -> IO n+udpPort = fmap fromIntegral . N.socketPort . udpSocket++-- | Send data over Udp using 'C.send'.+udp_send_data :: Udp -> B.ByteString -> IO ()+udp_send_data (Udp fd) d = do+  let l = B.length d+  n <- C.send fd d+  when (n /= l) (error (show ("udp_send_data", l, n)))++-- | Send data over Udp using 'C.sendAll'.+udp_sendAll_data :: Udp -> B.ByteString -> IO ()+udp_sendAll_data (Udp fd) = C.sendAll fd++-- | Send packet over Udp.+udp_send_packet :: Udp -> Packet.PacketOf Packet.Message -> IO ()+udp_send_packet udp = udp_sendAll_data udp . Builder.encodePacket_strict++-- | Receive packet over Udp.+udp_recv_packet :: Udp -> IO (Packet.PacketOf Packet.Message)+udp_recv_packet (Udp fd) = fmap Binary.decodePacket_strict (C.recv fd 8192)++udp_recv_packet_or :: Udp -> IO (Either String Packet.Packet)+udp_recv_packet_or (Udp fd) = Binary.decodePacketOr . BL.fromStrict <$> C.recv fd 8192++-- | Close Udp.+udp_close :: Udp -> IO ()+udp_close (Udp fd) = N.close fd++-- | 'Udp' is an instance of 'Fd.Transport'.+instance Fd.Transport Udp where+  sendPacket = udp_send_packet+  recvPacket = udp_recv_packet+  recvPacketOr = udp_recv_packet_or+  close = udp_close++-- | Bracket Udp communication.+with_udp :: IO Udp -> (Udp -> IO t) -> IO t+with_udp u = bracket u udp_close++-- | 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+  let hints = N.defaultHints {N.addrFamily = N.AF_INET} -- localhost=ipv4+  i : _ <- N.getAddrInfo (Just hints) (Just host) (Just (show port))+  let sa = N.addrAddress i+  f fd sa+  return (Udp fd)++-- | Set option, ie. 'N.Broadcast' or 'N.RecvTimeOut'.+set_udp_opt :: N.SocketOption -> Int -> Udp -> IO ()+set_udp_opt k v (Udp s) = N.setSocketOption s k v++-- | Get option.+get_udp_opt :: N.SocketOption -> Udp -> IO Int+get_udp_opt k (Udp s) = N.getSocketOption s k++-- | Make a 'Udp' connection.+openUdp :: String -> Int -> IO Udp+openUdp = udp_socket N.connect++{- | Trivial 'Udp' server socket.++> import Control.Concurrent++> let u0 = udpServer "127.0.0.1" 57300+> t0 <- forkIO (Fd.withTransport u0 (\fd -> forever (Fd.recvMessage fd >>= print >> print "Received message, continuing")))+> killThread t0++> let u1 = openUdp "127.0.0.1" 57300+> Fd.withTransport u1 (\fd -> Fd.sendMessage fd (Packet.message "/n" []))+-}+udpServer :: String -> Int -> IO Udp+udpServer = udp_socket N.bind++-- | Variant of 'udpServer' that doesn't require the host address.+udp_server :: Int -> IO Udp+udp_server p = do+  let hints =+        N.defaultHints+          { N.addrFamily = N.AF_INET -- localhost=ipv4+          , N.addrFlags = [N.AI_PASSIVE, N.AI_NUMERICSERV]+          , N.addrSocketType = N.Datagram+          }+  a : _ <- N.getAddrInfo (Just hints) Nothing (Just (show p))+  s <- N.socket (N.addrFamily a) (N.addrSocketType a) (N.addrProtocol a)+  N.setSocketOption s N.ReuseAddr 1+  N.bind s (N.addrAddress a)+  return (Udp s)++-- | Send to specified address using 'C.sendAllTo.+sendTo :: Udp -> Packet.PacketOf Packet.Message -> N.SockAddr -> IO ()+sendTo (Udp fd) p = C.sendAllTo fd (Builder.encodePacket_strict p)++-- | Recv variant to collect message source address.+recvFrom :: Udp -> IO (Packet.PacketOf Packet.Message, N.SockAddr)+recvFrom (Udp fd) = fmap (first Binary.decodePacket_strict) (C.recvFrom fd 8192)

+ Sound/Osc/Transport/Monad.hs view

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

+ Sound/Osc/Wait.hs view

@@ -0,0 +1,18 @@+-- | Waiting (for replies).+module Sound.Osc.Wait where++-- * 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 recur else return p+      recur = act >>= g+  in recur++-- | 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 = maybe recur return (f p)+      recur = act >>= g+  in recur

hosc.cabal view

@@ -1,21 +1,18 @@+Cabal-Version:     2.4 Name:              hosc-Version:           0.19.1+Version:           0.21.1 Synopsis:          Haskell Open Sound Control-Description:       @hosc@ implements a subset of the Open Sound Control-                   byte protocol, <http://opensoundcontrol.org/>.-                   .-                   See "Sound.OSC.Core" or "Sound.OSC" or "Sound.OSC.FD".-License:           GPL-3+Description:       Haskell library implementing the Open Sound Control protocol+License:           GPL-3.0-only License-File:      contrib/LICENSE Category:          Sound-Copyright:         (c) Rohan Drape, Stefan Kersten and others, 2007-2021+Copyright:         (c) Rohan Drape, Stefan Kersten and others, 2007-2024 Author:            Rohan Drape, Stefan Kersten Maintainer:        rd@rohandrape.net Stability:         Experimental Homepage:          http://rohandrape.net/t/hosc-Tested-With:       GHC == 8.8.4+Tested-With:       GHC == 9.10.1 Build-Type:        Simple-Cabal-Version:     >= 1.10 Data-Files:        README.md  Library@@ -23,32 +20,37 @@                    binary >= 0.7.2,                    blaze-builder >= 0.3,                    bytestring,-                   data-binary-ieee754,                    network >= 2.3,+                   parsec,+                   safe,                    time >= 1.5,                    transformers   Default-Language:Haskell2010-  GHC-Options:     -Wall -fwarn-tabs-  if impl(ghc < 8.4)-    cpp-options: -DIMPORT_SEMIGROUP-  Exposed-modules: Sound.OSC-                   Sound.OSC.Coding.Byte-                   Sound.OSC.Coding.Cast-                   Sound.OSC.Coding.Convert-                   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.Packet-                   Sound.OSC.Time-                   Sound.OSC.Transport.FD-                   Sound.OSC.Transport.FD.TCP-                   Sound.OSC.Transport.FD.UDP-                   Sound.OSC.Transport.Monad-                   Sound.OSC.Wait+  GHC-Options:     -Wall -Wno-x-partial -Wno-incomplete-uni-patterns+  Exposed-modules: Sound.Osc+                   Sound.Osc.Coding.Byte+                   Sound.Osc.Coding.Cast+                   Sound.Osc.Coding.Convert+                   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.Packet+                   Sound.Osc.Text+                   Sound.Osc.Time+                   Sound.Osc.Time.System+                   Sound.Osc.Time.Thread+                   Sound.Osc.Time.Thread.MonadIO+                   Sound.Osc.Time.Timeout+                   Sound.Osc.Transport.Fd+                   Sound.Osc.Transport.Fd.Socket+                   Sound.Osc.Transport.Fd.Tcp+                   Sound.Osc.Transport.Fd.Udp+                   Sound.Osc.Transport.Monad+                   Sound.Osc.Wait  Source-Repository  head   Type:            git