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

Mart Lubbers's avatar
Mart Lubbers committed
3
import Data.Tuple
Mart Lubbers's avatar
Mart Lubbers committed
4
import StdEnv
Mart Lubbers's avatar
Mart Lubbers committed
5

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

Mart Lubbers's avatar
Mart Lubbers committed
10
import iTasks
11 12
import iTasks.Internal.IWorld
import iTasks.Internal.SDS
Mart Lubbers's avatar
Mart Lubbers committed
13 14
import iTasks.Internal.Util
import iTasks.Internal.Task
15
import iTasks.Internal.TaskEval
Mart Lubbers's avatar
Mart Lubbers committed
16 17 18
import iTasks.Internal.TaskState

import TTY
Mart Lubbers's avatar
Mart Lubbers committed
19

Mart Lubbers's avatar
Mart Lubbers committed
20
:: *Resource | TTYd String *TTY
Mart Lubbers's avatar
Mart Lubbers committed
21 22 23

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

Mart Lubbers's avatar
Mart Lubbers committed
24
syncSerialChannel :: Timespec TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared sds ([a],[b],Bool)) -> Task () | iTask a & iTask b & RWShared sds
Mart Lubbers's avatar
Mart Lubbers committed
25
syncSerialChannel poll opts enc dec rw = Task evalinit
Mart Lubbers's avatar
Mart Lubbers committed
26
where
Mart Lubbers's avatar
Mart Lubbers committed
27 28 29 30 31 32 33 34 35 36
	evalinit DestroyEvent _ iworld = (DestroyedResult, iworld)
	evalinit event evalOpts iworld
		# (mtty, iworld=:{world,resources}) = getResource iworld
		= case mtty of
			[] = case TTYopen opts world of
				(False, _, world)
					= appFst exc $ liftIWorld TTYerror {iworld&world=world}
				(True, tty, world)
					= eval "" event evalOpts {iworld&world=world,resources=[TTYd opts.devicePath tty:resources]}
			_ = (exc "This tty was already open", iworld)
37

Mart Lubbers's avatar
Mart Lubbers committed
38 39 40 41 42 43 44 45 46 47 48 49
	withTTY f iworld
		# (mtty, iworld) = getResource iworld
		= case mtty of
			[] = (exc "This tty was already closed", iworld)
			[_,_:_]  = (exc "Multiple matching resources", iworld)
			[tty] = f tty iworld

	eval acc DestroyEvent evalOpts
		= withTTY \(TTYd _ tty) iworld
			# (ok, iworld) = liftIWorld (TTYclose tty) iworld
			| not ok = (exc "Couldn't close device", iworld)
			= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
50

Mart Lubbers's avatar
Mart Lubbers committed
51 52
	eval acc event evalOpts=:{taskId,lastEval}
		= withTTY \(TTYd dp tty) iworld
Mart Lubbers's avatar
Mart Lubbers committed
53 54
			# (merr, iworld) = readRegister taskId ticker iworld
			| isError merr = (ExceptionResult (fromError merr), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
55
			//TODO Keep async in mind
56
			# (merr, iworld) = read rw EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
57 58 59
			| isError merr = (ExceptionResult (fromError merr), iworld)
			= case fromOk merr of
				//We need to stop
60
				ReadingDone (_,_,True)
Mart Lubbers's avatar
Mart Lubbers committed
61
						# (ok, iworld) = liftIWorld (TTYclose tty) iworld
62
						| not ok = (exc "Couldn't close device", iworld)
Mart Lubbers's avatar
Mart Lubbers committed
63
						= (ValueResult NoValue (mkTaskEvalInfo lastEval) NoChange (return ()), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
64
				ReadingDone (r,s,ss)
Mart Lubbers's avatar
Mart Lubbers committed
65
					# tty = foldr TTYwrite tty $ reverse $ map enc s
66 67
					# (merr, tty) = readWhileAvailable tty
					| isError merr = (exc (fromError merr), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
68
					# iworld = {iworld & resources=[TTYd dp tty:iworld.resources]}
69
					= case dec (acc +++ toString (fromOk merr)) of
Mart Lubbers's avatar
Mart Lubbers committed
70
						(Left err, newacc) = (exc ("Error while parsing: " +++ join " " [toString (toInt c)\\c<-:acc+toString (fromOk merr)]), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
71 72
						(Right msgs, newacc)
							# (merr, iworld) = if (msgs =: [] && s =: [])
Mart Lubbers's avatar
Mart Lubbers committed
73 74 75
								(Ok WritingDone, iworld)
								//TODO Keep async in mind
								(write (r++msgs, [], False) rw EmptyContext iworld)
Mart Lubbers's avatar
Mart Lubbers committed
76 77 78
							| isError merr = (ExceptionResult (fromError merr), iworld)
							= (ValueResult
								NoValue
Mart Lubbers's avatar
Mart Lubbers committed
79 80 81
								(mkTaskEvalInfo lastEval)
								(mkUIIfReset event $ stringDisplay $ "Serial client" <+++ opts.devicePath)
								(Task (eval newacc))
Mart Lubbers's avatar
Mart Lubbers committed
82 83
							  , iworld)

84
	ticker = sdsFocus {start=zero,interval=poll} iworldTimespec
Mart Lubbers's avatar
Mart Lubbers committed
85

Mart Lubbers's avatar
Mart Lubbers committed
86
	getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
Mart Lubbers's avatar
Mart Lubbers committed
87 88

	exc :: (String -> TaskResult ())
Mart Lubbers's avatar
Mart Lubbers committed
89 90
	exc = ExceptionResult o exception

91
readWhileAvailable :: !*TTY -> (MaybeError String [Char], !*TTY)
92
readWhileAvailable tty
93 94 95
# (available, error, tty) = TTYavailable tty
| error = (Error "TTY device disconnected", tty)
| not available = (Ok [], tty)
96
# (c, tty) = TTYread tty
97 98 99
# (merr, tty) = readWhileAvailable tty
| isError merr = (merr, tty)
= (Ok [toChar c:fromOk merr], tty)