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

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

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
getTTYResource :: String *IWorld -> (Maybe *(*TTY, Int), *IWorld)
getTTYResource dp iw=:{resources}
# (mt, resources) = getTTYResource` resources
= (mt, {iw & resources=resources})
where
	getTTYResource` :: *[*Resource] -> (Maybe *(*TTY, Int), *[*Resource])
	getTTYResource` [] = (Nothing, [])
	getTTYResource` [TTYd (dpath, bgid, tty):xs]
	| dpath == dp = (Just (tty, bgid), xs)
	getTTYResource` [x:xs]
	# (mt, xs) = getTTYResource` xs
	= (mt, [x:xs])

liftWorld f = \iw=:{world}->{iw & world=f world}

Mart Lubbers's avatar
Mart Lubbers committed
48
49
syncSerialChannel :: TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel opts enc dec rw = withShared "" \sh->Task $ eval sh
Mart Lubbers's avatar
Mart Lubbers committed
50
	where
Mart Lubbers's avatar
Mart Lubbers committed
51
		eval sh event evalOpts tree=:(TCInit taskId ts) iworld
52
53
54
55
56
57
58
59
60
		# (mtty, iworld) = getTTYResource opts.devicePath iworld
		= case mtty of
			Just (tty, _) = (ExceptionResult (exception "This tty was already open"), iworld)
			Nothing = case TTYopen opts iworld.world of
				(False, _, world)
				# (err, world) = TTYerror world
				= (ExceptionResult (exception err), {iworld & world=world})
				(True, tty, world)
				# iworld = {iworld & world=world}
Mart Lubbers's avatar
Mart Lubbers committed
61
				= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec sh rw)) iworld of
62
63
64
					(Error e, iworld) = (ExceptionResult (exception "background task couldn't be added"), iworld)
					(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
						{iworld & resources=[TTYd (opts.devicePath, bgid, tty):iworld.resources]})
Mart Lubbers's avatar
Mart Lubbers committed
65

Mart Lubbers's avatar
Mart Lubbers committed
66
		eval _ _ _ tree=:(TCBasic _ ts _ _) iworld
67
		= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} rep tree, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
68

Mart Lubbers's avatar
Mart Lubbers committed
69
		eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
70
71
72
73
74
75
76
77
78
		# (mtty, iworld) = getTTYResource opts.devicePath iworld
		= case mtty of
			Nothing = (ExceptionResult (exception "This tty was already closed"), iworld)
			Just (tty, bgid)
			# (ok, world) = TTYclose tty iworld.world
			# iworld = {iworld & world=world}
			= case removeBackgroundTask bgid iworld of
				(Error e, iworld) = (ExceptionResult e, iworld)
				(Ok _, iworld) = (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
79

80
81
		rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath

82
83
84
85
86
87
88
89
90
91
/*
 * The actual backgroundtask synchronizing the device
 *
 * @param Device path
 * @param encoding function
 * @param decoding function
 * @param shared channels
 * @param IWorld
 * @return Maybe an exception
 */
Mart Lubbers's avatar
Mart Lubbers committed
92
93
serialDeviceBackgroundTask :: String (b -> String) (String -> (Either String [a], String)) (Shared String) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask dp enc dec accShare rw iworld
94
95
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
96

97
		//We need to stop
Mart Lubbers's avatar
Mart Lubbers committed
98
		(Ok (_,_,True), iworld) = (Ok (), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
99

100
		(Ok (r,s,ss), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
101
102
103
		# (merr, iworld) = read accShare iworld
		| isError merr = (liftError merr, iworld)
		# (Ok acc) = merr
104
105
106
107
108
		# (mtty, iworld) = getTTYResource dp iworld
		= case mtty of
			Nothing = (Error (exception "The tty device is gone"), iworld)
			Just (tty, bgid)
			# tty = foldr TTYwrite tty $ reverse $ map enc s
Mart Lubbers's avatar
Mart Lubbers committed
109
			# (newdata, tty) = readWhileAvailable tty
110
			# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]}
Mart Lubbers's avatar
Mart Lubbers committed
111
112
113
114
			= case dec (acc +++ newdata) of
				(Left err, newacc) = (Error (exception "Error while parsing"), iworld)
				(Right msgs, newacc)
					# (merr, iworld) = if (msgs =: [])
Mart Lubbers's avatar
updates    
Mart Lubbers committed
115
116
117
						if (s =: [])
							(Ok (), iworld)
							(write (r, [], False) rw iworld)
Mart Lubbers's avatar
Mart Lubbers committed
118
119
120
121
122
123
124
125
126
127
128
						(write (r++msgs, [], False) rw iworld)
					| isError merr = (liftError merr, iworld)
					= write newacc accShare iworld

readWhileAvailable :: !*TTY -> (String, !*TTY)
readWhileAvailable tty
# (available, tty) = TTYavailable tty
| not available = ("", tty)
# (c, tty) = TTYread tty
# (cs, tty) = readWhileAvailable tty
= (toString (toChar c) +++ cs, tty)