{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}


module Sound.Tidal.Tempo where

import Control.Concurrent.MVar
import qualified Sound.Tidal.Pattern as P
import qualified Sound.OSC.FD as O
import qualified Network.Socket as N
import Control.Concurrent (forkIO, ThreadId, threadDelay)
import Control.Monad (forever, when, foldM)
import Data.List (nub)
import qualified Control.Exception as E
import Sound.Tidal.Config
import Sound.Tidal.Utils (writeError)

{-
    Tempo.hs - Tidal's scheduler
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

instance Show O.UDP where
  show :: UDP -> String
show UDP
_ = String
"-unshowable-"

data Tempo = Tempo {Tempo -> Time
atTime  :: O.Time,
                    Tempo -> Rational
atCycle :: Rational,
                    Tempo -> Time
cps     :: O.Time,
                    Tempo -> Bool
paused  :: Bool,
                    Tempo -> Time
nudged  :: Double,
                    Tempo -> UDP
localUDP   :: O.UDP,
                    Tempo -> SockAddr
remoteAddr :: N.SockAddr,
                    Tempo -> Bool
synched :: Bool
                   }
  deriving Int -> Tempo -> ShowS
[Tempo] -> ShowS
Tempo -> String
(Int -> Tempo -> ShowS)
-> (Tempo -> String) -> ([Tempo] -> ShowS) -> Show Tempo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tempo] -> ShowS
$cshowList :: [Tempo] -> ShowS
show :: Tempo -> String
$cshow :: Tempo -> String
showsPrec :: Int -> Tempo -> ShowS
$cshowsPrec :: Int -> Tempo -> ShowS
Show

instance Eq Tempo where
  == :: Tempo -> Tempo -> Bool
