From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 30 Jun 2020 17:16:44 +0000 (+0200)
Subject: uds
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=111565b97002ef709dd5f822d0edee426a03e1a1;p=clean-tests.git

uds
---

diff --git a/uds/test.icl b/uds/test.icl
new file mode 100644
index 0000000..f2601b9
--- /dev/null
+++ b/uds/test.icl
@@ -0,0 +1,60 @@
+module test
+
+import StdEnv
+import Data.Maybe
+import Data.Functor
+import Data.Func
+import Control.Applicative
+import Control.Monad
+import qualified Data.Map
+
+class get v ~st
+where
+	get :: (v r w) .st -> .(Maybe r, .st) | TC r
+class put v ~st
+where
+	put :: w (v r w) .st -> .(Maybe (), .st) | TC w
+
+:: Source r w = Source String
+:: St :== 'Data.Map'.Map String Dynamic
+
+instance get Source St
+where
+	get (Source n) st = case 'Data.Map'.get n st of
+		Just (a :: a^) = (Just a, st)
+		_ = (Nothing, st)
+
+instance put Source St
+where
+	put w (Source n) st = (Just (), 'Data.Map'.put n (dynamic w) st)
+
+:: Par sdsl sdsr r w = E.r1 r2 w1 w2: Par (ParOpts sdsl sdsr r1 r2 w1 w2 r w)
+	& TC r1 & TC r2 & TC w1 & TC w2
+:: ParOpts sdsl sdsr r1 r2 w1 w2 r w =
+	{ read  :: r1 r2 -> Maybe r
+	, write :: w -> Maybe (w1, w2)
+	, left  :: (sdsl r1 w1)
+	, right :: (sdsr r2 w2)
+	}
+
+instance get (Par sdsl sdsr) St | get sdsl St & get sdsr St
+where
+	get (Par {read,left,right}) st
+		# (ml, st) = get left st
+		# (mr, st) = get right st
+		= (join $ read <$> ml <*> mr, st)
+instance put (Par sdsl sdsr) St | put sdsl St & put sdsr St
+where
+	put w (Par {write,left,right}) st
+		= case write w of
+			Nothing = (Nothing, st)
+			Just (w1, w2)
+				# (ml, st) = put w1 left st
+				# (mr, st) = put w2 right st
+				= (ml *> mr, st)
+
+Start :: (Maybe Int, .St)
+Start
+	# st = 'Data.Map'.newMap
+	# (Just _, st) = put 42 (Source "blurp") st
+	= get (Source "blurp") st