iTasksTTY.icl 3.73 KB
Newer Older
1
2
implementation module iTasksTTY

Mart Lubbers's avatar
Mart Lubbers committed
3
import StdEnv
Mart Lubbers's avatar
Mart Lubbers committed
4

Mart Lubbers's avatar
Mart Lubbers committed
5
6
import Data.Func
import Text
7

Mart Lubbers's avatar
Mart Lubbers committed
8
import iTasks
9
10
11
import iTasks.Internal.IWorld
import iTasks.Internal.SDS
import iTasks.Internal.TaskEval
Mart Lubbers's avatar
Mart Lubbers committed
12
13
14
import iTasks.Internal.TaskState

import TTY
Mart Lubbers's avatar
Mart Lubbers committed
15

Mart Lubbers's avatar
Mart Lubbers committed
16
:: *Resource | TTYd String *TTY
Mart Lubbers's avatar
Mart Lubbers committed
17
18
19

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

20
21
syncSerialChannel :: Timespec TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel poll opts enc dec rw = Task eval
Mart Lubbers's avatar
Mart Lubbers committed
22
where
23
	eval event evalOpts tree=:(TCInit taskId ts) iworld
Mart Lubbers's avatar
Mart Lubbers committed
24
25
26
27
	# (mtty, iworld=:{world,resources}) = getResource iworld
	= case mtty of
		[] = case TTYopen opts iworld.world of
			(False, _, world)
28
				# (err, world) = TTYerror world
Mart Lubbers's avatar
Mart Lubbers committed
29
30
31
32
33
34
35
36
				= (exc err, {iworld & world=world})
			(True, tty, world)
			# (merr, iworld) = readRegister taskId ticker {iworld & world=world, resources=[TTYd opts.devicePath tty:resources]}
			| isError merr = (ExceptionResult (fromError merr), iworld)
			= (ValueResult
				NoValue
				{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
				rep
Mart Lubbers's avatar
Mart Lubbers committed
37
				(TCBasic taskId ts (DeferredJSONNode $ JSONString "") False)
Mart Lubbers's avatar
Mart Lubbers committed
38
39
40
			  , iworld)
		_ = (exc "This tty was already open", iworld)

41
	eval _ _ tree=:(TCBasic taskId ts (DeferredJSONNode (JSONString acc)) _) iworld
Mart Lubbers's avatar
Mart Lubbers committed
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
	# (mtty, iworld) = getResource iworld
	= case mtty of
		[] = (exc"TTY resource lost", iworld)
		[_,_:_] = (exc "Multiple matching resources", iworld)
		[TTYd dp tty]
			# (merr, iworld) = readRegister taskId ticker iworld
			| isError merr = (ExceptionResult (fromError merr), iworld)
			# (merr, iworld=:{resources}) = read rw iworld
			| isError merr = (ExceptionResult (fromError merr), iworld)
			= case fromOk merr of
				//We need to stop
				(_,_,True) =
					(ValueResult
						(Value () True)
						{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
						rep
						(TCDestroy tree)
					, {iworld & resources=[TTYd dp tty:resources]})
				(r,s,ss)
					# tty = foldr TTYwrite tty $ reverse $ map enc s
62
63
					# (merr, tty) = readWhileAvailable tty
					| isError merr = (exc (fromError merr), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
64
					# iworld = {iworld & resources=[TTYd dp tty:iworld.resources]}
65
					= case dec (acc +++ toString (fromOk merr)) of
Mart Lubbers's avatar
Mart Lubbers committed
66
						(Left err, newacc) = (exc ("Error while parsing: " +++ join " " [toString (toInt c)\\c<-:acc+toString (fromOk merr)]), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
67
68
69
70
71
72
73
74
75
						(Right msgs, newacc)
							# (merr, iworld) = if (msgs =: [] && s =: [])
								(Ok (), iworld)
								(write (r++msgs, [], False) rw iworld)
							| isError merr = (ExceptionResult (fromError merr), iworld)
							= (ValueResult
								NoValue
								{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
								rep
Mart Lubbers's avatar
Mart Lubbers committed
76
								(TCBasic taskId ts (DeferredJSONNode $ JSONString newacc) False)
Mart Lubbers's avatar
Mart Lubbers committed
77
78
							  , iworld)

79
	eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
Mart Lubbers's avatar
Mart Lubbers committed
80
81
82
83
84
85
86
87
88
89
90
	# (mtty, iworld) = getResource iworld
	= case mtty of
		[] = (exc "This tty was already closed", iworld)
		[_,_:_]  = (exc "Multiple matching resources", iworld)
		[TTYd _ tty]
		# (ok, world) = TTYclose tty iworld.world
		# iworld & world = world
		| not ok = (exc "Couldn't close device", iworld)
		= (DestroyedResult, iworld)

	rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath
91
	ticker = sdsFocus {start=zero,interval=poll} iworldTimespec
Mart Lubbers's avatar
Mart Lubbers committed
92
93
94
	getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
	exc = ExceptionResult o exception

95
readWhileAvailable :: !*TTY -> (MaybeError String [Char], !*TTY)
Mart Lubbers's avatar
Mart Lubbers committed
96
readWhileAvailable tty
97
98
99
# (available, error, tty) = TTYavailable tty
| error = (Error "TTY device disconnected", tty)
| not available = (Ok [], tty)
Mart Lubbers's avatar
Mart Lubbers committed
100
# (c, tty) = TTYread tty
101
102
103
# (merr, tty) = readWhileAvailable tty
| isError merr = (merr, tty)
= (Ok [toChar c:fromOk merr], tty)