lifx-lan 0.5.1.1 → 0.6

raw patch · 3 files changed

+134/−106 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• lifx-lan.cabal +2/−1
• src/Lifx/Internal/ProductInfoMap.hs +127/−0
• src/Lifx/Lan.hs +5/−105

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.5.1.1+version:            0.6 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas@@ -18,6 +18,7 @@     exposed-modules:         Lifx.Internal.Product         Lifx.Internal.ProductInfo+        Lifx.Internal.ProductInfoMap         Lifx.Lan     hs-source-dirs: src     ghc-options:

@@ -0,0 +1,127 @@+module Lifx.Internal.ProductInfoMap where++import Control.Applicative+import Data.Either.Extra+import Data.Foldable hiding (product)+import Data.Function+import Data.Functor+import Data.Maybe+import Data.Tuple.Extra+import Data.Word++import Data.Map (Map, (!?))+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import GHC.Generics (Generic)++import Lifx.Internal.Product+import Lifx.Internal.ProductInfo++--TODO RecordDotSyntax can make this and other hiding unnecessary (we could also use "id" instead of "productId"...)+import Prelude hiding (product)++productInfoMap :: Map Word32 (Features, Map Word32 ProductInfo)+productInfoMap =+    Map.fromList $+        productInfo <&> \VendorInfo{..} ->+            ( vid+            ,+                ( defaults+                , Map.fromList $ (pid &&& id) <$> products+                )+            )++-- | Information about a particular LIFX product.+data Product = Product+    { name :: Text+    , productId :: Word32+    , features :: Features+    }+    deriving (Eq, Ord, Show, Generic)++data ProductLookupError+    = UnknownVendorId Word32+    | UnknownProductId Word32+    deriving (Eq, Ord, Show, Generic)++productLookup :: Word32 -> Word32 -> Word16 -> Word16 -> Either ProductLookupError Product+productLookup vendor product versionMinor versionMajor =+    case productInfoMap !? vendor of+        Nothing -> Left $ UnknownVendorId vendor+        Just (defaults, products) -> case products !? product of+            Nothing -> Left $ UnknownProductId product+            Just ProductInfo{features = originalFeatures, ..} ->+                pure+                    Product+                        { name+                        , productId = product+                        , features =+                            completeFeatures defaults $+                                foldl+                                    ( \old Upgrade{..} ->+                                        if (versionMajor, versionMinor) >= (major, minor)+                                            then addFeatures features old+                                            else old+                                    )+                                    originalFeatures+                                    upgrades+                        }+  where+    --TODO RecordDotSyntax+    completeFeatures+        Features+            { ..+            }+        PartialFeatures+            { hev = maybe_hev+            , color = maybe_color+            , chain = maybe_chain+            , matrix = maybe_matrix+            , relays = maybe_relays+            , buttons = maybe_buttons+            , infrared = maybe_infrared+            , multizone = maybe_multizone+            , temperatureRange = maybe_temperatureRange+            , extendedMultizone = maybe_extendedMultizone+            } =+            Features+                { hev = fromMaybe hev maybe_hev+                , color = fromMaybe color maybe_color+                , chain = fromMaybe chain maybe_chain+                , matrix = fromMaybe matrix maybe_matrix+                , relays = fromMaybe relays maybe_relays+                , buttons = fromMaybe buttons maybe_buttons+                , infrared = fromMaybe infrared maybe_infrared+                , multizone = fromMaybe multizone maybe_multizone+                , temperatureRange = maybe_temperatureRange <|> temperatureRange+                , extendedMultizone = fromMaybe extendedMultizone maybe_extendedMultizone+                }+    -- left-biased+    addFeatures+        PartialFeatures+            { ..+            }+        PartialFeatures+            { hev = old_hev+            , color = old_color+            , chain = old_chain+            , matrix = old_matrix+            , relays = old_relays+            , buttons = old_buttons+            , infrared = old_infrared+            , multizone = old_multizone+            , temperatureRange = old_temperatureRange+            , extendedMultizone = old_extendedMultizone+            } =+            PartialFeatures+                { hev = hev <|> old_hev+                , color = color <|> old_color+                , chain = chain <|> old_chain+                , matrix = matrix <|> old_matrix+                , relays = relays <|> old_relays+                , buttons = buttons <|> old_buttons+                , infrared = infrared <|> old_infrared+                , multizone = multizone <|> old_multizone+                , temperatureRange = temperatureRange <|> old_temperatureRange+                , extendedMultizone = extendedMultizone <|> old_extendedMultizone+                }

