hosc 0.12 → 0.13

raw patch · 9 files changed

+130/−136 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Sound/OSC/Transport/Monad.hs +38/−21
• Sound/OpenSoundControl/Coding/Byte.hs +2/−0
• Sound/OpenSoundControl/Coding/Decode/Base.hs +1/−1
• Sound/OpenSoundControl/Coding/Decode/Binary.hs +2/−2
• Sound/OpenSoundControl/Coding/Encode/Base.hs +5/−13
• Sound/OpenSoundControl/Coding/Encode/Builder.hs +2/−4
• Sound/OpenSoundControl/Time.hs +70/−87
• Sound/OpenSoundControl/Type.hs +9/−7
• hosc.cabal +1/−1

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

@@ -89,6 +89,8 @@  -- | 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

@@ -43,7 +43,7 @@       'd' -> Double (decode_f64 b)       's' -> String (decode_str (b_take (size 's' b) b))       'b' -> Blob (b_take (size 'b' b) (B.drop 4 b))-      't' -> TimeStamp (NTPi (decode_u64 b))+      't' -> TimeStamp (ntpi_to_ntpr (decode_u64 b))       'm' -> let [b0,b1,b2,b3] = B.unpack (B.take 4 b) in Midi (b0,b1,b2,b3)       _ -> error ("decode_datum: illegal type (" ++ [ty] ++ ")") 

@@ -55,7 +55,7 @@       'd' -> Double <$> I.getFloat64be       's' -> String <$> get_string       'b' -> Blob   <$> (get_bytes =<< getWord32be)-      't' -> TimeStamp <$> NTPi <$> getWord64be+      't' -> TimeStamp <$> ntpi_to_ntpr <$> getWord64be       'm' -> do b0 <- getWord8                 b1 <- getWord8                 b2 <- getWord8@@ -88,7 +88,7 @@ get_bundle :: Get Bundle get_bundle = do     skip (fromIntegral (L.length bundleHeader))-    t <- NTPi <$> getWord64be+    t <- ntpi_to_ntpr <$> getWord64be     ps <- get_message_seq     return $ Bundle t ps 

@@ -25,7 +25,7 @@       Int i -> encode_i32 i       Float f -> encode_f32 f       Double d -> encode_f64 d-      TimeStamp t -> encode_u64 $ as_ntpi t+      TimeStamp t -> encode_u64 $ ntpr_to_ntpi t       String s -> extend 0 (B.snoc (encode_str s) 0)       Midi (b0,b1,b2,b3) -> B.pack [b0,b1,b2,b3]       Blob b -> let n = encode_i32 (fromIntegral (B.length b))@@ -42,20 +42,12 @@ encode_message_blob :: Message -> Datum encode_message_blob = Blob . encodeMessage --- Encode an OSC bundle.-encode_bundle_ntpi :: NTPi -> [Message] -> B.ByteString-encode_bundle_ntpi t l =-    B.concat [bundleHeader-             ,encode_u64 t-             ,B.concat (map (encode_datum . encode_message_blob) l) ]- -- | Encode an OSC 'Bundle'. encodeBundle :: Bundle -> B.ByteString-encodeBundle b =-    case b of-      Bundle (NTPi t) l -> encode_bundle_ntpi t l-      Bundle (NTPr t) l -> encode_bundle_ntpi (ntpr_ntpi t) l-      Bundle (UTCr t) l -> encode_bundle_ntpi (utcr_ntpi t) l+encodeBundle (Bundle t m) =+    B.concat [bundleHeader+             ,encode_u64 (ntpr_to_ntpi t)+             ,B.concat (map (encode_datum . encode_message_blob) m)]  -- | Encode an OSC 'Packet'. encodePacket :: Packet -> B.ByteString

