From d4820dea71a69fdecc5cb8a49f77f4899b7a691f Mon Sep 17 00:00:00 2001
From: postsolar <120750161+postsolar@users.noreply.github.com>
Date: Sun, 25 Feb 2024 17:43:30 +0200
Subject: [PATCH] Implement overrides for signals (#15)

* Implement overrides for signals

This enables `GObjectSignal` instances to map input callbacks to callbacks consumed by the GJS runtime.

* fixes

* Turn `GioFileMonitorEvent` into enum

As enabled by #15
---
 src/AGS/Service/Mpris.purs         | 49 +++++++++++++++-----
 src/AGS/Service/Notifications.purs | 16 +++++--
 src/AGS/Variable.purs              | 13 +++++-
 src/GObject.purs                   | 63 +++++++++++++++++++++++---
 src/Gio/FileMonitor.purs           | 24 +++++++++-
 src/Gio/FileMonitorEvent.js        | 14 ------
 src/Gio/FileMonitorEvent.purs      | 72 ++++++++++++++++++++++++------
 7 files changed, 200 insertions(+), 51 deletions(-)
 delete mode 100644 src/Gio/FileMonitorEvent.js

diff --git a/src/AGS/Service/Mpris.purs b/src/AGS/Service/Mpris.purs
index 250b132..c17c126 100644
--- a/src/AGS/Service/Mpris.purs
+++ b/src/AGS/Service/Mpris.purs
@@ -5,12 +5,14 @@ module AGS.Service.Mpris
   , disconnectMpris
   , players
   , matchPlayer
-  , BusName
   , Player
   , PlayerProps
   , PlayerSignals
+  , PlayerSignalsOverrides
+  , PlayerPosition(..)
   , PlayerRecord
   , PlayerRecordR
+  , BusName(..)
   , MprisMetadata
   , MprisMetadataF
   , fromPlayer
@@ -28,10 +30,12 @@ import Prelude
 import AGS.Binding (class BindProp, Binding)
 import AGS.Service (class BindServiceProp, class ServiceConnect, Service)
 import Data.Maybe (Maybe)
+import Data.Newtype (class Newtype)
 import Data.Nullable (Nullable, toMaybe)
 import Data.Symbol (class IsSymbol, reflectSymbol)
+import Data.Variant as V
 import Effect (Effect)
-import Effect.Uncurried (EffectFn1, EffectFn2)
+import Effect.Uncurried (EffectFn1, EffectFn2, mkEffectFn1, mkEffectFn2)
 import GObject (class GObjectSignal, HandlerID, unsafeCopyGObjectProps)
 import Record as R
 import Record.Studio.MapKind (mapRecordKind)
@@ -83,35 +87,52 @@ foreign import matchPlayerImpl ∷ String → Effect (Nullable Player)
 
 -- *** Player
 
+foreign import data Player ∷ Type
+
 newtype BusName = BusName String
 
+derive instance Newtype BusName _
+instance Show BusName where
+  show (BusName bn) = "(BusName " <> show bn <> ")"
+
+derive newtype instance Eq BusName
+
+newtype PlayerPosition = PlayerPosition Number
+
+derive instance Newtype PlayerPosition _
+
+instance Show PlayerPosition where
+  show (PlayerPosition pos) = "(PlayerPosition " <> show pos <> ")"
+
+derive newtype instance Eq PlayerPosition
+derive newtype instance Ord PlayerPosition
+derive newtype instance Semiring PlayerPosition
+
 type PlayerRecord = Record PlayerRecordR
 
 type PlayerRecordR =
-  ( "bus-name" ∷ String
+  ( "bus-name" ∷ BusName
   , "can-go-next" ∷ Boolean
   , "can-go-prev" ∷ Boolean
   , "can-play" ∷ Boolean
   , "cover-path" ∷ Maybe String
   , entry ∷ String
   , identity ∷ String
-  , length ∷ Int
+  , length ∷ Number
   , "loop-status" ∷ Maybe Boolean
   , metadata ∷ MprisMetadata
   , name ∷ String
   , "play-back-status" ∷ String
-  , position ∷ Int
+  , position ∷ PlayerPosition
   , "shuffle-status" ∷ Maybe Boolean
   , "track-artists" ∷ Array String
   , "track-cover-url" ∷ String
   , "track-title" ∷ String
   , "track-album" ∷ String
   , trackid ∷ String
-  , volume ∷ Int
+  , volume ∷ Number
   )
 
-foreign import data Player ∷ Type
-
 type MprisMetadata = MprisMetadataF Maybe
 
 type MprisMetadataF f =
@@ -156,7 +177,7 @@ fromPlayer = unsafeCopyGObjectProps @PlayerRecordR
 
 type PlayerProps =
   -- the dbus name that starts with org.mpris.MediaPlayer2
-  ( "bus-name" ∷ String
+  ( "bus-name" ∷ BusName
   -- stripped from busName like spotify or firefox
   , name ∷ String
   -- name of the player like Spotify or Mozilla Firefox
@@ -189,11 +210,17 @@ instance BindProp Player PlayerProps
 -- * Signals
 
 type PlayerSignals =
-  ( position ∷ EffectFn2 Player Number Unit
+  ( position ∷ Player → PlayerPosition → Effect Unit
+  , closed ∷ Player → Effect Unit
+  )
+
+type PlayerSignalsOverrides =
+  ( position ∷ EffectFn2 Player PlayerPosition Unit
   , closed ∷ EffectFn1 Player Unit
   )
 
-instance GObjectSignal Player PlayerSignals
+instance GObjectSignal Player PlayerSignals PlayerSignalsOverrides where
+  overrides = V.over { position: mkEffectFn2, closed: mkEffectFn1 }
 
 -- * Methods
 
diff --git a/src/AGS/Service/Notifications.purs b/src/AGS/Service/Notifications.purs
index a631b6e..59c3d01 100644
--- a/src/AGS/Service/Notifications.purs
+++ b/src/AGS/Service/Notifications.purs
@@ -41,9 +41,10 @@ import Data.Nullable (Nullable, toMaybe)
 import Data.Show.Generic (genericShow)
 import Data.Symbol (class IsSymbol, reflectSymbol)
 import Data.Time.Duration (Milliseconds(..))
+import Data.Variant as V
 import Effect (Effect)
-import Effect.Aff.Compat (runEffectFn1)
-import Effect.Uncurried (EffectFn2)
+import Effect.Aff.Compat (mkEffectFn1, runEffectFn1)
+import Effect.Uncurried (EffectFn2, mkEffectFn2)
 import GObject (class GObjectSignal, HandlerID, unsafeCopyGObjectProps)
 import Partial.Unsafe (unsafePartial)
 import Record as Record
@@ -144,12 +145,21 @@ fromNotification =
 -- * Signals
 
 type NotificationSignals =
+  ( dismissed ∷ Notification → Effect Unit
+  , closed ∷ Notification → Effect Unit
+  , invoked ∷ Notification → ActionID → Effect Unit
+  )
+
+type NotificationSignalsOverrides =
   ( dismissed ∷ EffectFn1 Notification Unit
   , closed ∷ EffectFn1 Notification Unit
   , invoked ∷ EffectFn2 Notification ActionID Unit
   )
 
-instance GObjectSignal Notification NotificationSignals
+instance
+  GObjectSignal Notification NotificationSignals NotificationSignalsOverrides where
+  overrides = V.over
+    { dismissed: mkEffectFn1, closed: mkEffectFn1, invoked: mkEffectFn2 }
 
 -- * Bindings and props
 
diff --git a/src/AGS/Variable.purs b/src/AGS/Variable.purs
index 7197d59..4e26151 100644
--- a/src/AGS/Variable.purs
+++ b/src/AGS/Variable.purs
@@ -1,6 +1,7 @@
 module AGS.Variable
   ( Variable
   , VariableSignals
+  , VariableSignalsOverrides
   , get
   , set
   , bindValue
@@ -14,17 +15,25 @@ import Prelude
 
 import AGS.Binding (class BindProp, Binding, bindProp)
 import Data.Time.Duration (Milliseconds)
+import Data.Variant as V
 import Effect (Effect)
-import Effect.Uncurried (EffectFn1)
+import Effect.Uncurried (EffectFn1, mkEffectFn1)
 import GObject (class GObjectSignal)
 
 foreign import data Variable ∷ Type → Type
 
 type VariableSignals a =
+  ( changed ∷ Variable a → Effect Unit
+  )
+
+type VariableSignalsOverrides a =
   ( changed ∷ EffectFn1 (Variable a) Unit
   )
 
-instance GObjectSignal (Variable a) (VariableSignals a)
+instance
+  GObjectSignal (Variable a) (VariableSignals a) (VariableSignalsOverrides a)
+  where
+  overrides = V.over { changed: mkEffectFn1 }
 
 -- | Get the value of a variable.
 foreign import get ∷ ∀ a. Variable a → Effect a
diff --git a/src/GObject.purs b/src/GObject.purs
index ae88034..ff9c3bd 100644
--- a/src/GObject.purs
+++ b/src/GObject.purs
@@ -1,6 +1,7 @@
 module GObject
   ( HandlerID
   , class GObjectSignal
+  , overrides
   , connect
   , disconnect
   , unsafeCopyGObjectProps
@@ -8,32 +9,82 @@ module GObject
 
 import Prelude
 
+import Data.Maybe (Maybe(..))
 import Data.Symbol (class IsSymbol, reflectSymbol)
+import Data.Variant (Variant)
+import Data.Variant as V
 import Effect (Effect)
 import Effect.Uncurried (EffectFn2, EffectFn3, runEffectFn2, runEffectFn3)
+import Partial.Unsafe (unsafeCrashWith)
 import Prim.Row as R
 import Record.Studio.Keys (class Keys, keys)
 import Type.Proxy (Proxy(..))
 
 foreign import data HandlerID ∷ ∀ k. k → Type
 
-class GObjectSignal ∷ Type → Row Type → Constraint
-class GObjectSignal object signals | object → signals
+-- | This class establishes how different GObjects should connect to signals.
+-- | The first type parameter lays out the user-facing callback types, and
+-- | the second type parameter lays out the types used by GJS runtime.
+-- | An instance could look as follows:
+-- |
+-- | ```purescript
+-- | foreign import data Object1 ∷ Type -- the GObject
+-- | type Signals = ( changed ∷ EffectFn2 Object1 Int Unit )
+-- | -- don't apply any overrides
+-- | instance GObjectSignal Object1 Signals Signals where
+-- |   overrides = V.over {}
+-- |
+-- | -- now the same, but with overrides
+-- | foreign import data Object2 ∷ Type
+-- | type Signals = ( changed ∷ Effect Unit )
+-- | type SignalOverrides = ( changed ∷ EffectFn2 Object2 String Unit )
+-- | instance GObjectSignal Object2 Signals SignalOverrides where
+-- |   overrides = V.over { changed: \cb → mkEffectFn2 \_ _ → cb }
+-- | ```
+-- |
+-- | *Note*: for an instance to be found, a type alias used in the
+-- | instance head must be exported.
+class GObjectSignal ∷ Type → Row Type → Row Type → Constraint
+class
+  GObjectSignal object signals overrides
+  | object → signals overrides
+  where
+  overrides ∷ Variant signals → Variant overrides
 
+-- | Connect a GObject to a signal.
+-- | Example:
+-- |
+-- | ```purescript
+-- | connect @"changed" myObject \_obj info → log info
+-- | ```
 connect
-  ∷ ∀ @sig @obj cb rt os
+  ∷ ∀ @sig @obj cb pcb rt os ovs
   . R.Cons sig cb rt os
-  ⇒ GObjectSignal obj os
+  -- This constraint aids the compiler find the type of
+  -- the processed callback to project the variant's value.
+  -- It shouldn't be removed.
+  ⇒ R.Cons sig pcb rt ovs
+  ⇒ GObjectSignal obj os ovs
   ⇒ IsSymbol sig
   ⇒ obj
   → cb
   → Effect (HandlerID obj)
-connect = runEffectFn3 connectImpl (reflectSymbol (Proxy @sig))
+connect o cb' =
+  V.inj label cb'
+    # overrides @obj @os
+    # V.prj label
+    # case _ of
+        Just cb → runEffectFn3 connectImpl (reflectSymbol label) o cb
+        Nothing → unsafeCrashWith "connect: impossible"
+
+  where
+  label = Proxy @sig
 
 foreign import connectImpl ∷ ∀ f o. EffectFn3 String o f (HandlerID o)
 
 -- | Disconnect a GObject given its HandlerID.
-disconnect ∷ ∀ @obj os. GObjectSignal obj os ⇒ obj → HandlerID obj → Effect Unit
+disconnect
+  ∷ ∀ @obj os ovs. GObjectSignal obj os ovs ⇒ obj → HandlerID obj → Effect Unit
 disconnect = runEffectFn2 disconnectImpl
 
 foreign import disconnectImpl ∷ ∀ o. EffectFn2 o (HandlerID o) Unit
diff --git a/src/Gio/FileMonitor.purs b/src/Gio/FileMonitor.purs
index a5d1d77..a97eee4 100644
--- a/src/Gio/FileMonitor.purs
+++ b/src/Gio/FileMonitor.purs
@@ -1,6 +1,7 @@
 module Gio.FileMonitor
   ( GioFileMonitor
   , FileMonitorSignals
+  , FileMonitorSignalsOverrides
   , monitor
   , monitorFile
   , monitorDirectory
@@ -11,12 +12,17 @@ module Gio.FileMonitor
 
 import Prelude
 
+import Data.Enum (toEnum)
+import Data.Maybe (fromJust)
 import Data.Nullable (Nullable)
+import Data.Variant as V
 import Effect (Effect)
 import Effect.Uncurried
   ( EffectFn1
   , EffectFn2
   , EffectFn4
+  , mkEffectFn1
+  , mkEffectFn4
   , runEffectFn1
   , runEffectFn2
   )
@@ -24,6 +30,7 @@ import GObject (class GObjectSignal)
 import Gio.File (GioFile)
 import Gio.FileMonitorEvent (GioFileMonitorEvent)
 import Gio.FileMonitorFlags (GioFileMonitorFlags)
+import Partial.Unsafe (unsafePartial)
 import Unsafe.Coerce (unsafeCoerce)
 
 foreign import data GioFileMonitor ∷ Type
@@ -31,11 +38,24 @@ foreign import data GioFileMonitor ∷ Type
 -- * Signals
 
 type FileMonitorSignals =
-  ( changed ∷ EffectFn4 GioFileMonitor GioFile GioFile GioFileMonitorEvent Unit
+  ( changed ∷
+      GioFileMonitor → GioFile → GioFile → GioFileMonitorEvent → Effect Unit
+  , "notify::cancelled" ∷ GioFileMonitor → Effect Unit
+  )
+
+type FileMonitorSignalsOverrides =
+  ( changed ∷ EffectFn4 GioFileMonitor GioFile GioFile Int Unit
   , "notify::cancelled" ∷ EffectFn1 GioFileMonitor Unit
   )
 
-instance GObjectSignal GioFileMonitor FileMonitorSignals
+instance
+  GObjectSignal GioFileMonitor FileMonitorSignals FileMonitorSignalsOverrides
+  where
+  overrides = V.over
+    { changed: \cb → mkEffectFn4 \a b c int →
+        cb a b c (unsafePartial $ fromJust $ toEnum int)
+    , "notify::cancelled": mkEffectFn1
+    }
 
 -- * Methods
 
diff --git a/src/Gio/FileMonitorEvent.js b/src/Gio/FileMonitorEvent.js
deleted file mode 100644
index bb719b1..0000000
--- a/src/Gio/FileMonitorEvent.js
+++ /dev/null
@@ -1,14 +0,0 @@
-import Gio from 'gi://Gio'
-
-export const attributeChanged = Gio.FileMonitorEvent.ATTRIBUTE_CHANGED
-export const changed = Gio.FileMonitorEvent.CHANGED
-export const changesDoneHint = Gio.FileMonitorEvent.CHANGES_DONE_HINT
-export const created = Gio.FileMonitorEvent.CREATED
-export const deleted = Gio.FileMonitorEvent.DELETED
-export const moved = Gio.FileMonitorEvent.MOVED
-export const movedIn = Gio.FileMonitorEvent.MOVED_IN
-export const movedOut = Gio.FileMonitorEvent.MOVED_OUT
-export const preUnmount = Gio.FileMonitorEvent.PRE_UNMOUNT
-export const renamed = Gio.FileMonitorEvent.RENAMED
-export const unmounted = Gio.FileMonitorEvent.UNMOUNTED
-
diff --git a/src/Gio/FileMonitorEvent.purs b/src/Gio/FileMonitorEvent.purs
index 4bc7c4e..4245cf5 100644
--- a/src/Gio/FileMonitorEvent.purs
+++ b/src/Gio/FileMonitorEvent.purs
@@ -1,16 +1,62 @@
 module Gio.FileMonitorEvent where
 
-foreign import data GioFileMonitorEvent ∷ Type
-
-foreign import attributeChanged ∷ GioFileMonitorEvent
-foreign import changed ∷ GioFileMonitorEvent
-foreign import changesDoneHint ∷ GioFileMonitorEvent
-foreign import created ∷ GioFileMonitorEvent
-foreign import deleted ∷ GioFileMonitorEvent
-foreign import moved ∷ GioFileMonitorEvent
-foreign import movedIn ∷ GioFileMonitorEvent
-foreign import movedOut ∷ GioFileMonitorEvent
-foreign import preUnmount ∷ GioFileMonitorEvent
-foreign import renamed ∷ GioFileMonitorEvent
-foreign import unmounted ∷ GioFileMonitorEvent
+import Data.Bounded (class Bounded)
+import Data.Bounded.Generic (genericBottom, genericTop)
+import Data.Enum (class BoundedEnum, class Enum)
+import Data.Enum.Generic
+  ( genericCardinality
+  , genericFromEnum
+  , genericPred
+  , genericSucc
+  , genericToEnum
+  )
+import Data.Eq (class Eq)
+import Data.Generic.Rep (class Generic)
+import Data.Ord (class Ord)
+import Data.Show (class Show)
+import Data.Show.Generic (genericShow)
+
+data GioFileMonitorEvent
+  -- A file changed.
+  = Changed
+  -- A hint that this was probably the last change in a set of changes.
+  | ChangesDoneHint
+  -- A file was deleted.
+  | Deleted
+  -- A file was created.
+  | Created
+  -- A file attribute was changed.
+  | AttributeChanged
+  -- The file location will soon be unmounted.
+  | PreUnmount
+  -- The file location was unmounted.
+  | Unmounted
+  -- The file was moved -- only sent if the (deprecated) Gio.FileMonitorFlags.SEND_MOVED flag is set
+  | Moved
+  -- The file was renamed within the current directory -- only sent if the Gio.FileMonitorFlags.WATCH_MOVES flag is set. Since: 2.46.
+  | Renamed
+  -- The file was moved into the monitored directory from another location -- only sent if the Gio.FileMonitorFlags.WATCH_MOVES flag is set. Since: 2.46.
+  | MovedIn
+  -- The file was moved out of the monitored directory to another location -- only sent if the Gio.FileMonitorFlags.WATCH_MOVES flag is set. Since: 2.46
+  | MovedOut
+
+derive instance Generic GioFileMonitorEvent _
+derive instance Eq GioFileMonitorEvent
+derive instance Ord GioFileMonitorEvent
+
+instance Show GioFileMonitorEvent where
+  show = genericShow
+
+instance Bounded GioFileMonitorEvent where
+  top = genericTop
+  bottom = genericBottom
+
+instance Enum GioFileMonitorEvent where
+  succ = genericSucc
+  pred = genericPred
+
+instance BoundedEnum GioFileMonitorEvent where
+  cardinality = genericCardinality
+  toEnum = genericToEnum
+  fromEnum = genericFromEnum