(==) Tempo
t Tempo
t' = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [(Tempo -> Time
atTime Tempo
t)  Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== (Tempo -> Time
atTime Tempo
t'),
                   (Tempo -> Rational
atCycle Tempo
t) Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== (Tempo -> Rational
atCycle Tempo
t'),
                   (Tempo -> Time
cps Tempo
t)     Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== (Tempo -> Time
cps Tempo
t'),
                   (Tempo -> Bool
paused Tempo
t)  Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Tempo -> Bool
paused Tempo
t'),
                   (Tempo -> Time
nudged Tempo
t)  Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== (Tempo -> Time
nudged Tempo
t')
                  ]

data State = State {State -> Int
ticks   :: Int,
                    State -> Time
start   :: O.Time,
                    State -> (Time, Time)
nowTimespan :: (O.Time, O.Time),
                    State -> Arc
nowArc  :: P.Arc,
                    State -> Bool
starting :: Bool
                   }
  deriving Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show

changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo
changeTempo :: MVar Tempo -> (Time -> Tempo -> Tempo) -> IO Tempo
changeTempo MVar Tempo
tempoMV Time -> Tempo -> Tempo
f = do Time
t <- IO Time
forall (m :: * -> *). MonadIO m => m Time
O.time
                           Tempo
tempo <- MVar Tempo -> IO Tempo
forall a. MVar a -> IO a
takeMVar MVar Tempo
tempoMV
                           let tempo' :: Tempo
tempo' = Time -> Tempo -> Tempo
f Time
t Tempo
tempo
                           Tempo -> IO ()
sendTempo Tempo
tempo'
                           MVar Tempo -> Tempo -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Tempo
tempoMV Tempo
tempo'
                           Tempo -> IO Tempo
forall (m :: * -> *) a. Monad m => a -> m a
return Tempo
tempo'

changeTempo' :: Tempo -> O.Time -> Rational -> Tempo
changeTempo' :: Tempo -> Time -> Rational -> Tempo
changeTempo' Tempo
tempo Time
newCps Rational
cyc = Tempo
tempo {atTime :: Time
atTime = Tempo -> Rational -> Time
cyclesToTime Tempo
tempo Rational
cyc,
                                       cps :: Time
cps = Time
newCps,
                                       atCycle :: Rational
atCycle = Rational
cyc
                                      }

resetCycles :: MVar Tempo -> IO Tempo
resetCycles :: MVar Tempo -> IO Tempo
resetCycles MVar Tempo
tempoMV = MVar Tempo -> (Time -> Tempo -> Tempo) -> IO Tempo
changeTempo MVar Tempo
tempoMV (\Time
t Tempo
tempo -> Tempo
tempo {atTime :: Time
atTime = Time
t, atCycle :: Rational
atCycle = Rational
0})

setCps :: MVar Tempo -> O.Time -> IO Tempo
setCps :: MVar Tempo -> Time -> IO Tempo
setCps MVar Tempo
tempoMV Time
newCps = MVar Tempo -> (Time -> Tempo -> Tempo) -> IO Tempo
changeTempo MVar Tempo
tempoMV (\Time
t Tempo
tempo -> Tempo
tempo {atTime :: Time
atTime = Time
t,
                                                                atCycle :: Rational
atCycle = Tempo -> Time -> Rational
timeToCycles Tempo
tempo Time
t,
                                                                cps :: Time
cps = Time
newCps
                                                               })

defaultCps :: O.Time
defaultCps :: Time
defaultCps = Time
0.5625

defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo
defaultTempo :: Time -> UDP -> SockAddr -> Tempo
defaultTempo Time
t UDP
local SockAddr
remote = Tempo :: Time
-> Rational
-> Time
-> Bool
-> Time
-> UDP
-> SockAddr
-> Bool
-> Tempo
Tempo {atTime :: Time
atTime   = Time
t,
                                     atCycle :: Rational
atCycle  = Rational
0,
                                     cps :: Time
cps      = Time
defaultCps,
                                     paused :: Bool
paused   = Bool
False,
                                     nudged :: Time
nudged   = Time
0,
                                     localUDP :: UDP
localUDP   = UDP
local,
                                     remoteAddr :: SockAddr
remoteAddr = SockAddr
remote,
                                     synched :: Bool
synched = Bool
False
                                    }

-- | Returns the given time in terms of
-- cycles relative to metrical grid of a given Tempo
timeToCycles :: Tempo -> O.Time -> Rational
timeToCycles :: Tempo -> Time -> Rational
timeToCycles Tempo
tempo Time
t = Tempo -> Rational
atCycle Tempo
tempo Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Time -> Rational
forall a. Real a => a -> Rational
toRational Time
cycleDelta
  where delta :: Time
delta = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
- Tempo -> Time
atTime Tempo
tempo
        cycleDelta :: Time
cycleDelta = Time -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Tempo -> Time
cps Tempo
tempo) Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
delta

cyclesToTime :: Tempo -> Rational -> O.Time
cyclesToTime :: Tempo -> Rational -> Time
cyclesToTime Tempo
tempo Rational
cyc = Tempo -> Time
atTime Tempo
tempo Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Rational -> Time
forall a. Fractional a => Rational -> a
fromRational Rational
timeDelta
  where cycleDelta :: Rational
cycleDelta = Rational
cyc Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Tempo -> Rational
atCycle Tempo
tempo
        timeDelta :: Rational
timeDelta = Rational
cycleDelta Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Time -> Rational
forall a. Real a => a -> Rational
toRational (Tempo -> Time
cps Tempo
tempo)

{-
getCurrentCycle :: MVar Tempo -> IO Rational
getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational)
-}

clocked :: Config -> MVar Tempo -> (State -> IO ()) -> IO [ThreadId]
clocked :: Config -> MVar Tempo -> (State -> IO ()) -> IO [ThreadId]
clocked Config
config MVar Tempo
tempoMV State -> IO ()
callback
  = do Time
s <- IO Time
forall (m :: * -> *). MonadIO m => m Time
O.time
       -- TODO - do something with thread id
       Maybe ThreadId
_ <- Config -> IO (Maybe ThreadId)
serverListen Config
config
       ThreadId
listenTid <- Config -> MVar Tempo -> Time -> IO ThreadId
clientListen Config
config MVar Tempo
tempoMV Time
s
       let st :: State
st = State :: Int -> Time -> (Time, Time) -> Arc -> Bool -> State
State {ticks :: Int
ticks = Int
0,
                       start :: Time
start = Time
s,
                       nowTimespan :: (Time, Time)
nowTimespan = (Time
s, Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
frameTimespan),
                       nowArc :: Arc
nowArc = Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
P.Arc Rational
0 Rational
0,
                       starting :: Bool
starting = Bool
True
                      }
       ThreadId
clockTid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ State -> IO ()
forall b. State -> IO b
loop State
st
       [ThreadId] -> IO [ThreadId]
forall (m :: * -> *) a. Monad m => a -> m a
return [ThreadId
listenTid, ThreadId
clockTid]
  where frameTimespan :: Double
        frameTimespan :: Time
frameTimespan = Config -> Time
cFrameTimespan Config
config
        loop :: State -> IO b
loop State
st =
          do -- putStrLn $ show $ nowArc ts
             Tempo
tempo <- MVar Tempo -> IO Tempo
forall a. MVar a -> IO a
readMVar MVar Tempo
tempoMV
             Time
t <- IO Time
forall (m :: * -> *). MonadIO m => m Time
O.time
             let logicalT :: a -> Time
logicalT a
ticks' = State -> Time
start State
st Time -> Time -> Time
forall a. Num a => a -> a -> a
+ a -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ticks' Time -> Time -> Time
forall a. Num a => a -> a -> a
*  Time
frameTimespan
                 logicalNow :: Time
logicalNow = Int -> Time
forall a. Integral a => a -> Time
logicalT (Int -> Time) -> Int -> Time
forall a b. (a -> b) -> a -> b
$ State -> Int
ticks State
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                 -- Wait maximum of two frames
                 delta :: Time
delta = Time -> Time -> Time
forall a. Ord a => a -> a -> a
min (Time
frameTimespan Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
2) (Time
logicalNow Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
t)
                 e :: Rational
e = Tempo -> Time -> Rational
timeToCycles Tempo
tempo Time
logicalNow
                 s :: Rational
s = if State -> Bool
starting State
st Bool -> Bool -> Bool
&& Tempo -> Bool
synched Tempo
tempo
                     then Tempo -> Time -> Rational
timeToCycles Tempo
tempo (Int -> Time
forall a. Integral a => a -> Time
logicalT (Int -> Time) -> Int -> Time
forall a b. (a -> b) -> a -> b
$ State -> Int
ticks State
st)
                     else Arc -> Rational
forall a. ArcF a -> a
P.stop (Arc -> Rational) -> Arc -> Rational
forall a b. (a -> b) -> a -> b
$ State -> Arc
nowArc State
st
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
logicalNow) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Int) -> Time -> Int
forall a b. (a -> b) -> a -> b
$ Time
delta Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1000000)
             Time