@@ -42,7 +42,7 @@       Int i -> B.fromInt32be (fromIntegral i)       Float n -> B.fromWord32be (I.floatToWord (realToFrac n))       Double n -> B.fromWord64be (I.doubleToWord n)-      TimeStamp t -> B.fromWord64be (fromIntegral (as_ntpi t))+      TimeStamp t -> B.fromWord64be (fromIntegral (ntpr_to_ntpi t))       String s -> build_string s       Midi (b0,b1,b2,b3) -> B.fromWord8s [b0,b1,b2,b3]       Blob b -> build_bytes b@@ -66,9 +66,7 @@ build_packet o =     case o of       Packet_Message m -> build_message m-      Packet_Bundle (Bundle (NTPi t) l) -> build_bundle_ntpi t l-      Packet_Bundle (Bundle (NTPr t) l) -> build_bundle_ntpi (ntpr_ntpi t) l-      Packet_Bundle (Bundle (UTCr t) l) -> build_bundle_ntpi (utcr_ntpi t) l+      Packet_Bundle (Bundle t m) -> build_bundle_ntpi (ntpr_to_ntpi t) m  {-# INLINE encodeMessage #-} {-# INLINE encodeBundle #-}

@@ -1,12 +1,5 @@--- | OSC related timing functions.------ OSC timestamps are @NTP@ values, <http://ntp.org/>.--- 'T.getCurrentTime' gives @UTC@ values.  The 'Time' type is a union--- of the different representations.------ 'utcr' reads the current time as real valued @UTC@ and--- 'pauseThread' suspends the current thread for a real valued number--- of seconds.+-- | OSC related timing functions.  OSC timestamps are @NTP@ values,+-- <http://ntp.org/>. module Sound.OpenSoundControl.Time where  import Control.Concurrent@@ -14,124 +7,114 @@ import Control.Monad.IO.Class import Data.Word import qualified Data.Time as T+import qualified Data.Time.Clock.POSIX as T  -- * Temporal types --- | Type for integer representation of NTP time.+-- | Type for integer (binary) representation of @NTP@ time. type NTPi = Word64 --- | Time is represented in either @UTC@ or @NTP@ form.  The @NTP@ form may---   be either integral or real.-data Time = UTCr Double | NTPr Double | NTPi NTPi-            deriving (Read, Show)--instance Eq Time where-    a == b = as_ntpi a == as_ntpi b-    a /= b = as_ntpi a /= as_ntpi b---- | Coerce 'Time' to integral @NTP@ form.-as_ntpi :: Time -> NTPi-as_ntpi x =-    case x of-      UTCr t -> utcr_ntpi t-      NTPr t -> ntpr_ntpi t-      NTPi t -> t+-- | @NTP@ time in real-valued (fractional) form.+type Time = Double --- | Coerce 'Time' to real-valued @UTC@ form.-as_utcr :: Time -> Double-as_utcr x =-    case x of-      UTCr t -> t-      NTPr t -> ntpr_utcr t-      NTPi t -> ntpi_utcr t+-- | @Unix/Posix@ epoch time in real-valued (fractional) form.+type UT = Double --- | Times can be ordered, avoid coercion if not required.-instance Ord Time where-    compare p q =-        case (p,q) of-          (UTCr p',UTCr q') -> compare p' q'-          (NTPr p',NTPr q') -> compare p' q'-          (NTPi p',NTPi q') -> compare p' q'-          _ -> compare (as_ntpi p) (as_ntpi q)+-- * Time conversion  -- | Convert a real-valued NTP timestamp to an 'NTPi' timestamp.-ntpr_ntpi :: Double -> NTPi-ntpr_ntpi t = round (t * 2^(32::Int))+ntpr_to_ntpi :: RealFrac n => n -> NTPi+ntpr_to_ntpi t = round (t * 2^(32::Int))  -- | Convert an 'NTPi' timestamp to a real-valued NTP timestamp.-ntpi_ntpr :: NTPi -> Double-ntpi_ntpr t = fromIntegral t / 2^(32::Int)+ntpi_to_ntpr :: Fractional n => NTPi -> n+ntpi_to_ntpr t = fromIntegral t / 2^(32::Int) --- | Convert a real-valued UTC timestamp to an 'NTPi' timestamp.-utcr_ntpi :: Double -> NTPi-utcr_ntpi t =-    let secdif = (70 * 365 + 17) * 24 * 60 * 60-    in ntpr_ntpi (t + secdif)+-- | Difference (in seconds) between /NTP/ and /UT/ epochs.+--+-- > ntp_ut_epoch_diff / (24 * 60 * 60) == 25567+ntp_ut_epoch_diff :: Num n => n+ntp_ut_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60 --- | Convert a real-valued NTP timestamp to a real-valued UTC timestamp.-ntpr_utcr :: Double -> Double-ntpr_utcr t =-    let secdif = (70 * 365 + 17) * 24 * 60 * 60-    in t - secdif+-- | Convert a 'UT' timestamp to an 'NTPi' timestamp.+ut_to_ntpi :: UT -> NTPi+ut_to_ntpi t = ntpr_to_ntpi (t + ntp_ut_epoch_diff) --- | Convert an 'NTPi' timestamp to a real-valued UTC timestamp.-ntpi_utcr :: NTPi -> Double-ntpi_utcr = ntpr_utcr . ntpi_ntpr+-- | Convert @Unix/Posix@ to @NTP@.+ut_to_ntpr :: Num n => n -> n+ut_to_ntpr = (+) ntp_ut_epoch_diff +-- | Convert @NTP@ to @Unix/Posix@.+ntpr_to_ut :: Num n => n -> n+ntpr_to_ut = (+) (negate ntp_ut_epoch_diff)++-- | Convert 'NTPi' to @Unix/Posix@.+ntpi_to_ut :: NTPi -> UT+ntpi_to_ut = ntpr_to_ut . ntpi_to_ntpr++-- * Constants++-- | Constant indicating a bundle to be executed immediately.+--+-- > ntpr_to_ntpi immediately == 1+immediately :: Time+immediately = ntpi_to_ntpr 1++-- * 'Data.Time' inter-operation.+ -- | The time at 1970-01-01:00:00:00.-utc_base :: T.UTCTime-utc_base =+ut_epoch :: T.UTCTime+ut_epoch =     let d = T.fromGregorian 1970 1 1         s = T.secondsToDiffTime 0     in T.UTCTime d s --- | Convert an 'T.UTCTime' timestamp to a real-valued UTC timestamp.-utc_utcr :: T.UTCTime -> Double-utc_utcr t = realToFrac (T.diffUTCTime t utc_base)---- | Constant indicating the bundle is to be executed immediately.-immediately :: Time-immediately = NTPi 1+-- | 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 @UTC@ timestamp.-utcr :: MonadIO m => m Double-utcr = liftIO (fmap utc_utcr T.getCurrentTime)---- | Read current 'NTPi' timestamp.-ntpi ::  MonadIO m => m NTPi-ntpi = liftM utcr_ntpi utcr+-- | Read current real-valued @NTP@ timestamp.+--+-- > do {ct <- fmap utc_to_ut T.getCurrentTime+-- >    ;pt <- fmap realToFrac T.getPOSIXTime+-- >    ;print (pt - ct,pt - ct < 1e-5)}+time :: MonadIO m => m Time+time = liftIO (fmap (ut_to_ntpr . realToFrac) T.getPOSIXTime)  -- * Thread operations.  -- | The 'pauseThread' limit (in seconds).  Values larger than this -- require a different thread delay mechanism, see 'sleepThread'.  The -- value is the number of microseconds in @maxBound::Int@.-pauseThreadLimit :: Double+pauseThreadLimit :: Fractional n => n pauseThreadLimit = fromIntegral (maxBound::Int) / 1e6  -- | Pause current thread for the indicated duration (in seconds), see---   'pauseThreadLimit'.  Note also that this function does not---   attempt pauses less than @1e-4@.-pauseThread :: MonadIO m => Double -> m ()-pauseThread n = when (n > 1e-4) (liftIO (threadDelay (floor (n * 1e6))))+--   'pauseThreadLimit'.+pauseThread :: (MonadIO m,Ord n,RealFrac n) => n -> m ()+pauseThread n = when (n > 0) (liftIO (threadDelay (floor (n * 1e6)))) --- | Pause current thread until the given real-valued @UTC@ time, see+-- | Type restricted 'pauseThread'.+wait :: MonadIO m => Double -> m ()+wait = pauseThread++-- | Pause current thread until the given 'Time', see -- 'pauseThreadLimit'.-pauseThreadUntil :: MonadIO m => Double -> m ()-pauseThreadUntil t = pauseThread . (t -) =<< utcr+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 :: MonadIO m => Double -> m ()+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 real-valued @UTC@ time.--- Divides long sleeps into parts smaller than 'pauseThreadLimit'.-sleepThreadUntil :: MonadIO m => Double -> m ()-sleepThreadUntil t = sleepThread . (t -) =<< utcr+-- | 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

@@ -58,6 +58,14 @@       '/':_ -> Message a xs       _ -> error "message: ill-formed address pattern" +-- | 'Packet_Bundle' '.' 'bundle'.+p_bundle :: Time -> [Message] -> Packet+p_bundle t = Packet_Bundle . bundle t++-- | 'Packet_Message' '.' 'message'.+p_message :: Address_Pattern -> [Datum] -> Packet+p_message a = Packet_Message . message a+ -- * Datum  -- | Single character identifier of an OSC datum.@@ -209,14 +217,8 @@ -- * Pretty printing  -- | Pretty printer for 'Time'.------ > map timePP [UTCr 0,NTPr 0,NTPi 0] timePP :: Time -> String-timePP t =-    case t of-      UTCr n -> 'U' : show n-      NTPr n -> 'N' : show n-      NTPi i -> 'N' : show (ntpi_ntpr i)+timePP = (:) 'N' . show  -- | Pretty printer for 'Datum'. --

@@ -1,5 +1,5 @@ Name:              hosc-Version:           0.12+Version:           0.13 Synopsis:          Haskell Open Sound Control Description:       @hosc@ implements a subset of the /Open Sound Control/                    byte protocol, <http://opensoundcontrol.org/>.