-- TODO remove when `OverloadedRecordUpdate` is fully implemented (and simplify some nested updates) - hopefully 9.4
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- | Rather than interacting with any bulbs, simulate interactions by printing to a terminal.
module Lifx.Lan.Mock.Terminal (Mock, MockError, runMock, runMockFull, MockState (MockState)) where

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 = (.label) -- TODO this is a GHC bug: https://gitlab.haskell.org/ghc/ghc/-/issues/21226
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

{- | Run a LIFX action by mocking effects in a terminal.

Note that sending some messages (e.g. 'GetVersion') will throw exceptions, since the necessary state isn't specified.
See `runMockFull` for more control.
-}
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)

-- | More general version of `runMock`, which allows specifying extra information about devices.
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