From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 16 Jun 2017 09:34:21 +0000 (+0200)
Subject: removed whileUnchanged for devices
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=17aaf6797b3dd4e820b186a55335a36a89ea92cb;p=mTask.git

removed whileUnchanged for devices
---

diff --git a/Devices/mTaskDevice.dcl b/Devices/mTaskDevice.dcl
index bae443e..5fc0bfe 100644
--- a/Devices/mTaskDevice.dcl
+++ b/Devices/mTaskDevice.dcl
@@ -42,7 +42,7 @@ withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
 
 startupDevices :: Task [MTaskDevice]
 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
-manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
+manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task ()
 
 sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
 sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl
index f4789cc..2a0f17e 100644
--- a/Devices/mTaskDevice.icl
+++ b/Devices/mTaskDevice.icl
@@ -53,15 +53,18 @@ getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
 getSynFun (TCPDevice t) = synFun t
 getSynFun (SerialDevice t) = synFun t
 
-addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
-addDevice devices processFun
+addDevice :: (MTaskDevice (Shared Channels) -> Task ()) -> Task String
+addDevice processFun
 	=   enterChoice "Device type" [] (map consName{|*|} deviceTypes)
 	>&^ \sh->whileUnchanged sh $ \mty->case mty of
 		Nothing = viewInformation "No type selected yet" [] ""
 		Just ty = enterInformation "Name" [] -&&- deviceSettings ty
 			>>= \(name, settings)->makeDevice name settings
-			>>= \dev->upd (\l->[dev:l]) devices
+			>>= \dev->traceValue "make device done"
+			>>| upd (\l->[dev:l]) deviceStoreNP
+			>>| traceValue "update deviceslist"
 			>>| connectDevice processFun dev
+			>>| traceValue "device connected"
 			@! ""
 	where
 		deviceSettings "SerialDevice" = getmTaskSerialDevice
@@ -80,7 +83,7 @@ addDevice devices processFun
 //		errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! ()
 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
 connectDevice procFun device = let ch = channels device
-	in appendTopLevelTask 'DM'.newMap True
+	in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True
 		(	procFun device ch 
 		-||- catchAll (getSynFun device.deviceData ch) errHdl)
 		>>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing})
@@ -88,12 +91,12 @@ connectDevice procFun device = let ch = channels device
 	where
 		errHdl e = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! ()
 
-manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
-manageDevices processFun ds = anyTask [
-		addDevice deviceStoreNP processFun <<@ Title "Add new device" @! ():
-			[viewDevice processFun d 
-				<<@ Title d.deviceName\\d<-ds]]
-	<<@ ArrangeWithTabs @! ()
+manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task ()
+manageDevices processFun = get deviceStoreNP >>= \ds->anyTask [
+		addDevice processFun <<@ Title "Add new device" @! ():
+			[viewDevice processFun d <<@ Title d.deviceName\\d<-ds]]
+	<<@ ArrangeWithTabs
+	@! ()
 
 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask 
diff --git a/Devices/mTaskTCP.icl b/Devices/mTaskTCP.icl
index 9d810ef..48dc193 100644
--- a/Devices/mTaskTCP.icl
+++ b/Devices/mTaskTCP.icl
@@ -18,19 +18,25 @@ getmTaskTCPDevice = TCPDevice <$> enterInformation "Settings" []
 
 instance MTaskDuplex TCPSettings where
 	synFun :: TCPSettings (Shared Channels) -> Task ()
-	synFun s channels =
-		tcpconnect s.host s.port channels {ConnectionHandlers|
+	synFun s channels
+	| not (trace_tn "synFun started") = undef
+	= tcpconnect s.host s.port channels {ConnectionHandlers|
 				onConnect=onConnect,
 				onData=onData,
 				onShareChange=onShareChange,
-				onDisconnect=onDisconnect} @! ()
+				onDisconnect=onDisconnect} >>= \_->viewInformation "done" [] "done" @! ()
 		where
 			onConnect :: String ChD -> (MaybeErrorString String, Maybe ChD, [String], Bool)
-			onConnect acc (msgs,send,sendStopped) = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
+			onConnect acc (msgs,send,sendStopped)
+			| not (trace_tn "onConnect") = undef
+			= (Ok "", Just (msgs,[],sendStopped), map encode send, False)
 
 			onData :: String String ChD -> (MaybeErrorString String, Maybe ChD, [String], Bool)
-			onData newdata acc (msgs,send,True) = (Ok acc, Nothing, [], True)
+			onData newdata acc (msgs,send,True)
+			| not (trace_tn "onData: stop") = undef
+			= (Ok acc, Nothing, [], True)
 			onData newdata acc (msgs,send,sendStopped)