t' <- IO Time
forall (m :: * -> *). MonadIO m => m Time
O.time
             let actualTick :: Int
actualTick = Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Int) -> Time -> Int
forall a b. (a -> b) -> a -> b
$ (Time
t' Time -> Time -> Time
forall a. Num a => a -> a -> a
- State -> Time
start State
st) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
frameTimespan
                 -- reset ticks if ahead/behind by skipTicks or more
                 ahead :: Bool
ahead = Int -> Int
forall a. Num a => a -> a
abs (Int
actualTick Int -> Int -> Int
forall a. Num a => a -> a -> a
- State -> Int
ticks State
st) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Config -> Int
cSkipTicks Config
config
                 newTick :: Int
newTick | Bool
ahead = Int
actualTick
                         | Bool
otherwise = State -> Int
ticks State
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                 st' :: State
st' = State
st {ticks :: Int
ticks = Int
newTick,
                           nowArc :: Arc
nowArc = Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
P.Arc Rational
s Rational
e,
                           nowTimespan :: (Time, Time)
nowTimespan = (Time
logicalNow,  Time
logicalNow Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
frameTimespan),
                           starting :: Bool
starting = Bool -> Bool
not (Tempo -> Bool
synched Tempo
tempo)
                          }
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ahead (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
writeError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"skip: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
actualTick Int -> Int -> Int
forall a. Num a => a -> a -> a
- State -> Int
ticks State
st)
             State -> IO ()
