{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Internal helpers for applying attributes and signal handlers to GTK+
-- widgets.
module GI.Gtk.Declarative.Attributes.Collected
  ( CollectedProperties
  , Collected(..)
  , canBeModifiedTo
  , collectAttributes
  , constructProperties
  , updateProperties
  , updateClasses
  )
where

import           Data.Foldable
import qualified Data.GI.Base.Attributes       as GI
import qualified Data.HashMap.Strict           as HashMap
import           Data.HashMap.Strict            ( HashMap )
import qualified Data.HashSet                  as HashSet
import qualified Data.Set                      as Set
import qualified Data.Text                     as Text
import           Data.Text                      ( Text )
import           Data.Typeable
import           Data.Vector                    ( Vector )
import           GHC.TypeLits
import qualified GI.Gtk                        as Gtk
import           GI.Gtk.Declarative.Attributes

-- | A collected property key/value pair, to be used when
-- settings properties when patching widgets.
data CollectedProperty widget where
  CollectedProperty ::( GI.AttrOpAllowed 'GI.AttrConstruct info widget,
      GI.AttrOpAllowed 'GI.AttrSet info widget,
      GI.AttrGetC info widget attr getValue,
      GI.AttrSetTypeConstraint info setValue,
      KnownSymbol attr,
      Typeable attr,
      Eq setValue,
      Typeable setValue
    ) =>
    GI.AttrLabelProxy attr ->
    setValue ->
    CollectedProperty widget

-- | A collected map of key/value pairs, where the type-level property
-- names are represented as 'Text' values. This is used to calculate
-- differences in old and new property sets when patching.
type CollectedProperties widget = HashMap Text (CollectedProperty widget)

-- | Checks if the 'old' collected properties are a subset of the 'new' ones,
-- and thus if a widget thus be updated or if it has to be recreated.
canBeModifiedTo
  :: CollectedProperties widget -> CollectedProperties widget -> Bool
old `canBeModifiedTo` new = Set.fromList (HashMap.keys old)
  `Set.isSubsetOf` Set.fromList (HashMap.keys new)

-- | All the collected properties and classes for a widget. These are based
-- on the 'Attribute' list in the declarative markup, but collected separately
-- into more efficient data structures, optimized for patching.
data Collected widget event
  = Collected
      { collectedClasses :: ClassSet,
        collectedProperties :: CollectedProperties widget
      }

instance Semigroup (Collected widget event) where
  c1 <> c2 = Collected (collectedClasses c1 <> collectedClasses c2)
                       (collectedProperties c1 <> collectedProperties c2)

instance Monoid (Collected widget event) where
  mempty = Collected mempty mempty

-- | Collect declarative markup attributes to the patching-optimized
-- 'Collected' data structure.
collectAttributes :: Vector (Attribute widget event) -> Collected widget event
collectAttributes = foldl' go mempty
 where
  go
    :: Collected widget event
    -> Attribute widget event
    -> Collected widget event
  go Collected {..} = \case
    attr := value -> Collected
      { collectedProperties = HashMap.insert (Text.pack (symbolVal attr))
                                             (CollectedProperty attr value)
                                             collectedProperties
      , ..
      }
    Classes classSet ->
      Collected { collectedClasses = collectedClasses <> classSet, .. }
    _ -> Collected { .. }

-- | Create a list of GTK construct operations based on collected
-- properties, used when creating new widgets.
constructProperties
  :: Collected widget event -> [GI.AttrOp widget 'GI.AttrConstruct]
constructProperties c = map
  (\(CollectedProperty attr value) -> attr Gtk.:= value)
  (HashMap.elems (collectedProperties c))

-- | Update the changed properties of a widget, based on the old and new
-- collected properties.
updateProperties
  :: widget -> CollectedProperties widget -> CollectedProperties widget -> IO ()
updateProperties (widget' :: widget) oldProps newProps = do
  let toAdd  = HashMap.elems (HashMap.difference newProps oldProps)
      setOps = mconcat
        (HashMap.elems (HashMap.intersectionWith toMaybeSetOp oldProps newProps)
        )
  GI.set widget' (map (toSetOp (Proxy @widget)) toAdd <> setOps)
 where
  toSetOp
    :: Proxy widget
    -> CollectedProperty widget
    -> Gtk.AttrOp widget 'GI.AttrSet
  toSetOp _ (CollectedProperty attr value) = attr Gtk.:= value
  toMaybeSetOp
    :: CollectedProperty widget
    -> CollectedProperty widget
    -> [Gtk.AttrOp widget 'GI.AttrSet]
  toMaybeSetOp (CollectedProperty attr (v1 :: t1)) (CollectedProperty _ (v2 :: t2))
    = case eqT @t1 @t2 of
      Just Refl | v1 /= v2 -> pure (attr Gtk.:= v2)
      _                    -> mempty

-- | Update the style context's classes to only include the new set of
-- classes (last argument).
updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses ctx old new = do
  let toAdd    = HashSet.difference new old
      toRemove = HashSet.difference old new
  mapM_ (Gtk.styleContextAddClass ctx)    toAdd
  mapM_ (Gtk.styleContextRemoveClass ctx) toRemove