Implement widget updates

spago.lock

@@ -12,6 +12,7 @@ workspace:
         - nullable
         - prelude
         - record
+        - record-studio
         - untagged-union
         - web-encoding
       test_dependencies: []
@@ -38,6 +39,7 @@ workspace:
         - functions
         - functors
         - gen
+        - heterogeneous
         - identity
         - integers
         - invariant
@@ -59,6 +61,7 @@ workspace:
         - profunctor
         - psci-support
         - record
+        - record-studio
         - refs
         - safe-coerce
         - st
@@ -71,6 +74,7 @@ workspace:
         - unfoldable
         - unsafe-coerce
         - untagged-union
+        - variant
         - web-encoding
   package_set:
     address:
@@ -812,6 +816,17 @@ packages:
       - tailrec
       - tuples
       - unfoldable
+  heterogeneous:
+    type: registry
+    version: 0.6.0
+    integrity: sha256-cfNYSK6yYmjTrkzk95Otpv6TUUkeBreexwqG/tBvUyg=
+    dependencies:
+      - either
+      - functors
+      - prelude
+      - record
+      - tuples
+      - variant
   identity:
     type: registry
     version: 6.0.0
@@ -1013,6 +1028,16 @@ packages:
       - functions
       - prelude
       - unsafe-coerce
+  record-studio:
+    type: registry
+    version: 1.0.4
+    integrity: sha256-9v6qpUrGa17Im/F/vWODjKlmD3ZuUXYIKCpz5OI9seM=
+    dependencies:
+      - heterogeneous
+      - lists
+      - prelude
+      - record
+      - typelevel-prelude
   refs:
     type: registry
     version: 6.0.0
@@ -1139,6 +1164,19 @@ packages:
       - psci-support
       - tuples
       - unsafe-coerce
+  variant:
+    type: registry
+    version: 8.0.0
+    integrity: sha256-SR//zQDg2dnbB8ZHslcxieUkCeNlbMToapvmh9onTtw=
+    dependencies:
+      - enums
+      - lists
+      - maybe
+      - partial
+      - prelude
+      - record
+      - tuples
+      - unsafe-coerce
   web-encoding:
     type: registry
     version: 3.0.0

spago.yaml

@@ -10,6 +10,7 @@ package:
     - nullable
     - prelude
     - record
+    - record-studio
     - untagged-union
     - web-encoding
   test:

src/AGS/Binding.purs

@@ -1,33 +1,27 @@
 module AGS.Binding
   ( Binding
-  , SelfOrBinding
   , class BindProp
   , bindProp
   , unsafeBindProp
+  , ValueOrBinding
+  , overValue
+  , overBinding
+  , overBoth
   ) where
 
 import Prelude
 
 import Control.Apply (lift2)
+import Data.Either (either)
 import Data.Symbol (class IsSymbol, reflectSymbol)
 import Type.Proxy (Proxy(..))
-import Untagged.Union (OneOf)
+import Untagged.TypeCheck (class HasRuntimeType)
+import Untagged.Union (OneOf, asOneOf, toEither1)
 
 foreign import data Binding ∷ Type → Type
 
 type role Binding representational
 
-type SelfOrBinding a = OneOf a (Binding a)
-
-class BindProp ∷ ∀ k. Type → k → Type → Constraint
-class BindProp o p t | o p → t where
-  bindProp ∷ o → Binding t
-
-unsafeBindProp ∷ ∀ @p @o @t. IsSymbol p ⇒ BindProp o p t ⇒ o → Binding t
-unsafeBindProp = unsafeBindPropImpl (reflectSymbol (Proxy @p))
-
-foreign import unsafeBindPropImpl ∷ ∀ o t. String → o → Binding t
-
 -- | Transform the value streamed in a `Binding`.
 instance Functor Binding where
   map = transform
@@ -62,3 +56,46 @@ foreign import applyBinding ∷ ∀ a b. Binding (a → b) → Binding a → Bin
 foreign import pureBinding ∷ ∀ a. a → Binding a
 foreign import bindBinding ∷ ∀ a b. Binding a → (a → Binding b) → Binding b
 