callback State
st'
             {-putStrLn ("actual tick: " ++ show actualTick
                       ++ " old tick: " ++ show (ticks st)
                       ++ " new tick: " ++ show newTick
                      )-}
             State -> IO b
loop State
st'

clientListen :: Config -> MVar Tempo -> O.Time -> IO ThreadId
clientListen :: Config -> MVar Tempo -> Time -> IO ThreadId
clientListen Config
config MVar Tempo
tempoMV Time
s =
  do -- Listen on random port
     let tempoClientPort :: Int
tempoClientPort = Config -> Int
cTempoClientPort Config
config
         hostname :: String
hostname = Config -> String
cTempoAddr Config
config
         port :: Int
port = Config -> Int
cTempoPort Config
config
     (AddrInfo
remote_addr:[AddrInfo]
_) <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
N.getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
hostname) Maybe String
forall a. Maybe a
Nothing
     UDP
local <- String -> Int -> IO UDP
O.udpServer String
"0.0.0.0" Int
tempoClientPort
     let (N.SockAddrInet PortNumber
_ HostAddress
a) = AddrInfo -> SockAddr
N.addrAddress AddrInfo
remote_addr
         remote :: SockAddr
remote = PortNumber -> HostAddress -> SockAddr
N.SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) HostAddress
a
         t :: Tempo
t = Time -> UDP -> SockAddr -> Tempo
defaultTempo Time
s UDP
local SockAddr
remote
     MVar Tempo -> Tempo -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Tempo
tempoMV Tempo
t
     -- Send to clock port from same port that's listened to
     UDP -> Packet -> SockAddr -> IO ()
O.sendTo UDP
local (String -> [Datum] -> Packet
O.p_message String
"/hello" []) SockAddr
remote
     -- Make tempo mvar
     -- Listen to tempo changes
     IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ UDP -> MVar Tempo -> IO ()
listenTempo UDP
local MVar Tempo
tempoMV

sendTempo :: Tempo -> IO ()
sendTempo :: Tempo -> IO ()
sendTempo Tempo
tempo = UDP -> Packet -> SockAddr -> IO ()
O.sendTo (Tempo -> UDP
localUDP Tempo
tempo) (Time -> [Message] -> Packet
O.p_bundle (Tempo -> Time
atTime Tempo
tempo) [Message
m]) (Tempo -> SockAddr
remoteAddr Tempo
tempo)
  where m :: Message
m = String -> [Datum] -> Message
O.Message String
"/transmit/cps/cycle" [Float -> Datum
O.Float (Float -> Datum) -> Float -> Datum
forall a b. (a -> b) -> a -> b
$ Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Rational -> Float) -> Rational -> Float
forall a b. (a -> b) -> a -> b
$ Tempo -> Rational
atCycle Tempo
tempo,
                                             Float -> Datum
O.Float (Float -> Datum) -> Float -> Datum
forall a b. (a -> b) -> a -> b
$ Time -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Time -> Float) -> Time -> Float
forall a b. (a -> b) -> a -> b
$ Tempo -> Time
cps Tempo
tempo,
                                             Int32 -> Datum
O.Int32 (Int32 -> Datum) -> Int32 -> Datum
forall a b. (a -> b) -> a -> b
$ if Tempo -> Bool
paused Tempo
tempo then Int32
1 else Int32
0
                                            ]

