[Draft] Custom attributes

docs/src/widgets/custom-widgets.md

@@ -1,3 +1,3 @@
 # Custom Widgets
 
-_This section is yet to be written. In the meantime, see [the CustomWidget example](https://github.com/owickstrom/gi-gtk-declarative/blob/master/examples/CustomWidget.hs)._
+_This section is yet to be written. In the meantime, see [the CustomAttribute example](https://github.com/owickstrom/gi-gtk-declarative/blob/master/examples/CustomAttribute.hs)._

examples/CustomWidget.hs → examples/CustomAttribute.hs

@@ -1,85 +1,80 @@
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE OverloadedLabels    #-}
-{-# LANGUAGE OverloadedLists     #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module CustomWidget where
-
-import           Control.Monad                  ( void )
-import           Data.Vector                    ( Vector )
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+module CustomAttribute where
+
+import           Control.Monad                  (void)
+import           Data.Vector                    (Vector)
 import           Data.Word
 
-import qualified GI.GObject                    as GI
-import qualified GI.Gtk                        as Gtk
+import qualified GI.GObject                     as GI
+import qualified GI.Gtk                         as Gtk
 import           GI.Gtk.Declarative
 import           GI.Gtk.Declarative.App.Simple
-import           GI.Gtk.Declarative.EventSource ( fromCancellation )
+import           GI.Gtk.Declarative.EventSource (fromCancellation)
 
 
 -- * Custom widget for ranged 'Double' inputs
 -------------------------------------------
 
+numberInput
+  :: Vector (Attribute Gtk.Box event)
+  -> NumberInputProperties
+  -> Maybe (Double -> event)
+  -> Widget event
+numberInput attrs props onInputChanged =
+  let customAttr = customAttribute () (NumberInput props onInputChanged)
+      vertical = #orientation := Gtk.OrientationVertical
+   in widget Gtk.Box ([vertical, customAttr] <> attrs)
+
+data NumberInput event = NumberInput
+  { props          :: NumberInputProperties
+  , onInputChanged :: Maybe (Double -> event)
+  }
+  deriving (Functor)
+
 data NumberInputProperties = NumberInputProperties
   { value  :: Double
   , range  :: (Double, Double)
   , step   :: Double
   , digits :: Word32
   } deriving (Eq, Show)
 
+instance CustomAttribute Gtk.Box NumberInput where
 
-newtype NumberInputEvent = NumberInputChanged Double
+  data AttrState NumberInput = NumberInputState Gtk.SpinButton
 
-numberInput
-  :: Vector (Attribute Gtk.Box NumberInputEvent)
-  -> NumberInputProperties
-  -> Widget NumberInputEvent
-numberInput customAttributes customParams = Widget
-  (CustomWidget { customWidget
-                , customCreate
-                , customPatch
-                , customSubscribe
-                , customAttributes
-                , customParams
-                }
-  )
- where
-  -- The constructor for the underlying GTK widget.
-  customWidget = Gtk.Box
-  -- A function that creates a widget (of the same type as
-  -- customWidget), used on first render and on 'CustomReplace'. It's
-  -- also returning our internal state, a reference to the spin button
-  -- widget.
-  customCreate props = do
-    box  <- Gtk.new Gtk.Box [#orientation Gtk.:= Gtk.OrientationVertical]
+  attrCreate box (NumberInput props _) = do
     lbl  <- Gtk.new Gtk.Label [#label Gtk.:= "I'm a custom widget."]
     spin <- Gtk.new Gtk.SpinButton []
     adj  <- propsToAdjustment props
     Gtk.spinButtonSetAdjustment spin adj
     Gtk.spinButtonSetDigits spin (digits props)
     #packStart box lbl True True 0
     #packStart box spin False False 0
-    return (box, spin)
-
-  -- A function that computes a patch for our custom widget. Here we
-  -- compare the params value of type 'NumberInputProperties' to
-  -- decide whether to modify the spin button widget or not. Note that
-  -- the spin button widget is passed through the internal state.
-  customPatch old new spin
-    | old == new = CustomKeep
-    | otherwise = CustomModify $ \_box -> do
-      adj <- propsToAdjustment new
-      Gtk.spinButtonSetAdjustment spin adj
-      Gtk.spinButtonSetDigits spin (digits new)
-      return spin
-
-  -- Finally, we subscribe to widget signals to emit
-  -- 'NumberInputChanged' events from the spin button reference
-  -- carried by the internal state.
-  customSubscribe _params (spin :: Gtk.SpinButton) _box cb = do
-    h <- Gtk.on spin #valueChanged $ cb . NumberInputChanged =<< #getValue spin
-    -- This creates a 'Subscription' from an IO action that
-    -- disconnects the signal handler.
-    return (fromCancellation (GI.signalHandlerDisconnect spin h))
+    return (NumberInputState spin)
+
+  attrPatch _box state@(NumberInputState spin) (NumberInput oldProps _) (NumberInput newProps _)
+    | oldProps == newProps = pure state
+    | otherwise = do
+        adj <- propsToAdjustment newProps
+        Gtk.spinButtonSetAdjustment spin adj
+        Gtk.spinButtonSetDigits spin (digits newProps)
+        return state
+
+  attrSubscribe _box (NumberInputState spin) (NumberInput _props onInputChanged) cb = do
+    case onInputChanged of
+      Nothing -> mempty
+      Just handler -> do
+        h <- Gtk.on spin #valueChanged $ cb . handler =<< #getValue spin
+        -- This creates a 'Subscription' from an IO action that
+        -- disconnects the signal handler.
+        return (fromCancellation (GI.signalHandlerDisconnect spin h))
 
 propsToAdjustment :: NumberInputProperties -> IO Gtk.Adjustment
 propsToAdjustment NumberInputProperties { value, range = (begin, end), step } =
@@ -101,7 +96,7 @@ view' (State currentValue) =
       , #widthRequest := 400
       , #heightRequest := 300
       ]
-    $ centered (toNumberEvent <$> numberSetter)
+    $ centered numberSetter
  where
   -- Construct our custom widget with some properties for the
   -- underlying SpinButton
@@ -116,8 +111,8 @@ view' (State currentValue) =
                           , step   = 0.1
                           , digits = 1
                           }
-  -- Map the custom widget's event to our app 'Event' type
-  toNumberEvent (NumberInputChanged d) = NumberSet d
+    -- And our event handler
+    (Just NumberSet)
 
 -- Helper that vertically and horizontally centers a widget
 centered :: Widget e -> Widget e

examples/Grid.hs

@@ -6,10 +6,8 @@
 module Grid where
 
 import           Control.Monad                  ( void )
-import           Data.Text                      ( pack )
 import           GI.Gtk                         ( Button(..)
                                                 , Grid(..)
-                                                , Label(..)
                                                 , Window(..)
                                                 )
 import           GI.Gtk.Declarative

examples/Main.hs

@@ -6,7 +6,7 @@ import           System.IO
 
 import qualified AddBoxes
 import qualified CSS
-import qualified CustomWidget
+import qualified CustomAttribute
 import qualified Dialog
 import qualified Exit
 import qualified FileChooserButton
@@ -18,12 +18,13 @@ import qualified ManyBoxes
 import qualified MenuBar
 import qualified Notebook
 import qualified Paned
+import qualified Windows
 
 main :: IO ()
 main =
   let examples =
           [ ("AddBoxes"         , AddBoxes.main)
-          , ("CustomWidget"     , CustomWidget.main)
+          , ("CustomAttribute"  , CustomAttribute.main)
           , ("FileChooserButton", FileChooserButton.main)
           , ("Hello"            , Hello.main)
           , ("ListBox"          , ListBox.main)
@@ -36,6 +37,7 @@ main =
           , ("CSS"              , CSS.main)
           , ("Paned"            , Paned.main)
           , ("Dialog"           , Dialog.main)
+          , ("Windows"          , Windows.main)
           ]
   in  getArgs >>= \case
         [example] -> case lookup example examples of

examples/Windows.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Windows where
+
+import           Control.Concurrent                          (threadDelay)
+import           Control.Monad                               (void)
+import           Data.FileEmbed                              (embedFile)
+import           Data.Functor                                ((<&>))
+import           Data.Text                                   (pack)
+import           Data.UUID                                   (UUID)
+import           Data.Vector                                 (Vector)
+import qualified Data.Vector                                 as Vector
+import           Pipes.Prelude                               (repeatM)
+import           System.Random                               (randomIO)
+
+import           GI.Gtk                                      (Box (..),
+                                                              Button (..),
+                                                              Label (..),
+                                                              Orientation (..),
+                                                              Window (..),
+                                                              WindowPosition (..))
+import           GI.Gtk.Declarative
+import           GI.Gtk.Declarative.App.Simple
+import           GI.Gtk.Declarative.Attributes.Custom.Window (IconData(..),
+                                                              setDefaultIcon,
+                                                              presentWindow,
+                                                              window)
+
+data WindowState = WindowState
+  { windowStateKey       :: UUID
+  , windowStateCount     :: Int
+  , windowStatePresented :: Int
+  }
+
+type State = Vector WindowState
+
+data Event
+  = IncrAll
+  | AddWindow UUID
+  | PresentWindow UUID
+  | RemoveWindow UUID
+  | Closed
+
+view' :: State -> AppView Window Event
+view' ws =
+  bin Window
+    ([ #title := "Windows"
+    , on #deleteEvent (const (True, Closed))
+    , #widthRequest := 400
+    , #heightRequest := 300
+    , #windowPosition := WindowPositionCenter
+    ] <> (windowAttr <$> ws)) $
+    container
+      Box
+      [#orientation := OrientationVertical, #spacing := 4, #margin := 4] $
+      addButton `Vector.cons` (windowButton <$> ws)
+
+addButton :: BoxChild Event
+addButton = BoxChild defaultBoxChildProperties
+  $ widget Button
+      [ #label := "Add Window"
+      , onM #clicked (const (AddWindow <$> randomIO))
+      ]
+
+windowButton :: WindowState -> BoxChild Event
+windowButton WindowState {..} =
+  BoxChild defaultBoxChildProperties $
+    widget
+    Button
+    [ #label := pack ("Present window " <> show windowStateKey)
+    , on #clicked $ PresentWindow windowStateKey
+    ]
+
+windowAttr :: WindowState -> Attribute widget Event
+windowAttr WindowState {..} = window windowStateKey $ bin
+  Window
+  [ #title := pack (show windowStateKey)
+  , on #deleteEvent (const (True, RemoveWindow windowStateKey))
+  , #widthRequest := 400
+  , #heightRequest := 250
+  , #windowPosition := WindowPositionCenter
+  , presentWindow windowStatePresented
+  ] $
+  widget Label
+    [#label := pack ("Open for " <> show windowStateCount <> " seconds")]
+
+update' :: State -> Event -> Transition State Event
+update' ws = \case
+  IncrAll -> Transition
+    (ws <&> \w -> w { windowStateCount = windowStateCount w + 1})
+    (pure Nothing)
+  AddWindow key -> Transition
+    (ws `Vector.snoc` WindowState key 1 1)
+    (pure Nothing)
+  PresentWindow key -> Transition
+    (ws <&> \w ->
+      if windowStateKey w == key
+      then w { windowStatePresented = windowStatePresented w + 1 }
+      else w)
+    (pure Nothing)
+  RemoveWindow key -> Transition
+    (Vector.filter (\w -> windowStateKey w /= key) ws)
+    (pure Nothing)
+  Closed->
+    Exit
+
+icon :: IconData
+icon = IconDataBytes $(embedFile "icon.png")
+
+main :: IO ()
+main = do
+  setDefaultIcon icon
+  void $ run App
+    { view         = view'
+    , update       = update'
+    , inputs       = [incrPeriodically]
+    , initialState = []
+    }
+  where incrPeriodically = repeatM $ IncrAll <$ threadDelay (1000 * 1000)

examples/examples.cabal

@@ -19,7 +19,7 @@ executable example
   main-is:              Main.hs
   other-modules:        AddBoxes
                       , CSS
-                      , CustomWidget
+                      , CustomAttribute
                       , Dialog
                       , Exit
                       , FileChooserButton
@@ -31,9 +31,11 @@ executable example
                       , MenuBar
                       , Notebook
                       , Paned
+                      , Windows
   build-depends:        base >=4.10 && <5
                       , async
                       , bytestring
+                      , file-embed
                       , gi-gobject
                       , gi-glib
                       , gi-gtk
@@ -44,7 +46,9 @@ executable example
                       , haskell-gi-base
                       , pipes
                       , pipes-extras
+                      , random
                       , text
+                      , uuid
                       , vector
   default-language:     Haskell2010
   ghc-options:          -O2 -Wall -threaded

gi-gtk-declarative-app-simple/src/GI/Gtk/Declarative/App/Simple.hs

@@ -134,7 +134,7 @@ runLoop App {..} = do
             sub      <- subscribe newMarkup newState (publishEvent events)
             return (newState, sub)
           Replace createNew -> runUI $ do
-            Gtk.widgetDestroy =<< someStateWidget oldState
+            destroy oldState oldMarkup
             cancel oldSubscription
             newState <- createNew
             Gtk.widgetShowAll =<< someStateWidget newState