lifx-lan 0.7.1 → 0.8.0

raw patch · 7 files changed

+95/−19 lines, 7 filesdep ~basedep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• lifx-lan.cabal +1/−1
• src/Lifx/Internal/Colour.hs +12/−1
• src/Lifx/Internal/ProductInfo.hs +40/−0
• src/Lifx/Lan.hs +10/−0
• src/Lifx/Lan/Internal.hs +18/−0
• src/Lifx/Lan/Mock/Terminal.hs +9/−16

@@ -1,8 +1,12 @@ # Revision history for lifx-lan +## 0.8 -- 25-02-2023+- Various minor improvements to MTL interfaces.+- Update to latest products list+ ## 0.7.1 -- 21-10-2022 - Handle invalid UTF-8 in light label.-- Ensure discovery exits successfully when zero devices wanted+- Ensure discovery exits successfully when zero devices are wanted.  ## 0.7 -- 2022-02-20 - Drop support for GHC < 9.2.

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.7.1+version:            0.8.0 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas

@@ -6,13 +6,14 @@ import Data.Word  import Data.Colour.RGBSpace.HSV (hsv)+import Data.Colour.RGBSpace.HSV qualified as HSV  import Lifx.Lan.Internal  {- | Note that when 'kelvin' has an effect (i.e. when saturation is any less than maximum), output is somewhat arbitrary. -LIFX's team have never shared an exact forumla, and this implementation is inspired by various conflicting sources.+LIFX's team have never shared an exact formula, and this implementation is inspired by various conflicting sources. -} hsbkToRgb :: HSBK -> RGB Float hsbkToRgb HSBK{..} =@@ -36,6 +37,16 @@                     , channelGreen = t / 2 + 0.5                     , channelBlue = t                     }++-- | Kelvin in output is always 0.+rgbToHsbk :: RGB Float -> HSBK+rgbToHsbk c =+    HSBK+        { hue = floor $ HSV.hue c * fromIntegral (maxBound @Word16 `div` 360)+        , saturation = floor $ HSV.saturation c * fromIntegral (maxBound @Word16)+        , brightness = floor $ HSV.value c * fromIntegral (maxBound @Word16)+        , kelvin = 0+        }  interpolateColour :: Num a => a -> RGB a -> RGB a -> RGB a interpolateColour r = liftA2 (\a b -> a * (r + b * (1 - r)))