@@ -31,6 +31,7 @@     LifxT (LifxT),     runLifxT,     LifxError (..),+    ProductLookupError (..),     MonadLifx (..),      -- * Responses@@ -97,9 +98,8 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map, (!?))+import Data.Map (Map) import Data.Map.Strict qualified as Map-import Data.Text (Text) import Data.Time (     NominalDiffTime,     diffUTCTime,@@ -128,7 +128,7 @@ import System.Timeout (timeout)  import Lifx.Internal.Product-import Lifx.Internal.ProductInfo+import Lifx.Internal.ProductInfoMap  --TODO RecordDotSyntax can make this and other hiding unnecessary (we could also use "id" instead of "productId"...) import Prelude hiding (product)@@ -280,8 +280,7 @@     | WrongSender Device HostAddress -- expected, then actual     | UnexpectedSockAddrType SockAddr     | UnexpectedPort PortNumber-    | UnknownVendorId Word32-    | UnknownProductId Word32+    | ProductLookupError ProductLookupError     deriving (Eq, Ord, Show, Generic)  {- Message responses -}@@ -663,111 +662,12 @@         putWord16le if b then maxBound else minBound         putWord32le $ nominalDiffTimeToInt @Milli d -{- Product info -}--productInfoMap :: Map Word32 (Features, Map Word32 ProductInfo)-productInfoMap =-    Map.fromList $-        productInfo <&> \VendorInfo{..} ->-            ( vid-            ,-                ( defaults-                , Map.fromList $ (pid &&& id) <$> products-                )-            )---- | Information about a particular LIFX product.-data Product = Product-    { name :: Text-    , productId :: Word32-    , features :: Features-    }-    deriving (Eq, Ord, Show, Generic)- -- | Ask a device for its vendor and product ID, and look up info on it from the official database. getProductInfo :: MonadLifx m => Device -> m Product getProductInfo dev = do     StateHostFirmware{..} <- sendMessage dev GetHostFirmware     StateVersion{..} <- sendMessage dev GetVersion-    case productInfoMap !? vendor of-        Nothing -> lifxThrow $ UnknownVendorId vendor-        Just (defaults, products) -> case products !? product of-            Nothing -> lifxThrow $ UnknownProductId product-            Just ProductInfo{features = originalFeatures, ..} ->-                pure-                    Product-                        { name-                        , productId = product-                        , features =-                            completeFeatures defaults $-                                foldl-                                    ( \old Upgrade{..} ->-                                        if (versionMajor, versionMinor) >= (major, minor)-                                            then addFeatures features old-                                            else old-                                    )-                                    originalFeatures-                                    upgrades-                        }-  where-    --TODO RecordDotSyntax-    completeFeatures-        Features-            { ..-            }-        PartialFeatures-            { hev = maybe_hev-            , color = maybe_color-            , chain = maybe_chain-            , matrix = maybe_matrix-            , relays = maybe_relays-            , buttons = maybe_buttons-            , infrared = maybe_infrared-            , multizone = maybe_multizone-            , temperatureRange = maybe_temperatureRange-            , extendedMultizone = maybe_extendedMultizone-            } =-            Features-                { hev = fromMaybe hev maybe_hev-                , color = fromMaybe color maybe_color-                , chain = fromMaybe chain maybe_chain-                , matrix = fromMaybe matrix maybe_matrix-                , relays = fromMaybe relays maybe_relays-                , buttons = fromMaybe buttons maybe_buttons-                , infrared = fromMaybe infrared maybe_infrared-                , multizone = fromMaybe multizone maybe_multizone-                , temperatureRange = maybe_temperatureRange <|> temperatureRange-                , extendedMultizone = fromMaybe extendedMultizone maybe_extendedMultizone-                }-    -- left-biased-    addFeatures-        PartialFeatures-            { ..-            }-        PartialFeatures-            { hev = old_hev-            , color = old_color-            , chain = old_chain-            , matrix = old_matrix-            , relays = old_relays-            , buttons = old_buttons-            , infrared = old_infrared-            , multizone = old_multizone-            , temperatureRange = old_temperatureRange-            , extendedMultizone = old_extendedMultizone-            } =-            PartialFeatures-                { hev = hev <|> old_hev-                , color = color <|> old_color-                , chain = chain <|> old_chain-                , matrix = matrix <|> old_matrix-                , relays = relays <|> old_relays-                , buttons = buttons <|> old_buttons-                , infrared = infrared <|> old_infrared-                , multizone = multizone <|> old_multizone-                , temperatureRange = temperatureRange <|> old_temperatureRange-                , extendedMultizone = extendedMultizone <|> old_extendedMultizone-                }+    either (lifxThrow . ProductLookupError) pure $ productLookup vendor product versionMinor versionMajor  {- Util -}