listenTempo :: O.UDP -> MVar Tempo -> IO ()
listenTempo :: UDP -> MVar Tempo -> IO ()
listenTempo UDP
udp MVar Tempo
tempoMV = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Packet
pkt <- UDP -> IO Packet
forall t. Transport t => t -> IO Packet
O.recvPacket UDP
udp
                                       Maybe Time -> Packet -> IO ()
act Maybe Time
forall a. Maybe a
Nothing Packet
pkt
                                       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where act :: Maybe Time -> Packet -> IO ()
act Maybe Time
_ (O.Packet_Bundle (O.Bundle Time
ts [Message]
ms)) = (Message -> IO ()) -> [Message] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Time -> Packet -> IO ()
act (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
ts) (Packet -> IO ()) -> (Message -> Packet) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Packet
O.Packet_Message) [Message]
ms
        act (Just Time
ts) (O.Packet_Message (O.Message String
"/cps/cycle" [O.Float Float
atCycle',
                                                                 O.Float Float
cps',
                                                                 O.Int32 Int32
paused'
                                                                ]
                                        )
                      ) =
          do Tempo
tempo <- MVar Tempo -> IO Tempo
forall a. MVar a -> IO a
takeMVar MVar Tempo
tempoMV
             MVar Tempo -> Tempo -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Tempo
tempoMV (Tempo -> IO ()) -> Tempo -> IO ()
forall a b. (a -> b) -> a -> b
$ Tempo
tempo {atTime :: Time
atTime = Time
ts,
                                      atCycle :: Rational
atCycle = Float -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
atCycle',
                                      cps :: Time
cps = Float -> Time
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
cps',
                                      paused :: Bool
paused = Int32
paused' Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
1,
                                      synched :: Bool
synched = Bool
True
                                     }
        act Maybe Time
_ Packet
pkt = String -> IO ()
writeError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown packet (client): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Packet -> String
forall a. Show a => a -> String
show Packet
pkt

serverListen :: Config -> IO (Maybe ThreadId)
serverListen :: Config -> IO (Maybe ThreadId)
serverListen Config
config = IO (Maybe ThreadId)
-> (SomeException -> IO (Maybe ThreadId)) -> IO (Maybe ThreadId)
forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny IO (Maybe ThreadId)
run (\SomeException
_ -> Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThreadId
forall a. Maybe a
Nothing) -- probably just already running)
  where run :: IO (Maybe ThreadId)
run = do let port :: Int
port = Config -> Int
cTempoPort Config
config
                 -- iNADDR_ANY deprecated - what's the right way to do this?
                 UDP
udp <- String -> Int -> IO UDP
O.udpServer String
"0.0.0.0" Int
port
                 Packet
cpsMessage <- IO Packet
defaultCpsMessage
                 ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ UDP -> ([SockAddr], Packet) -> IO ()
forall b. UDP -> ([SockAddr], Packet) -> IO b
loop UDP
udp ([], Packet
cpsMessage)
                 Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ThreadId -> IO (Maybe ThreadId))
-> Maybe ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
tid
        loop :: UDP -> ([SockAddr], Packet) -> IO b
