Add rudimentary shares system

1 files changed, 36 insertions, 0 deletions

diff --git a/src/Gtk/Shares.icl b/src/Gtk/Shares.icl
new file mode 100644
index 0000000..13a8727
--- /dev/null
+++ b/src/Gtk/Shares.icl
@@ -0,0 +1,36 @@
+implementation module Gtk.Shares
+
+import StdEnv
+import StdMaybe
+import StdDebug
+
+import Control.Monad
+import Data.Functor
+import qualified Data.Map
+
+import Gtk
+
+:: Shared a :== (String,a)
+
+share :: !ShareId a -> Shared a | shared a
+share id default = (id,default)
+
+getShared :: !(Shared a) -> GtkM a | shared a
+getShared (id,default) = retrieve <$> getState
+where
+	retrieve {shares} = case 'Data.Map'.get id shares of
+		Nothing        -> default
+		Just (v :: a^) -> v
+		Just d         -> trace_n warning default
+		with
+			warning = "getShared type mismatch: expected "+++
+				toString (typeCodeOfDynamic (dynamic default))+++"; got "+++
+				toString (typeCodeOfDynamic d)
+
+setShared :: !(Shared a) !a -> GtkM a | shared a
+setShared (id,_) v =
+	modState (\st -> {st & shares='Data.Map'.put id (dynamic v) st.shares}) >>|
+	pure v
+
+updateShared :: !(a -> a) !(Shared a) -> GtkM a | shared a
+updateShared f shared = getShared shared >>= setShared shared o f