{-# 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 :: CollectedProperties widget
old canBeModifiedTo :: CollectedProperties widget -> CollectedProperties widget -> Bool
`canBeModifiedTo` new :: CollectedProperties widget
new = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (CollectedProperties widget -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys CollectedProperties widget
old)
  Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (CollectedProperties widget -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys CollectedProperties widget
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
      { Collected widget event -> ClassSet
collectedClasses :: ClassSet,
        Collected widget event -> CollectedProperties widget
collectedProperties :: CollectedProperties widget
      }

instance Semigroup (Collected widget event) where
  c1 :: Collected widget event
c1 <> :: Collected widget event
-> Collected widget event -> Collected widget event
<> c2 :: Collected widget event
c2 = ClassSet -> CollectedProperties widget -> Collected widget event
forall widget event.
ClassSet -> CollectedProperties widget -> Collected widget event
Collected (Collected widget event -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget event
c1 ClassSet -> ClassSet -> ClassSet
forall a. Semigroup a => a -> a -> a
<> Collected widget event -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget event
c2)
                       (Collected widget event -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget event
c1 CollectedProperties widget
-> CollectedProperties widget -> CollectedProperties widget
forall a. Semigroup a => a -> a -> a
<> Collected widget event -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget event
c2)

instance Monoid (Collected widget event) where
  mempty :: Collected widget event
mempty = ClassSet -> CollectedProperties widget -> Collected widget event
forall widget event.
ClassSet -> CollectedProperties widget -> Collected widget event
Collected ClassSet
forall a. Monoid a => a
mempty CollectedProperties widget
forall a. Monoid a => a
mempty

-- | Collect declarative markup attributes to the patching-optimized
-- 'Collected' data structure.
collectAttributes :: Vector (Attribute widget event) -> Collected widget event
collectAttributes :: Vector (Attribute widget event) -> Collected widget event
collectAttributes = (Collected widget event
 -> Attribute widget event -> Collected widget event)
-> Collected widget event
-> Vector (Attribute widget event)
-> Collected widget event
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Collected widget event
-> Attribute widget event -> Collected widget event
forall widget event.
Collected widget event
-> Attribute widget event -> Collected widget event
go Collected widget event
forall a. Monoid a => a
mempty
 where
  go
    :: Collected widget event
    -> Attribute widget event
    -> Collected widget event
  go :: Collected widget event
-> Attribute widget event -> Collected widget event
go Collected {..} = \case
    attr :: AttrLabelProxy attr
attr := value :: setValue
value -> Collected :: forall widget event.
ClassSet -> CollectedProperties widget -> Collected widget event
Collected
      { collectedProperties :: CollectedProperties widget
collectedProperties = Text
-> CollectedProperty widget
-> CollectedProperties widget
-> CollectedProperties widget
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert (String -> Text
Text.pack (AttrLabelProxy attr -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal AttrLabelProxy attr
attr))
                                             (AttrLabelProxy attr -> setValue -> CollectedProperty widget
forall info widget (attr :: Symbol) getValue setValue.
(AttrOpAllowed 'AttrConstruct info widget,
 AttrOpAllowed 'AttrSet info widget,
 AttrGetC info widget attr getValue,
 AttrSetTypeConstraint info setValue, KnownSymbol attr,
 Typeable attr, Eq setValue, Typeable setValue) =>
AttrLabelProxy attr -> setValue -> CollectedProperty widget
CollectedProperty AttrLabelProxy attr
attr setValue
value)
                                             CollectedProperties widget
collectedProperties
      , ..
      }
    Classes classSet :: ClassSet
classSet ->
      Collected :: forall widget event.
ClassSet -> CollectedProperties widget -> Collected widget event
Collected { collectedClasses :: ClassSet
collectedClasses = ClassSet
collectedClasses ClassSet -> ClassSet -> ClassSet
forall a. Semigroup a => a -> a -> a
<> ClassSet
classSet, .. }
    _ -> Collected :: forall widget event.
ClassSet -> CollectedProperties widget -> Collected widget event
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 :: Collected widget event -> [AttrOp widget 'AttrConstruct]
constructProperties c :: Collected widget event
c = (CollectedProperty widget -> AttrOp widget 'AttrConstruct)
-> [CollectedProperty widget] -> [AttrOp widget 'AttrConstruct]
forall a b. (a -> b) -> [a] -> [b]
map
  (\(CollectedProperty attr :: AttrLabelProxy attr
attr value :: setValue
value) -> AttrLabelProxy attr
attr AttrLabelProxy attr -> setValue -> AttrOp widget 'AttrConstruct
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> b -> AttrOp obj tag
Gtk.:= setValue
value)
  (HashMap Text (CollectedProperty widget)
-> [CollectedProperty widget]
forall k v. HashMap k v -> [v]
HashMap.elems (Collected widget event -> HashMap Text (CollectedProperty widget)
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget event
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
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties (widget
widget' :: widget) oldProps :: CollectedProperties widget
oldProps newProps :: CollectedProperties widget
newProps = do
  let toAdd :: [CollectedProperty widget]
toAdd  = CollectedProperties widget -> [CollectedProperty widget]
forall k v. HashMap k v -> [v]
HashMap.elems (CollectedProperties widget
-> CollectedProperties widget -> CollectedProperties widget
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference CollectedProperties widget
newProps CollectedProperties widget
oldProps)
      setOps :: [AttrOp widget 'AttrSet]
setOps = [[AttrOp widget 'AttrSet]] -> [AttrOp widget 'AttrSet]
forall a. Monoid a => [a] -> a
mconcat
        (HashMap Text [AttrOp widget 'AttrSet] -> [[AttrOp widget 'AttrSet]]
forall k v. HashMap k v -> [v]
HashMap.elems ((CollectedProperty widget
 -> CollectedProperty widget -> [AttrOp widget 'AttrSet])
-> CollectedProperties widget
-> CollectedProperties widget
-> HashMap Text [AttrOp widget 'AttrSet]
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
HashMap.intersectionWith CollectedProperty widget
-> CollectedProperty widget -> [AttrOp widget 'AttrSet]
toMaybeSetOp CollectedProperties widget
oldProps CollectedProperties widget
newProps)
        )
  widget -> [AttrOp widget 'AttrSet] -> IO ()
forall o (m :: * -> *).
MonadIO m =>
o -> [AttrOp o 'AttrSet] -> m ()
GI.set widget
widget' ((CollectedProperty widget -> AttrOp widget 'AttrSet)
-> [CollectedProperty widget] -> [AttrOp widget 'AttrSet]
forall a b. (a -> b) -> [a] -> [b]
map (Proxy widget -> CollectedProperty widget -> AttrOp widget 'AttrSet
toSetOp (Proxy widget
forall k (t :: k). Proxy t
Proxy @widget)) [CollectedProperty widget]
toAdd [AttrOp widget 'AttrSet]
-> [AttrOp widget 'AttrSet] -> [AttrOp widget 'AttrSet]
forall a. Semigroup a => a -> a -> a
<> [AttrOp widget 'AttrSet]
setOps)
 where
  toSetOp
    :: Proxy widget
    -> CollectedProperty widget
    -> Gtk.AttrOp widget 'GI.AttrSet
  toSetOp :: Proxy widget -> CollectedProperty widget -> AttrOp widget 'AttrSet
toSetOp _ (CollectedProperty attr :: AttrLabelProxy attr
attr value :: setValue
value) = AttrLabelProxy attr
attr AttrLabelProxy attr -> setValue -> AttrOp widget 'AttrSet
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> b -> AttrOp obj tag
Gtk.:= setValue
value
  toMaybeSetOp
    :: CollectedProperty widget
    -> CollectedProperty widget
    -> [Gtk.AttrOp widget 'GI.AttrSet]
  toMaybeSetOp :: CollectedProperty widget
-> CollectedProperty widget -> [AttrOp widget 'AttrSet]
toMaybeSetOp (CollectedProperty attr :: AttrLabelProxy attr
attr (setValue
v1 :: t1)) (CollectedProperty _ (setValue
v2 :: t2))
    = case (Typeable setValue, Typeable setValue) =>
Maybe (setValue :~: setValue)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t1 @t2 of
      Just Refl | setValue
v1 setValue -> setValue -> Bool
forall a. Eq a => a -> a -> Bool
/= setValue
setValue
v2 -> AttrOp widget 'AttrSet -> [AttrOp widget 'AttrSet]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttrLabelProxy attr
attr AttrLabelProxy attr -> setValue -> AttrOp widget 'AttrSet
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> b -> AttrOp obj tag
Gtk.:= setValue
v2)
      _                    -> [AttrOp widget 'AttrSet]
forall a. Monoid a => a
mempty

-- | Update the style context's classes to only include the new set of
-- classes (last argument).
updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses :: StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses ctx :: StyleContext
ctx old :: ClassSet
old new :: ClassSet
new = do
  let toAdd :: ClassSet
toAdd    = ClassSet -> ClassSet -> ClassSet
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.difference ClassSet
new ClassSet
old
      toRemove :: ClassSet
toRemove = ClassSet -> ClassSet -> ClassSet
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.difference ClassSet
old ClassSet
new
  (Text -> IO ()) -> ClassSet -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StyleContext -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass StyleContext
ctx)    ClassSet
toAdd
  (Text -> IO ()) -> ClassSet -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StyleContext -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextRemoveClass StyleContext
ctx) ClassSet
toRemove