module MiniLight.Component (
  HookMap,
  HasComponentEnv(..),
  ComponentEnv(..),
  emit,
  emitGlobally,

  ComponentUnit(..),
  Component,
  _unsafeAs,
  newComponent,
  getComponentSize,
  getUID,
  getHooks,
  setHooks,
  propagate,
) where

import Control.Lens
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef
import qualified Data.Text as T
import MiniLight.Light
import MiniLight.Event
import MiniLight.Figure
import qualified SDL
import Unsafe.Coerce

type HookMap = HM.HashMap T.Text (T.Text, Object -> Value)

-- | Environmental information, which are passed for each component
data ComponentEnv = ComponentEnv {
  ComponentEnv -> Text
uid :: T.Text,  -- ^ The unique id
  ComponentEnv -> Maybe HookMap
callbacks :: Maybe HookMap  -- ^ The hooks
}

makeClassy_ ''ComponentEnv

-- | Emit a signal, which will be catched at the next frame.
emit
  :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et)
  => Maybe T.Text  -- ^ target component ID
  -> et
  -> LightT env m ()
emit :: Maybe Text -> et -> LightT env m ()
emit target :: Maybe Text
target et :: et
et = do
  Text
uid <- Getting Text env Text -> LightT env m Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text env Text
forall c. HasComponentEnv c => Lens' c Text
_uid
  IORef [Event]
ref <- Getting (IORef [Event]) env (IORef [Event])
-> LightT env m (IORef [Event])
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef [Event]) env (IORef [Event])
forall c. HasLoopEnv c => Lens' c (IORef [Event])
_signalQueue
  IO () -> LightT env m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LightT env m ()) -> IO () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ IORef [Event] -> ([Event] -> [Event]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Event]
ref (([Event] -> [Event]) -> IO ()) -> ([Event] -> [Event]) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Text -> et -> Event
forall a. EventType a => Text -> Maybe Text -> a -> Event
signal Text
uid Maybe Text
target et
et Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)

  Maybe HookMap
