Add sendMessageAndWait

Author: georgefst

CHANGELOG.md

@@ -6,6 +6,7 @@
 - Don't provide field selector functions for any types. Using `OverloadedRecordDot` in client code is recommended. We still export `unLifxT` as a normal function, for backward compatibility.
 - Move much of the implementation detail of `LifxT` has been moved to `Lifx.Lan.Internal`.
 - Add `Lifx.Lan.Mock.Terminal` module for testing programs without a physical LIFX device.
+- Add `sendMessageAndWait` function.
 - Use `Text` rather than `ByteString` for `label` field of `LightState`.
 - Rename `productId` field of `Product` to `id`.
 - Update to latest products list.

src/Lifx/Lan.hs

@@ -31,6 +31,7 @@ module Lifx.Lan (
     LifxError (..),
     ProductLookupError (..),
     MonadLifx (..),
+    sendMessageAndWait,
 
     -- * Responses
     StateService (..),
@@ -53,6 +54,7 @@ module Lifx.Lan (
     Header (..),
 ) where
 
+import Control.Concurrent
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Extra
@@ -65,6 +67,7 @@ import Data.Fixed
 import Data.Foldable
 import Data.Functor
 import Data.Maybe
+import Data.Proxy
 import Data.Time
 import Data.Word
 import Network.Socket
@@ -581,6 +584,22 @@ getProductInfo dev = do
     v <- sendMessage dev GetVersion
     either (lifxThrow . liftProductLookupError @m) pure $ productLookup v.vendor v.product versionMinor versionMajor
 
+{- Higher-level helpers -}
+
+{- | Like `sendMessage`, but for messages whose effect is not instantaneous (e.g. `SetColor`),
+block (using `threadDelay`) until completion.
+-}
+sendMessageAndWait :: (MonadLifx m, MonadIO m) => Device -> Message () -> m ()
+sendMessageAndWait d m = do
+    sendMessage d m
+    maybe (pure ()) (liftIO . threadDelay . timeMicros) mt
+  where
+    mt = case m of
+        SetPower{} -> Nothing
+        SetColor _ t -> Just t
+        SetLightPower _ t -> Just t
+    timeMicros t = round $ t * fromInteger (resolution $ Proxy @E6)
+
 {- Util -}
 
 fromIntegralSafe :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b