@@ -1779,6 +1779,46 @@                 , upgrades = []                 }             , ProductInfo+                { pid = 121+                , name = "LIFX Downlight Intl"+                , features = PartialFeatures+                    { hev = Nothing+                    , color = Just True+                    , chain = Just False+                    , matrix = Just False+                    , relays = Nothing+                    , buttons = Nothing+                    , infrared = Just False+                    , multizone = Just False+                    , temperatureRange = Just+                        ( 1500+                        , 9000+                        )+                    , extendedMultizone = Nothing+                    }+                , upgrades = []+                }+            , ProductInfo+                { pid = 122+                , name = "LIFX Downlight US"+                , features = PartialFeatures+                    { hev = Nothing+                    , color = Just True+                    , chain = Just False+                    , matrix = Just False+                    , relays = Nothing+                    , buttons = Nothing+                    , infrared = Just False+                    , multizone = Just False+                    , temperatureRange = Just+                        ( 1500+                        , 9000+                        )+                    , extendedMultizone = Nothing+                    }+                , upgrades = []+                }+            , ProductInfo                 { pid = 123                 , name = "LIFX Color US"                 , features = PartialFeatures

@@ -8,6 +8,8 @@ import Control.Monad.IO.Class (liftIO) import Data.Foldable (for_) +import Lifx.Lan+ -- | Find all devices on the network, print their addresses, and set their brightness to 50%. main :: IO () main = runLifx do@@ -61,6 +63,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe+import Control.Monad.Writer hiding (Product) import Data.Composition import Data.Either.Extra import Data.Fixed@@ -424,6 +427,13 @@     lifxThrow = lift . lifxThrow instance MonadLifx m => MonadLifx (StateT s m) where     type MonadLifxError (StateT s m) = MonadLifxError m+    liftProductLookupError = liftProductLookupError @m+    sendMessage = lift .: sendMessage+    broadcastMessage = lift . broadcastMessage+    discoverDevices = lift . discoverDevices+    lifxThrow = lift . lifxThrow+instance (MonadLifx m, Monoid t) => MonadLifx (WriterT t m) where+    type MonadLifxError (WriterT t m) = MonadLifxError m     liftProductLookupError = liftProductLookupError @m     sendMessage = lift .: sendMessage     broadcastMessage = lift . broadcastMessage

@@ -1,3 +1,5 @@+{-# LANGUAGE UndecidableInstances #-}+ module Lifx.Lan.Internal where  import Control.Monad.Except@@ -90,6 +92,22 @@         , Monad         , MonadIO         )++instance MonadTrans LifxT where+    lift = LifxT . lift . lift . lift+instance MonadReader s m => MonadReader s (LifxT m) where+    ask = lift ask+    local f m = LifxT $ StateT \s -> ReaderT \e ->+        ExceptT $ local f $ unLifx e s m+instance MonadState s m => MonadState s (LifxT m) where+    state = lift . state+instance MonadError e m => MonadError e (LifxT m) where+    throwError = lift . throwError @e @m+    catchError m h = LifxT $ StateT \s -> ReaderT \e ->+        ExceptT $ catchError @e @m (unLifx e s m) (unLifx e s . h)++unLifx :: (Socket, Word32, Int) -> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))+unLifx e s = runExceptT . flip runReaderT e . flip runStateT s . (.unwrap)  {- Util -} 

@@ -27,9 +27,6 @@         , Applicative         , Monad         , MonadIO-        , MonadError MockError-        , MonadReader [Device]-        , MonadState (Map Device MockState)         )  data MockState = MockState@@ -39,10 +36,9 @@     , version :: Maybe StateVersion     } --- TODO this seems like a GHC bug dotLabel :: LightState -> Text--- dotLabel = (.label)-dotLabel = \LightState{..} -> label+-- dotLabel = (.label) -- TODO this is a GHC bug: https://gitlab.haskell.org/ghc/ghc/-/issues/21226+dotLabel LightState{..} = label  {- | Run a LIFX action by mocking effects in a terminal. @@ -72,12 +68,12 @@  instance MonadLifx Mock where     type MonadLifxError Mock = MockError-    lifxThrow = throwError+    lifxThrow = Mock . throwError     liftProductLookupError = MockProductLookupError      sendMessage d m = do         s <- lookupDevice d-        r <- case m of+        r <- Mock case m of             GetService -> whenProvided s.service             GetHostFirmware -> whenProvided s.hostFirmware             GetPower -> pure $ StatePower s.light.power@@ -86,7 +82,7 @@             GetColor -> pure s.light             SetColor hsbk _t -> modify $ Map.insert d s{light = s.light{hsbk}}             SetLightPower (convertPower -> power) _t -> modify $ Map.insert d s{light = s.light{power}}-        ds <- ask+        ds <- Mock ask         for_ ds \d' -> do             s' <- lookupDevice d'             liftIO do@@ -96,12 +92,9 @@         liftIO $ putStrLn ""         pure r       where-        lookupDevice = maybe (lifxThrow $ MockNoSuchDevice d) pure <=< gets . Map.lookup+        lookupDevice = maybe (lifxThrow $ MockNoSuchDevice d) pure <=< Mock . gets . Map.lookup         whenProvided = maybe (throwError MockDataNotProvided) pure         convertPower = fromIntegral . fromEnum-        mkSGR s =-            if s.power /= 0-                then [SetRGBColor Background . uncurryRGB sRGB $ hsbkToRgb s.hsbk]-                else []-    broadcastMessage m = ask >>= traverse \d -> (d,) <$> sendMessage d m-    discoverDevices x = maybe id take x <$> ask+        mkSGR s = [SetRGBColor Background . uncurryRGB sRGB $ hsbkToRgb s.hsbk | s.power /= 0]+    broadcastMessage m = Mock ask >>= traverse \d -> (d,) <$> sendMessage d m+    discoverDevices = Mock . asks . maybe id take