hs <- Getting (Maybe HookMap) env (Maybe HookMap)
-> LightT env m (Maybe HookMap)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe HookMap) env (Maybe HookMap)
forall c. HasComponentEnv c => Lens' c (Maybe HookMap)
_callbacks
  case Text -> HookMap -> Maybe (Text, Object -> Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (et -> Text
forall e. EventType e => e -> Text
getEventType et
et) (HookMap -> Maybe (Text, Object -> Value))
-> Maybe HookMap -> Maybe (Text, Object -> Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe HookMap
hs of
    Just (name :: Text
name, param :: Object -> Value
param) -> IO () -> LightT env m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LightT env m ()) -> IO () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ IORef [Event] -> ([Event] -> [Event]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef'
      IORef [Event]
ref
      (Text -> Maybe Text -> EventData -> Event
forall a. EventType a => Text -> Maybe Text -> a -> Event
signal Text
uid Maybe Text
forall a. Maybe a
Nothing (Text -> Value -> EventData
EventData Text
name (Object -> Value
param (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ et -> Object
forall e. EventType e => e -> Object
getEventProperties et
et)) Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    Nothing -> () -> LightT env m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Emit a signal globally.
emitGlobally
  :: (HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et)
  => et
  -> LightT env m ()
emitGlobally :: et -> LightT env m ()
emitGlobally = Maybe Text -> et -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
Maybe Text -> et -> LightT env m ()
emit Maybe Text
forall a. Maybe a
Nothing

-- | CompoonentUnit typeclass provides a way to define a new component.
-- Any 'ComponentUnit' instance can be embedded into 'Component' type.
class ComponentUnit c where
  -- | Updating a model.
  update :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => c -> LightT env m c
  update = c -> LightT env m c
forall (m :: * -> *) a. Monad m => a -> m a
return

  -- | Descirbes a view. The figures here would be cached. See also 'useCache' for the cache configuration.
  figures :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure]

  -- | Drawing a figures.
  draw :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m ()
  draw comp :: c
comp = MiniLight () -> LightT env m ()
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight (MiniLight () -> LightT env m ())
-> ([Figure] -> MiniLight ()) -> [Figure] -> LightT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Figure] -> MiniLight ()
forall env (m :: * -> *).
(HasLightEnv env, MonadIO m, MonadMask m) =>
[Figure] -> LightT env m ()
renders ([Figure] -> LightT env m ())
-> LightT env m [Figure] -> LightT env m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures c
comp
  {-# INLINE draw #-}

  -- | Event handlers
  onSignal :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c
  onSignal _ = c -> LightT env m c
forall (m :: * -> *) a. Monad m => a -> m a
return

  -- | Return @True@ if a cache stored in the previous frame should be used.
  useCache
    :: c  -- ^ A model value in the previous frame
    -> c  -- ^ A model value in the current frame
    -> Bool
  useCache _ _ = Bool
False

  -- | To be called just before clearing caches.
  -- If you want to destroy cached textures for memory efficiency, override this method.
  --
  -- __NB__: Freeing SDL textures and figures are not performed automatically. You must call 'freeFigure' at your own risk.
  beforeClearCache :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> [Figure] -> LightT env m ()
  beforeClearCache _ _ = () -> LightT env m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | A wrapper for 'ComponentUnit' instances.
data Component = forall c. ComponentUnit c => Component {
  Component -> Text
uidOf :: T.Text,
  ()
component :: c,
  ()
prev :: c,
  Component -> IORef [Figure]
cache :: IORef [Figure],
  Component -> Maybe HookMap
callbackObject :: Maybe HookMap
}

-- | Unsafe coercing the component
_unsafeAs :: (ComponentUnit c) => Lens' Component c
_unsafeAs :: Lens' Component c
_unsafeAs = (Component -> c)
-> (Component -> c -> Component) -> Lens' Component c
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
  (\(Component _ c :: c
c _ _ _) -> c -> c
forall a b. a -> b
unsafeCoerce c
c)
  (\(Component a :: Text
a _ c :: c
c d :: IORef [Figure]
d e :: Maybe HookMap
e) b :: c
b -> Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component Text
a (c -> c
forall a b. a -> b
unsafeCoerce c
b) c
c IORef [Figure]
d Maybe HookMap
e)

-- | Create a new component.
newComponent
  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)
  => T.Text
  -> c
  -> LightT env m Component
newComponent :: Text -> c -> LightT env m Component
newComponent uid :: Text
uid c :: c
c = do
  [Figure]
figs <- c -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures c
c
  IORef [Figure]
ref  <- IO (IORef [Figure]) -> LightT env m (IORef [Figure])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [Figure]) -> LightT env m (IORef [Figure]))
-> IO (IORef [Figure]) -> LightT env m (IORef [Figure])
forall a b. (a -> b) -> a -> b
$ [Figure] -> IO (IORef [Figure])
forall a. a -> IO (IORef a)
newIORef [Figure]
figs
  Component -> LightT env m Component
forall (m :: * -> *) a. Monad m => a -> m a
return (Component -> LightT env m Component)
-> Component -> LightT env m Component
forall a b. (a -> b) -> a -> b
$ $WComponent :: forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component
    { uidOf :: Text
uidOf          = Text
uid
    , component :: c
component      = c
c
    , prev :: c
prev           = c
c
    , cache :: IORef [Figure]
cache          = IORef [Figure]
ref
    , callbackObject :: Maybe HookMap
callbackObject = Maybe HookMap
forall a. Maybe a
Nothing
    }

-- | Get the size of a component.
getComponentSize
  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)
  => c
  -> LightT env m (SDL.Rectangle Int)
getComponentSize :: c -> LightT env m (Rectangle Int)
getComponentSize comp :: c
comp = do
  [Figure]
figs <- c -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures c
comp
  Rectangle Int -> LightT env m (Rectangle Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle Int -> LightT env m (Rectangle Int))
-> Rectangle Int -> LightT env m (Rectangle Int)
forall a b. (a -> b) -> a -> b
$ (Rectangle Int -> Rectangle Int -> Rectangle Int)
-> Rectangle Int -> [Rectangle Int] -> Rectangle Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Rectangle Int -> Rectangle Int -> Rectangle Int
union (Point V2 Int -> V2 Int -> Rectangle Int
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (V2 Int -> Point V2 Int
forall (f :: * -> *) a. f a -> Point f a
SDL.P 0) 0) ([Rectangle Int] -> Rectangle Int)
-> [Rectangle Int] -> Rectangle Int
forall a b. (a -> b) -> a -> b
$ (Figure -> Rectangle Int) -> [Figure] -> [Rectangle Int]
forall a b. (a -> b) -> [a] -> [b]
map Figure -> Rectangle Int
targetArea [Figure]
figs

-- | Get its unique id.
getUID :: Component -> T.Text
getUID :: Component -> Text
getUID (Component uid :: Text
uid _ _ _ _) = Text
uid