+class BindProp ∷ ∀ k. Type → k → Type → Constraint
+class BindProp o p t | o p → t where
+  bindProp ∷ o → Binding t
+
+unsafeBindProp ∷ ∀ @p @o @t. IsSymbol p ⇒ BindProp o p t ⇒ o → Binding t
+unsafeBindProp = unsafeBindPropImpl (reflectSymbol (Proxy @p))
+
+foreign import unsafeBindPropImpl ∷ ∀ o t. String → o → Binding t
+
+-- * ValueOrBinding
+
+type ValueOrBinding a = OneOf a (Binding a)
+
+-- | Transform a *value* inside a `ValueOrBinding`.
+-- | If `ValueOrBinding` is a binding, it stays unmodified.
+overValue
+  ∷ ∀ a
+  . HasRuntimeType a
+  ⇒ (a → a)
+  → ValueOrBinding a
+  → ValueOrBinding a
+overValue = flip overBoth identity
+
+-- | Transform a *binding* inside a `ValueOrBinding`.
+-- | If `ValueOrBinding` is a plain value, it stays unmodified.
+overBinding
+  ∷ ∀ a
+  . HasRuntimeType a
+  ⇒ (Binding a → Binding a)
+  → ValueOrBinding a
+  → ValueOrBinding a
+overBinding = overBoth identity
+
+-- | Transform both a plain value and a binding in `ValueOrBinding`.
+overBoth
+  ∷ ∀ a b
+  . HasRuntimeType a
+  ⇒ (a → b)
+  → (Binding a → Binding b)
+  → ValueOrBinding a
+  → ValueOrBinding b
+overBoth f g sob = either (asOneOf <<< f) (asOneOf <<< g) $ toEither1 sob
+

src/AGS/Widget.js

@@ -0,0 +1,10 @@
+export const grabFocus =
+  widget => () =>
+    widget.grab_focus()
+
+export const withInterval =
+  interval => handler => widget => () =>
+    { widget.poll(interval, _ => handler())
+      return
+    }
+

src/AGS/Widget.purs

@@ -1,46 +1,86 @@
-module AGS.Widget (module Exports) where
+module AGS.Widget
+  ( grabFocus
+  , withInterval
+  , module Exports
+  ) where
 
