iTasksTTY.icl 3.75 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

5
from Data.Map import :: Map, newMap
Mart Lubbers's avatar
Mart Lubbers committed
6
7
import Data.Func
import Text
8

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

import TTY
Mart Lubbers's avatar
Mart Lubbers committed
16

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

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

21
22
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
23
where
24
	eval event evalOpts tree=:(TCInit taskId ts) iworld
Mart Lubbers's avatar
Mart Lubbers committed
25
26
27
28
	# (mtty, iworld=:{world,resources}) = getResource iworld
	= case mtty of
		[] = case TTYopen opts iworld.world of
			(False, _, world)
29
				# (err, world) = TTYerror world
Mart Lubbers's avatar
Mart Lubbers committed
30
31
32
33
34
35
				= (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
36
				{TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes=newMap}
Mart Lubbers's avatar
Mart Lubbers committed
37
				rep
Mart Lubbers's avatar
Mart Lubbers committed
38
				(TCBasic taskId ts (DeferredJSONNode $ JSONString "") False)
Mart Lubbers's avatar
Mart Lubbers committed
39
40
41
			  , iworld)
		_ = (exc "This tty was already open", iworld)

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

80
	eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
Mart Lubbers's avatar
Mart Lubbers committed
81
82
83
84
85
86
87
88
89
90
91
	# (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
92
	ticker = sdsFocus {start=zero,interval=poll} iworldTimespec
Mart Lubbers's avatar
Mart Lubbers committed
93
94
95
	getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
	exc = ExceptionResult o exception

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