loop UDP
udp ([SockAddr]
cs, Packet
msg) = do (Packet
pkt,SockAddr
c) <- UDP -> IO (Packet, SockAddr)
O.recvFrom UDP
udp
                                ([SockAddr]
cs', Packet
msg') <- UDP
-> SockAddr
-> Maybe Time
-> ([SockAddr], Packet)
-> Packet
-> IO ([SockAddr], Packet)
act UDP
udp SockAddr
c Maybe Time
forall a. Maybe a
Nothing ([SockAddr]
cs,Packet
msg) Packet
pkt
                                UDP -> ([SockAddr], Packet) -> IO b
loop UDP
udp ([SockAddr]
cs', Packet
msg')
        act :: O.UDP -> N.SockAddr -> Maybe O.Time -> ([N.SockAddr], O.Packet) -> O.Packet -> IO ([N.SockAddr], O.Packet)
        act :: UDP
-> SockAddr
-> Maybe Time
-> ([SockAddr], Packet)
-> Packet
-> IO ([SockAddr], Packet)
act UDP
udp SockAddr
c Maybe Time
_ ([SockAddr]
cs,Packet
msg) (O.Packet_Bundle (O.Bundle Time
ts [Message]
ms)) = (([SockAddr], Packet) -> Packet -> IO ([SockAddr], Packet))
-> ([SockAddr], Packet) -> [Packet] -> IO ([SockAddr], Packet)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UDP
-> SockAddr
-> Maybe Time
-> ([SockAddr], Packet)
-> Packet
-> IO ([SockAddr], Packet)
act UDP
udp SockAddr
c (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
ts)) ([SockAddr]
cs,Packet
msg) ([Packet] -> IO ([SockAddr], Packet))
-> [Packet] -> IO ([SockAddr], Packet)
forall a b. (a -> b) -> a -> b
$ (Message -> Packet) -> [Message] -> [Packet]
forall a b. (a -> b) -> [a] -> [b]
map Message -> Packet
O.Packet_Message [Message]
ms
        act UDP
udp SockAddr
c Maybe Time
_ ([SockAddr]
cs,Packet
msg) (O.Packet_Message (O.Message String
"/hello" []))
          = do UDP -> Packet -> SockAddr -> IO ()
O.sendTo UDP
udp Packet
msg SockAddr
c
               ([SockAddr], Packet) -> IO ([SockAddr], Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SockAddr] -> [SockAddr]
forall a. Eq a => [a] -> [a]
nub (SockAddr
cSockAddr -> [SockAddr] -> [SockAddr]
forall a. a -> [a] -> [a]
:[SockAddr]
cs),Packet
msg)
        act UDP
udp SockAddr
_ (Just Time
ts) ([SockAddr]
cs,Packet
_) (O.Packet_Message (O.Message String
"/transmit/cps/cycle" [Datum]
params)) =
          do let path' :: String
path' = String
"/cps/cycle"
                 msg' :: Packet
msg' = Time -> [Message] -> Packet
O.p_bundle Time
ts [String -> [Datum] -> Message
O.Message String
path' [Datum]
params]
             (SockAddr -> IO ()) -> [SockAddr] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UDP -> Packet -> SockAddr -> IO ()
O.sendTo UDP
udp Packet
msg') [SockAddr]
cs
             ([SockAddr], Packet) -> IO ([SockAddr], Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SockAddr]
cs, Packet
msg')
        act UDP
_ SockAddr
x Maybe Time
_ ([SockAddr]
cs,Packet
msg) Packet
pkt = do String -> IO ()
writeError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown packet (serv): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Packet -> String
forall a. Show a => a -> String
show Packet
pkt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" / " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
x
                                    ([SockAddr], Packet) -> IO ([SockAddr], Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SockAddr]
cs,Packet
msg)
        catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
        catchAny :: IO a -> (SomeException -> IO a) -> IO a
catchAny = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
        defaultCpsMessage :: IO Packet
defaultCpsMessage = do Time
ts <- IO Time
forall (m :: * -> *). MonadIO m => m Time
O.time
                               Packet -> IO Packet
forall (m :: * -> *) a. Monad m => a -> m a
return (Packet -> IO Packet) -> Packet -> IO Packet
forall a b. (a -> b) -> a -> b
$ Time -> [Message] -> Packet
O.p_bundle Time
ts [String -> [Datum] -> Message
O.Message String
"/cps/cycle" [Float -> Datum
O.Float Float
0,
                                                                               Float -> Datum
O.Float (Float -> Datum) -> Float -> Datum
forall a b. (a -> b) -> a -> b
$ Time -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
defaultCps,
                                                                               Int32 -> Datum
O.Int32 Int32
0
                                                                              ]
                                                    ]