{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

-- | This module implements the patch algorithm for containers.
module GI.Gtk.Declarative.Container.Patch
  ( IsContainer(..)
  , patchInContainer
  )
where

import           Data.Foldable                  ( foldMap )
import           Data.Vector                    ( Vector
                                                , (!?)
                                                )
import qualified Data.Vector                   as Vector
import qualified GI.Gtk                        as Gtk

import           GI.Gtk.Declarative.Container.Class
import           GI.Gtk.Declarative.Patch
import           GI.Gtk.Declarative.State

-- | Patch all children in a container. This does not feature any ID checking,
-- as seen in React, so reordering children in a container can produce many
-- updates.
patchInContainer
  :: ( Gtk.IsWidget container
     , Gtk.IsContainer container
     , Patchable child
     , IsContainer container child
     )
  => StateTree 'ContainerState container child event cs
  -> container
  -> Vector (child e1)
  -> Vector (child e2)
  -> IO (StateTree 'ContainerState container child event cs)
patchInContainer :: StateTree 'ContainerState container child event cs
-> container
-> Vector (child e1)
-> Vector (child e2)
-> IO (StateTree 'ContainerState container child event cs)
patchInContainer (StateTreeContainer top :: StateTreeNode container event cs
top children :: Vector SomeState
children) container :: container
container os' :: Vector (child e1)
os' ns' :: Vector (child e2)
ns' = do
  let maxLength :: Int
maxLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Vector SomeState -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector SomeState
children, Vector (child e1) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (child e1)
os', Vector (child e2) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (child e2)
ns'] :: [Int])
      indices :: Vector Int32
indices   = Int32 -> Int -> Vector Int32
forall a. Num a => a -> Int -> Vector a
Vector.enumFromN 0 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLength)
  Vector SomeState
newChildren <- ((Int32, Maybe SomeState, Maybe (child e1), Maybe (child e2))
 -> IO (Vector SomeState))
-> Vector
     (Int32, Maybe SomeState, Maybe (child e1), Maybe (child e2))
-> IO (Vector SomeState)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
    (Int32, Maybe SomeState, Maybe (child e1), Maybe (child e2))
-> IO (Vector SomeState)
go
    (Vector Int32
-> Vector (Maybe SomeState)
-> Vector (Maybe (child e1))
-> Vector (Maybe (child e2))
-> Vector
     (Int32, Maybe SomeState, Maybe (child e1), Maybe (child e2))
forall a b c d.
Vector a -> Vector b -> Vector c -> Vector d -> Vector (a, b, c, d)
Vector.zip4 Vector Int32
indices
                 (Int -> Vector SomeState -> Vector (Maybe SomeState)
forall a. Int -> Vector a -> Vector (Maybe a)
padMaybes Int
maxLength Vector SomeState
children)
                 (Int -> Vector (child e1) -> Vector (Maybe (child e1))
forall a. Int -> Vector a -> Vector (Maybe a)
padMaybes Int
maxLength Vector (child e1)
os')
                 (Int -> Vector (child e2) -> Vector (Maybe (child e2))
forall a. Int -> Vector a -> Vector (Maybe a)
padMaybes Int
maxLength Vector (child e2)
ns')
    )

  container -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetQueueResize container
container
  StateTree 'ContainerState container child event cs
-> IO (StateTree 'ContainerState container child event cs)
forall (m :: * -> *) a. Monad m => a -> m a
return (StateTreeNode container event cs
-> Vector SomeState
-> StateTree 'ContainerState container child event cs
forall widget (child :: * -> *) event customState.
(IsContainer widget, IsContainer widget child) =>
StateTreeNode widget event customState
-> Vector SomeState
-> StateTree 'ContainerState widget child event customState
StateTreeContainer StateTreeNode container event cs
top Vector SomeState
newChildren)
 where
  go :: (Int32, Maybe SomeState, Maybe (child e1), Maybe (child e2))
-> IO (Vector SomeState)
go = \case
    -- In case we have a corresponding old and new declarative widget, we patch
    -- the GTK widget.
    (i :: Int32
i, Just oldChildState :: SomeState
oldChildState, Just old :: child e1
old, Just new :: child e2
new) ->
      case SomeState -> child e1 -> child e2 -> Patch
forall (widget :: * -> *) e1 e2.
Patchable widget =>
SomeState -> widget e1 -> widget e2 -> Patch
patch SomeState
oldChildState child e1
old child e2
new of
        Modify  modify :: IO SomeState
modify       -> SomeState -> Vector SomeState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeState -> Vector SomeState)
-> IO SomeState -> IO (Vector SomeState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SomeState
modify
        Replace createWidget :: IO SomeState
createWidget -> do
          SomeState
newChildState  <- IO SomeState
createWidget
          Widget
oldChildWidget <- SomeState -> IO Widget
someStateWidget SomeState
oldChildState
          Widget
newChildWidget <- SomeState -> IO Widget
someStateWidget SomeState
newChildState
          container -> child e2 -> Int32 -> Widget -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Int32 -> Widget -> Widget -> IO ()
replaceChild container
container child e2
new Int32
i Widget
oldChildWidget Widget
newChildWidget
          Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState -> Vector SomeState
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeState
newChildState)
        Keep -> Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState -> Vector SomeState
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeState
oldChildState)

    -- When there is a new declarative widget, but there already exists a GTK
    -- widget in the corresponding place, we need to replace the GTK widget with
    -- one created from the declarative widget.
    (i :: Int32
i, Just oldChildState :: SomeState
oldChildState, Nothing, Just new :: child e2
new) -> do
      SomeState
newChildState  <- child e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create child e2
new
      Widget
oldChildWidget <- SomeState -> IO Widget
someStateWidget SomeState
oldChildState
      Widget
newChildWidget <- SomeState -> IO Widget
someStateWidget SomeState
newChildState
      container -> child e2 -> Int32 -> Widget -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Int32 -> Widget -> Widget -> IO ()
replaceChild container
container child e2
new Int32
i Widget
oldChildWidget Widget
newChildWidget
      Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState -> Vector SomeState
forall a. a -> Vector a
Vector.singleton SomeState
newChildState)

    -- When there is a new declarative widget, or one that lacks a corresponding
    -- GTK widget, create and add it.
    (_i :: Int32
_i, Nothing, _, Just n :: child e2
n) -> do
      SomeState
newChildState <- child e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create child e2
n
      Widget
w             <- SomeState -> IO Widget
someStateWidget SomeState
newChildState
      container -> child e2 -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Widget -> IO ()
appendChild container
container child e2
n Widget
w
      Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState -> Vector SomeState
forall a. a -> Vector a
Vector.singleton SomeState
newChildState)

    -- When a declarative widget has been removed, remove the GTK widget from
    -- the container.
    (_i :: Int32
_i, Just childState :: SomeState
childState, Just _, Nothing) -> do
      Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
childState
      Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector SomeState
forall a. Vector a
Vector.empty

    -- When there are more old declarative widgets than GTK widgets, we can
    -- safely ignore the old declarative widgets.
    (_i :: Int32
_i, Nothing        , Just _ , Nothing) -> Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector SomeState
forall a. Vector a
Vector.empty

    -- But, when there are stray GTK widgets without corresponding
    -- declarative widgets, something has gone wrong, and we clean that up by
    -- removing the GTK widgets.
    (_i :: Int32
_i, Just childState :: SomeState
childState, Nothing, Nothing) -> do
      Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
childState
      Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector SomeState
forall a. Vector a
Vector.empty

    -- No more GTK widgets or declarative widgets, we are done.
    (_i :: Int32
_i, Nothing, Nothing, Nothing) -> Vector SomeState -> IO (Vector SomeState)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector SomeState
forall a. Vector a
Vector.empty

padMaybes :: Int -> Vector a -> Vector (Maybe a)
padMaybes :: Int -> Vector a -> Vector (Maybe a)
padMaybes len :: Int
len xs :: Vector a
xs = Int -> (Int -> Maybe a) -> Vector (Maybe a)
forall a. Int -> (Int -> a) -> Vector a
Vector.generate Int
len (Vector a
xs Vector a -> Int -> Maybe a
forall a. Vector a -> Int -> Maybe a
!?)