-import AGS.Binding (Binding, SelfOrBinding, bindProp) as Exports
-import AGS.Widget.Box (BoxProps, box) as Exports
-import AGS.Widget.Button (ButtonProps, button, buttonImpl) as Exports
-import AGS.Widget.CenterBox (CenterBoxProps, centerBox) as Exports
-import AGS.Widget.CircularProgress (CircularProgressProps, circularProgress) as Exports
-import AGS.Widget.Entry (EntryProps, entry) as Exports
-import AGS.Widget.EventBox (EventBoxProps, eventBox) as Exports
-import AGS.Widget.Icon (IconProps, icon) as Exports
+import AGS.Binding
+  ( class BindProp
+  , Binding
+  , ValueOrBinding
+  , bindProp
+  , overBinding
+  , overBoth
+  , overValue
+  ) as Exports
+import AGS.Widget.Box (BoxProps, UpdateBoxProps, box, box') as Exports
+import AGS.Widget.Button (ButtonProps, UpdateButtonProps, button, button') as Exports
+import AGS.Widget.CenterBox
+  ( CenterBoxProps
+  , UpdateCenterBoxProps
+  , centerBox
+  , centerBox'
+  ) as Exports
+import AGS.Widget.CircularProgress
+  ( CircularProgressProps
+  , UpdateCircularProgressProps
+  , circularProgress
+  , circularProgress'
+  ) as Exports
+import AGS.Widget.Entry (EntryProps, UpdateEntryProps, entry, entry') as Exports
+import AGS.Widget.EventBox
+  ( EventBoxProps
+  , UpdateEventBoxProps
+  , eventBox
+  , eventBox'
+  ) as Exports
+import AGS.Widget.Icon (IconProps, UpdateIconProps, icon, icon') as Exports
 import AGS.Widget.Internal
   ( AGSWidgetProps
   , Any
   , AnyF
-  , grabFocus
   , mkAny
-  , unsafeSetProperty
-  , withInterval
+  , unsafeWidgetUpdate
   ) as Exports
-import AGS.Widget.Label (LabelProps, label) as Exports
-import AGS.Widget.Menu (MenuProps, menu) as Exports
+import AGS.Widget.Label (LabelProps, label, label') as Exports
+import AGS.Widget.Menu (MenuProps, UpdateMenuProps, menu, menu') as Exports
 import AGS.Widget.Menu.Item (MenuItem, MenuItemProps, menuItem, menuItemImpl) as Exports
-import AGS.Widget.Overlay (OverlayProps, overlay) as Exports
-import AGS.Widget.ProgressBar (ProgressBarProps, progressBar) as Exports
+import AGS.Widget.Overlay (OverlayProps, UpdateOverlayProps, overlay, overlay') as Exports
+import AGS.Widget.ProgressBar
+  ( ProgressBarProps
+  , UpdateProgressBarProps
+  , progressBar
+  , progressBar'
+  ) as Exports
 import AGS.Widget.Revealer
   ( GtkRevealerTransitionType
   , RevealerProps
+  , UpdateRevealerProps
   , revealer
+  , revealer'
   , transitions
   ) as Exports
-import AGS.Widget.Scrollable (ScrollableProps, scrollable) as Exports
+import AGS.Widget.Scrollable
+  ( ScrollableProps
+  , UpdateScrollableProps
+  , scrollable
+  , scrollable'
+  ) as Exports
 import AGS.Widget.Slider
   ( Mark
   , MarkPosition
   , SliderProps
+  , UpdateSliderProps
   , markPositionBottom
   , markPositionLeft
   , markPositionRight
   , markPositionTop
   , slider
+  , slider'
   ) as Exports
-import AGS.Widget.Stack (StackProps, stack) as Exports
+import AGS.Widget.Stack (StackProps, stack, stack') as Exports
 import AGS.Widget.Window (Window, WindowProps, window) as Exports
+import Effect (Effect)
 import Effect.Uncurried
   ( EffectFn1
   , EffectFn2
@@ -50,10 +90,14 @@ import Effect.Uncurried
   , mkEffectFn2
   , mkEffectFn3
   , mkEffectFn4
-  , runEffectFn1
-  , runEffectFn2
-  , runEffectFn3
-  , runEffectFn4
   ) as Exports
-import Untagged.Union (UndefinedOr, asOneOf) as Exports
+import Gtk.Widget (Widget)
+import Gtk.Widget (Widget) as Exports
+import Prelude (Unit)
+import Untagged.Union (asOneOf) as Exports
+
+-- * Methods
+
+foreign import grabFocus ∷ Widget → Effect Unit
+foreign import withInterval ∷ Int → Effect Unit → Widget → Effect Unit
 

src/AGS/Widget/Box.purs

@@ -1,15 +1,23 @@
 module AGS.Widget.Box
   ( BoxProps
+  , UpdateBoxProps
   , box
+  , box'
   ) where
 
-import AGS.Binding (SelfOrBinding)
-import AGS.Widget.Internal (AGSWidgetProps)
+import Prelude
+
+import AGS.Binding (ValueOrBinding)
+import AGS.Widget.Internal
+  ( AGSWidgetProps
+  , unsafeWidgetUpdate
+  )
+import Data.Tuple.Nested (type (/\), (/\))
+import Effect (Effect)
 import Gtk.Box (GtkBoxProps)
 import Gtk.Container (GtkContainerProps)
 import Gtk.Orientable (GtkOrientableProps)
 import Gtk.Widget (Widget)
-import Prelude ((<<<))
 import Prim.Row (class Union)
 import Type.Row (type (+))
 import Unsafe.Coerce (unsafeCoerce)
@@ -21,7 +29,7 @@ type BoxProps r =
     + GtkBoxProps
     +
       ( vertical ∷ Boolean
-      , children ∷ SelfOrBinding (Array Widget)
+      , children ∷ ValueOrBinding (Array Widget)
       | r
       )
 
@@ -30,3 +38,17 @@ box = boxImpl <<< unsafeCoerce
 
 foreign import boxImpl ∷ Record (BoxProps ()) → Widget
 
+type UpdateBoxProps = Record (BoxProps ()) → Record (BoxProps ())
+
+box'
+  ∷ ∀ r r'
+  . Union r r' (BoxProps ())
+  ⇒ Record r
+  → Widget /\ (UpdateBoxProps → Effect Unit)
+box' props =
+  let
+    widget = box props
+    update = unsafeWidgetUpdate @(BoxProps ()) widget
+  in
+    widget /\ update
+