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

3
import System.OS
Mart Lubbers's avatar
Mart Lubbers committed
4 5
import TTY

6
import StdList
Mart Lubbers's avatar
Mart Lubbers committed
7
from StdFunc import o, flip
8 9
import StdMisc
import StdString
10
import Data.List
11
import qualified Data.Map as DM
12 13

import System.Directory
Mart Lubbers's avatar
Mart Lubbers committed
14
import iTasks
15 16
import Data.Tuple
import Control.Applicative
Mart Lubbers's avatar
Mart Lubbers committed
17
from Data.Func import $
18 19
from Text import class Text(startsWith), instance Text String

Mart Lubbers's avatar
Mart Lubbers committed
20 21
import iTasks.UI.Definition

22 23 24 25 26 27
import iTasks.Internal.IWorld
import iTasks.Internal.TaskState
import iTasks.Internal.Task
import iTasks.Internal.SDS
import iTasks.Internal.TaskServer
import iTasks.Internal.TaskEval
Mart Lubbers's avatar
Mart Lubbers committed
28

Mart Lubbers's avatar
Mart Lubbers committed
29
:: *Resource | TTYd String *TTY
Mart Lubbers's avatar
Mart Lubbers committed
30 31 32

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

33 34
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
35
where
36
	eval event evalOpts tree=:(TCInit taskId ts) iworld
Mart Lubbers's avatar
Mart Lubbers committed
37 38 39 40
	# (mtty, iworld=:{world,resources}) = getResource iworld
	= case mtty of
		[] = case TTYopen opts iworld.world of
			(False, _, world)
41
				# (err, world) = TTYerror world
Mart Lubbers's avatar
Mart Lubbers committed
42 43 44 45 46 47 48 49
				= (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
50
				(TCBasic taskId ts (DeferredJSONNode $ JSONString "") False)
Mart Lubbers's avatar
Mart Lubbers committed
51 52 53
			  , iworld)
		_ = (exc "This tty was already open", iworld)

54
	eval _ _ tree=:(TCBasic taskId ts (DeferredJSONNode (JSONString acc)) _) iworld
Mart Lubbers's avatar
Mart Lubbers committed
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
	# (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
75 76
					# (merr, tty) = readWhileAvailable tty
					| isError merr = (exc (fromError merr), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
77
					# iworld = {iworld & resources=[TTYd dp tty:iworld.resources]}
78
					= case dec (acc +++ toString (fromOk merr)) of
Mart Lubbers's avatar
Mart Lubbers committed
79 80 81 82 83 84 85 86 87 88
						(Left err, newacc) = (exc "Error while parsing", iworld)
						(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
89
								(TCBasic taskId ts (DeferredJSONNode $ JSONString newacc) False)
Mart Lubbers's avatar
Mart Lubbers committed
90 91
							  , iworld)

92
	eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
Mart Lubbers's avatar
Mart Lubbers committed
93 94 95 96 97 98 99 100 101 102 103
	# (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
104
	ticker = sdsFocus {start=zero,interval=poll} iworldTimespec
Mart Lubbers's avatar
Mart Lubbers committed
105 106 107
	getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
	exc = ExceptionResult o exception

108 109
import StdMisc, StdDebug
readWhileAvailable :: !*TTY -> (MaybeError String [Char], !*TTY)
110
readWhileAvailable tty
111 112 113
# (available, error, tty) = TTYavailable tty
| error = (Error "TTY device disconnected", tty)
| not available = (Ok [], tty)
114
# (c, tty) = TTYread tty
115 116 117 118
| not (trace_tn ("Read: " +++ toString c)) = undef
# (merr, tty) = readWhileAvailable tty
| isError merr = (merr, tty)
= (Ok [toChar c:fromOk merr], tty)