Add singletonShared convenience function

2 files changed, 13 insertions, 0 deletions

diff --git a/src/Gtk/Shares.dcl b/src/Gtk/Shares.dcl
index e05407c..3a3891b 100644
--- a/src/Gtk/Shares.dcl
+++ b/src/Gtk/Shares.dcl
@@ -13,3 +13,5 @@ share :: !ShareId a -> Shared a | shared a
 getShared :: !(Shared a) -> GtkM a | shared a
 setShared :: !(Shared a) !a -> GtkM a | shared a
 updateShared :: !(a -> a) !(Shared a) -> GtkM a | shared a
+
+singletonShared :: !String !(GtkM a) -> GtkM a | shared a
diff --git a/src/Gtk/Shares.icl b/src/Gtk/Shares.icl
index 13a8727..4ff107f 100644
--- a/src/Gtk/Shares.icl
+++ b/src/Gtk/Shares.icl
@@ -34,3 +34,14 @@ setShared (id,_) v =
 
 updateShared :: !(a -> a) !(Shared a) -> GtkM a | shared a
 updateShared f shared = getShared shared >>= setShared shared o f
+
+singletonShared :: !String !(GtkM a) -> GtkM a | shared a
+singletonShared name setup =
+	let shr = share name Nothing in
+	getShared shr >>= \val -> case val of
+		Just val ->
+			pure val
+		Nothing ->
+			setup >>= \val ->
+			setShared shr (Just val) >>|
+			pure val