-- | Get the hooks
getHooks :: Component -> Maybe HookMap
getHooks :: Component -> Maybe HookMap
getHooks (Component _ _ _ _ h :: Maybe HookMap
h) = Maybe HookMap
h

-- | Get the hooks
setHooks :: Component -> Maybe HookMap -> Component
setHooks :: Component -> Maybe HookMap -> Component
setHooks (Component uid :: Text
uid comp :: c
comp prev :: c
prev cache :: IORef [Figure]
cache _) h :: Maybe HookMap
h = Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component Text
uid c
comp c
prev IORef [Figure]
cache Maybe HookMap
h

-- | Clear the previous model cache and reflect the current model.
propagate :: Component -> Component
propagate :: Component -> Component
propagate (Component uid :: Text
uid comp :: c
comp _ cache :: IORef [Figure]
cache h :: Maybe HookMap
h) = Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component Text
uid c
comp c
comp IORef [Figure]
cache Maybe HookMap
h

instance ComponentUnit Component where
  update :: Component -> LightT env m Component
update (Component uid :: Text
uid comp :: c
comp prev :: c
prev cache :: IORef [Figure]
cache h :: Maybe HookMap
h) = do
    c
comp' <- c -> LightT env m c
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, HasLoopEnv env,
 HasComponentEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m c
update c
comp
    Component -> LightT env m Component
forall (m :: * -> *) a. Monad m => a -> m a
return (Component -> LightT env m Component)
-> Component -> LightT env m Component
forall a b. (a -> b) -> a -> b
$ Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component Text
uid c
comp' c
prev IORef [Figure]
cache Maybe HookMap
h

  figures :: Component -> LightT env m [Figure]
figures (Component _ comp :: c
comp _ _ _) = c -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures c
comp

  draw :: Component -> LightT env m ()
draw (Component _ comp :: c
comp prev :: c
prev ref :: IORef [Figure]
ref _) = do
    if c -> c -> Bool
forall c. ComponentUnit c => c -> c -> Bool
useCache c
prev c
comp
      then MiniLight () -> LightT env m ()
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight (MiniLight () -> LightT env m ())
-> ([Figure] -> MiniLight ()) -> [Figure] -> LightT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Figure] -> MiniLight ()
forall env (m :: * -> *).
(HasLightEnv env, MonadIO m, MonadMask m) =>
[Figure] -> LightT env m ()
renders ([Figure] -> LightT env m ())
-> LightT env m [Figure] -> LightT env m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Figure] -> LightT env m [Figure]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [Figure] -> IO [Figure]
forall a. IORef a -> IO a
readIORef IORef [Figure]
ref)
      else do
        [Figure]
figs <- IO [Figure] -> LightT env m [Figure]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [Figure] -> IO [Figure]
forall a. IORef a -> IO a
readIORef IORef [Figure]
ref)
        c -> [Figure] -> LightT env m ()
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> [Figure] -> LightT env m ()
beforeClearCache c
comp [Figure]
figs

        [Figure]
figs <- c -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures c
comp
        MiniLight () -> LightT env m ()
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight (MiniLight () -> LightT env m ())
-> MiniLight () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ [Figure] -> MiniLight ()
forall env (m :: * -> *).
(HasLightEnv env, MonadIO m, MonadMask m) =>
[Figure] -> LightT env m ()
renders [Figure]
figs
        IO () -> LightT env m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LightT env m ()) -> IO () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ IORef [Figure] -> [Figure] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Figure]
ref [Figure]
figs

  onSignal :: Event -> Component -> LightT env m Component
onSignal ev :: Event
ev (Component uid :: Text
uid comp :: c
comp prev :: c
prev cache :: IORef [Figure]
cache h :: Maybe HookMap
h) = (c -> Component) -> LightT env m c -> LightT env m Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\comp' :: c
comp' -> Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
forall c.
ComponentUnit c =>
Text -> c -> c -> IORef [Figure] -> Maybe HookMap -> Component
Component Text
uid c
comp' c
prev IORef [Figure]
cache Maybe HookMap
h) (LightT env m c -> LightT env m Component)
-> LightT env m c -> LightT env m Component
forall a b. (a -> b) -> a -> b
$ Event -> c -> LightT env m c
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, HasLoopEnv env,
 HasComponentEnv env, MonadIO m, MonadMask m) =>
Event -> c -> LightT env m c
onSignal Event
ev c
comp