{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
module Lifx.Lan.Mock.Terminal (Mock, MockError, runMock, runMockFull, MockState (MockState)) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.Colour.RGBSpace
import Data.Colour.SRGB
import Data.Foldable
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text.IO qualified as T
import System.Console.ANSI hiding (SetColor)
import Lifx.Internal.Colour
import Lifx.Lan
newtype Mock a = Mock (StateT (Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a)
deriving newtype
( forall a b. a -> Mock b -> Mock a
forall a b. (a -> b) -> Mock a -> Mock b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Mock b -> Mock a
$c<$ :: forall a b. a -> Mock b -> Mock a
fmap :: forall a b. (a -> b) -> Mock a -> Mock b
$cfmap :: forall a b. (a -> b) -> Mock a -> Mock b
Functor
, Functor Mock
forall a. a -> Mock a
forall a b. Mock a -> Mock b -> Mock a
forall a b. Mock a -> Mock b -> Mock b
forall a b. Mock (a -> b) -> Mock a -> Mock b
forall a b c. (a -> b -> c) -> Mock a -> Mock b -> Mock c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Mock a -> Mock b -> Mock a
$c<* :: forall a b. Mock a -> Mock b -> Mock a
*> :: forall a b. Mock a -> Mock b -> Mock b
$c*> :: forall a b. Mock a -> Mock b -> Mock b
liftA2 :: forall a b c. (a -> b -> c) -> Mock a -> Mock b -> Mock c
$cliftA2 :: forall a b c. (a -> b -> c) -> Mock a -> Mock b -> Mock c
<*> :: forall a b. Mock (a -> b) -> Mock a -> Mock b
$c<*> :: forall a b. Mock (a -> b) -> Mock a -> Mock b
pure :: forall a. a -> Mock a
$cpure :: forall a. a -> Mock a
Applicative
, Applicative Mock
forall a. a -> Mock a
forall a b. Mock a -> Mock b -> Mock b
forall a b. Mock a -> (a -> Mock b) -> Mock b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Mock a
$creturn :: forall a. a -> Mock a
>> :: forall a b. Mock a -> Mock b -> Mock b
$c>> :: forall a b. Mock a -> Mock b -> Mock b
>>= :: forall a b. Mock a -> (a -> Mock b) -> Mock b
$c>>= :: forall a b. Mock a -> (a -> Mock b) -> Mock b
Monad
, Monad Mock
forall a. IO a -> Mock a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Mock a
$cliftIO :: forall a. IO a -> Mock a
MonadIO
)
data MockState = MockState
{ MockState -> LightState
light :: LightState
, MockState -> Maybe StateService
service :: Maybe StateService
, MockState -> Maybe StateHostFirmware
hostFirmware :: Maybe StateHostFirmware
, MockState -> Maybe StateVersion
version :: Maybe StateVersion
}
dotLabel :: LightState -> Text
dotLabel :: LightState -> Text
dotLabel LightState{Word16
Text
HSBK
$sel:label:LightState :: LightState -> Text
$sel:power:LightState :: LightState -> Word16
$sel:hsbk:LightState :: LightState -> HSBK
label :: Text
power :: Word16
hsbk :: HSBK
..} = Text
label
runMock :: [(Device, Text)] -> Mock a -> IO (Either MockError a)
runMock :: forall a. [(Device, Text)] -> Mock a -> IO (Either MockError a)
runMock = forall a.
[(Device, MockState)] -> Mock a -> IO (Either MockError a)
runMockFull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Text
t -> LightState
-> Maybe StateService
-> Maybe StateHostFirmware
-> Maybe StateVersion
-> MockState
MockState (HSBK -> Word16 -> Text -> LightState
LightState (Word16 -> Word16 -> Word16 -> Word16 -> HSBK
HSBK Word16
0 Word16
0 Word16
0 Word16
0) Word16
1 Text
t) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
runMockFull :: [(Device, MockState)] -> Mock a -> IO (Either MockError a)
runMockFull :: forall a.
[(Device, MockState)] -> Mock a -> IO (Either MockError a)
runMockFull [(Device, MockState)]
ds (Mock StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
x) =
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
(forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Device, MockState)]
ds)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Device, MockState)]
ds)
forall a b. (a -> b) -> a -> b
$ StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
x
data MockError
= MockNoSuchDevice Device
| MockProductLookupError ProductLookupError
| MockDataNotProvided
deriving (Int -> MockError -> ShowS
[MockError] -> ShowS
MockError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MockError] -> ShowS
$cshowList :: [MockError] -> ShowS
show :: MockError -> String
$cshow :: MockError -> String
showsPrec :: Int -> MockError -> ShowS
$cshowsPrec :: Int -> MockError -> ShowS
Show)
instance MonadLifx Mock where
type MonadLifxError Mock = MockError
lifxThrow :: forall a. MonadLifxError Mock -> Mock a
lifxThrow = forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
liftProductLookupError :: ProductLookupError -> MonadLifxError Mock
liftProductLookupError = ProductLookupError -> MockError
MockProductLookupError
sendMessage :: forall r. Device -> Message r -> Mock r
sendMessage Device
d Message r
m = do
MockState
s <- Device -> Mock MockState
lookupDevice Device
d
r
r <- forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock case Message r
m of
Message r
GetService -> forall {f :: * -> *} {a}. MonadError MockError f => Maybe a -> f a
whenProvided MockState
s.service
Message r
GetHostFirmware -> forall {f :: * -> *} {a}. MonadError MockError f => Maybe a -> f a
whenProvided MockState
s.hostFirmware
Message r
GetPower -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word16 -> StatePower
StatePower MockState
s.light.power
SetPower (forall {b} {a}. (Num b, Enum a) => a -> b
convertPower -> Word16
power) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Device
d MockState
s{$sel:light:MockState :: LightState
light = MockState
s.light{Word16
power :: Word16
$sel:power:LightState :: Word16
power}}
Message r
GetVersion -> forall {f :: * -> *} {a}. MonadError MockError f => Maybe a -> f a
whenProvided MockState
s.version
Message r
GetColor -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MockState
s.light
SetColor HSBK
hsbk NominalDiffTime
_t -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Device
d MockState
s{$sel:light:MockState :: LightState
light = MockState
s.light{HSBK
hsbk :: HSBK
$sel:hsbk:LightState :: HSBK
hsbk}}
SetLightPower (forall {b} {a}. (Num b, Enum a) => a -> b
convertPower -> Word16
power) NominalDiffTime
_t -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Device
d MockState
s{$sel:light:MockState :: LightState
light = MockState
s.light{Word16
power :: Word16
$sel:power:LightState :: Word16
power}}
[Device]
ds <- forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock forall r (m :: * -> *). MonadReader r m => m r
ask
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Device]
ds \Device
d' -> do
MockState
s' <- Device -> Mock MockState
lookupDevice Device
d'
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
[SGR] -> IO ()
setSGR forall a b. (a -> b) -> a -> b
$ forall {a} {p}.
(Eq a, Num a, HasField "power" p a, HasField "hsbk" p HSBK) =>
p -> [SGR]
mkSGR MockState
s'.light
Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ LightState -> Text
dotLabel MockState
s'.light
[SGR] -> IO ()
setSGR []
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
where
lookupDevice :: Device -> Mock MockState
lookupDevice = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow forall a b. (a -> b) -> a -> b
$ Device -> MockError
MockNoSuchDevice Device
d) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
whenProvided :: Maybe a -> f a
whenProvided = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockError
MockDataNotProvided) forall (f :: * -> *) a. Applicative f => a -> f a
pure
convertPower :: a -> b
convertPower = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
mkSGR :: p -> [SGR]
mkSGR p
s = [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Background forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall a b. (a -> b) -> a -> b
$ HSBK -> RGB Float
hsbkToRgb p
s.hsbk | p
s.power forall a. Eq a => a -> a -> Bool
/= a
0]
broadcastMessage :: forall r. Message r -> Mock [(Device, r)]
broadcastMessage Message r
m = forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse \Device
d -> (Device
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage Device
d Message r
m
discoverDevices :: Maybe Int -> Mock [Device]
discoverDevices = forall a.
StateT
(Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a
-> Mock a
Mock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Int -> [a] -> [a]
take