+			| not (trace_tn "onData: notstop") = undef
 			# split = indexOf "\n" newdata
 			| split == -1 = (Ok acc, Just (msgs, send, True), [], False)
 			# newMsg = decode (newdata % (0, split-1))
@@ -40,11 +46,19 @@ instance MTaskDuplex TCPSettings where
 			
 			onShareChange :: String ChD -> (MaybeErrorString String, Maybe ChD, [String], Bool)
 			// Stop!
-			 0onShareChange acc (msgs,send,True) = (Ok acc, Nothing, [], True)
+			onShareChange acc (msgs,send,True)
+			| not (trace_tn "onSC: stop") = undef
+			= (Ok acc, Nothing, [], True)
 			// Nothing to send
-			onShareChange acc (msgs,[], _) = (Ok acc, Nothing, [], False)
+			onShareChange acc (msgs,[], _)
+			| not (trace_tn "onSC: nothing") = undef
+			= (Ok acc, Nothing, [], False)
 			// Something to send
-			onShareChange acc (msgs,send, ss) = (Ok acc, Just (msgs,[],ss), map encode send, False)
+			onShareChange acc (msgs,send, ss)
+			| not (trace_tn "onSC: send") = undef
+			= (Ok acc, Just (msgs,[],ss), map encode send, False)
 
 			onDisconnect :: String ChD -> (MaybeErrorString String, Maybe ChD)
-			onDisconnect _ (msgs,send,_) = (Ok "", Just ([], [], True))
+			onDisconnect _ (msgs,send,_)
+			| not (trace_tn "ondisconnect") = undef
+			= (Ok "", Just ([], [], True))
diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl
index 43350e1..fda2a39 100644
--- a/Shares/mTaskShare.icl
+++ b/Shares/mTaskShare.icl
@@ -13,10 +13,10 @@ from StdFunc import flip
 derive class iTask MTaskShare
 
 manageShares :: Task [MTaskDevice]
