iTasksTTY.icl 5.06 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
enterTTYSettings :: Task TTYSettings
enterTTYSettings = accWorld getTTYDevices
Mart Lubbers's avatar
Mart Lubbers committed
35
36
37
38
39
40
41
42
43
44
45
46
47
	>>= \ds->(
				enterChoice "Device" [] ds 
			-&&- updateInformation "Baudrate" [] B9600
			<<@ ArrangeHorizontal)
		-&&- (
				updateInformation "Bytesize" [] BytesizeEight
			-&&- updateInformation "Parity" [] ParityNone
			<<@ ArrangeHorizontal)
		-&&- (
				updateInformation "Stop2bits" [] False
			-&&- updateInformation "Xonoff" [] False
			<<@ ArrangeHorizontal)
	@ \((dev, br), ((bs, pr), (st, xo)))->makeTTYSettings dev br bs pr st xo
48

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
64
65
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
66
	where
Mart Lubbers's avatar
Mart Lubbers committed
67
		eval sh event evalOpts tree=:(TCInit taskId ts) iworld
68
69
70
71
72
73
74
75
76
		# (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
77
				= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec sh rw)) iworld of
78
79
80
					(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
81

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

Mart Lubbers's avatar
Mart Lubbers committed
85
		eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
86
87
88
89
90
91
92
93
94
		# (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
95

96
97
		rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath

98
99
100
101
102
103
104
105
106
107
/*
 * 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
108
109
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
110
111
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
112

113
		//We need to stop
Mart Lubbers's avatar
Mart Lubbers committed
114
		(Ok (_,_,True), iworld) = (Ok (), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
115

116
		(Ok (r,s,ss), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
117
118
119
		# (merr, iworld) = read accShare iworld
		| isError merr = (liftError merr, iworld)
		# (Ok acc) = merr
120
121
122
123
124
		# (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
125
			# (newdata, tty) = readWhileAvailable tty
126
			# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]}
Mart Lubbers's avatar
Mart Lubbers committed
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
			= case dec (acc +++ newdata) of
				(Left err, newacc) = (Error (exception "Error while parsing"), iworld)
				(Right msgs, newacc)
					# (merr, iworld) = if (msgs =: [])
						(Ok (), iworld)
						(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)