-manageShares = whileUnchanged deviceStoreNP
-	$ \devs->case devs of
-		[] = viewInformation "No devices yet" [] []
-		_ = allTasks (map manageSharesOnDevice devs)
+manageShares = viewInformation "" [] []//whileUnchanged deviceStoreNP
+//	$ \devs->case devs of
+//		[] = viewInformation "No devices yet" [] []
+//		_ = allTasks (map manageSharesOnDevice devs)
 
 manageSharesOnDevice :: MTaskDevice -> Task MTaskDevice
 manageSharesOnDevice dev = (case dev.deviceShares of
@@ -97,6 +97,28 @@ getRealShare dev share = sdsFocus ()
 	$ sdsFocus (Just (dev, share.identifier))
 	$ deviceStore
 
+//getRealShare :: MTaskDevice MTaskShare -> Shared BCValue
+//getRealShare dev share = sdsLens
+//	("realShare" +++ toString share.identifier)
+//	(const $ Just (dev, share.identifier))
+//	(SDSRead $ const $ \rs->case find ((==)dev) rs of
+//		Nothing = Error $ exception "Device doesn't exist anymore"
+//		Just {deviceShares} = case find ((==)share) deviceShares of
+//			Nothing = Error $ exception "Share doesn't exist anymore"
+//			Just share = Ok share.MTaskShare.value
+//	)
+//	(SDSWrite $ const $ \rs w->partition ((==)dev) devs of
+//		([], _) = Error $ exception "Device doesn't exist anymore"
+//		([_,_:_], _) = Error $ exception "Multiple matching devices"
+//		([d=:{deviceShares}], devs) = case partition ((==)share) deviceShares of
+//			([], _) = Error $ exception "Share doesn't exist anymore"
+//			([_,_:_], _) = Error $ exception "Multiple matching shares"
+//			([s], shares)
+//				# s = {MTaskShare | s & value=val}
+//				# d = {MTaskDevice | d & deviceShares=[s:shares]}
+//				= Ok $ Just [d:devs])
+//	(SDSNotify $ const $ \rs w
+
 deviceLens dev share = (mread, mwrite)
 where
 	mread :: [MTaskDevice] -> MaybeError TaskException BCValue
diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl
index b6a2ede..a9f1a6c 100644
--- a/Utils/SDS.dcl
+++ b/Utils/SDS.dcl
@@ -8,5 +8,4 @@ memoryShare :: String a -> Shared a | iTask a
 
 deviceStoreNP :: Shared [MTaskDevice]
 deviceStore :: RWShared (Maybe (MTaskDevice, Int)) [MTaskDevice] [MTaskDevice]
-bcStateStore :: Shared BCState
 mTaskTaskStore :: Shared [String]
diff --git a/Utils/SDS.icl b/Utils/SDS.icl
index 9975d27..afd1c6c 100644
--- a/Utils/SDS.icl
+++ b/Utils/SDS.icl
@@ -18,6 +18,10 @@ memoryShare s d = sdsFocus s $ memoryStore s $ Just d
 deviceStoreNP :: Shared [MTaskDevice]
 deviceStoreNP = sdsFocus Nothing $ deviceStore
 
+import GenPrint, TTY
+derive gPrint MTaskDevice, Maybe, MTaskShare, MTaskResource, TaskId, MTaskTask, (,), TTYSettings, TCPSettings, DateTime, Parity, BaudRate, ByteSize, MaybeError, ()
+gPrint{|Dynamic|} _ st = gPrint{|*|} "**Dynamic**" st
+
 deviceStore :: RWShared (Maybe (MTaskDevice, Int)) [MTaskDevice] [MTaskDevice]
 deviceStore = SDSSource {SDSSource 
 	| name = "deviceStore"
@@ -25,11 +29,17 @@ deviceStore = SDSSource {SDSSource
 	, write= realWrite
 	}
 where
+	realRead p iw
+	| not (trace_tn $ "read called with: " +++ printToString p) = undef
+	= read realDeviceStore iw
+
 	realWrite mi w iw
+	| not (trace_tn $ "write called with: " +++ printToString mi +++ " w " +++ printToString w) = undef
 	# (merr, iw) = write w realDeviceStore iw
-	| isError merr || isNothing mi = (merr $> const True, iw)
+	| not (trace_tn $ "written to real store: " +++ printToString merr) = undef
+	| isError merr || isNothing mi = (merr $> notifyPred mi, iw)
 	# (Just (dev, ident)) = mi
-	| ident == -1 = (merr $> const True, iw)
+	| ident == -1 = (merr $> notifyPred mi, iw)
 	= case find ((==)dev) w of
 		Nothing = (Error $ exception "Device doesn't exist anymore", iw)
 		Just {deviceShares} = case find (\d->d.identifier == ident) deviceShares of
@@ -38,14 +48,22 @@ where
 			| not $ trace_tn "Really sending a message from a share update" = undef
 			= case sendMessagesIW [MTUpd ident s.MTaskShare.value] dev iw of
 				(Error e, iw) = (Error e, iw)
-				(Ok _, iw) = (Ok $ lens mi, iw)
+				(Ok _, iw) = (Ok $ notifyPred mi, iw)
 
-	lens Nothing (Just p) = False
-	lens Nothing Nothing = True
-	lens (Just (d1, i1)) (Just (d2, i2)) = d1 == d2 && (i2 == -1 || i1 == i2)
+	notifyPred :: (Maybe (MTaskDevice, Int)) (Maybe (MTaskDevice, Int)) -> Bool
+	// Global watcher looking at a global event
+	notifyPred Nothing Nothing = True
+	// Global watcher looking at a local event
+	notifyPred Nothing (Just _) = False
+	// Local watcher looking at a global event
+	notifyPred (Just _) Nothing = False
+	// Local device watcher looking at a local event
+	notifyPred (Just (d1, -1)) (Just (d2, _)) = d1 == d2
+	// Local share watcher looking at a local share event
+	notifyPred (Just (d1, i1)) (Just (d2, i2)) = d1 == d2 && i1 == i2
 
 realDeviceStore :: Shared [MTaskDevice]
-realDeviceStore = sharedStore "mTaskDevices" []
+realDeviceStore = memoryShare "mTaskDevices" []
 
 bcStateStore :: Shared BCState
 bcStateStore = memoryShare "mTaskBCState" zero
diff --git a/miTask.icl b/miTask.icl
index 918b414..233e072 100644
--- a/miTask.icl
+++ b/miTask.icl
@@ -56,8 +56,7 @@ demo = viewSharedInformation "Devices" [] deviceStoreNP
 mTaskManager :: Task ()
 mTaskManager = (>>|) startupDevices $ 
 		viewmTasks ||-
-		((manageShares ||- whileUnchanged deviceStoreNP (manageDevices process))
-			<<@ ArrangeSplit Vertical True)
+		((manageShares ||- forever (manageDevices process)) <<@ ArrangeSplit Vertical True)
 		<<@ ArrangeWithSideBar 0 LeftSide 260 True
 	where
 		viewmTasks :: Task String