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

Mart Lubbers's avatar
Mart Lubbers committed
3
4
import TTY

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

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

Mart Lubbers's avatar
Mart Lubbers committed
19
20
21
22
23
24
25
import iTasks.UI.Definition

import iTasks._Framework.TaskState
import iTasks._Framework.TaskServer
import iTasks._Framework.IWorld
import iTasks._Framework.Store

26
:: *Resource | TTYd *[*(String,Int,!*TTY)]
Mart Lubbers's avatar
Mart Lubbers committed
27
28
29

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

30
31
32
33
34
35
getTTYDevices :: !*env -> *(![String], !*env)
getTTYDevices w = case readDirectory "/dev" w of
	(Error (errcode, errmsg), w) = abort errmsg
	(Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
	where
		isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
36
		prefixes = ["tty", "rfcomm"]
Mart Lubbers's avatar
Mart Lubbers committed
37

38
39
enterTTYSettings :: Task TTYSettings
enterTTYSettings = accWorld getTTYDevices
Mart Lubbers's avatar
Mart Lubbers committed
40
41
42
43
44
45
46
47
48
49
50
51
52
	>>= \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
53

Mart Lubbers's avatar
Mart Lubbers committed
54
55
syncSerialChannel :: TTYSettings (b -> String) (String -> a) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel opts enc dec rw = Task eval
Mart Lubbers's avatar
Mart Lubbers committed
56
	where
57
		eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world,ioTasks={todo}}
Mart Lubbers's avatar
Mart Lubbers committed
58
		= case TTYopen opts world of
Mart Lubbers's avatar
Mart Lubbers committed
59
60
61
62
			(False, _, world)
			# (err, world) = TTYerror world
			= (ExceptionResult (exception err), {iworld & world=world})
			(True, tty, world)
63
			# iworld = {iworld & world=world}
64
			= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec rw)) iworld of
Mart Lubbers's avatar
Mart Lubbers committed
65
				(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
66
67
68
69
70
				(Ok bgid, iworld) = case iworld.resources of
					Nothing = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
						{iworld & resources=Just $ TTYd [(opts.devicePath, bgid, tty)]})
					Just (TTYd m) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
						{iworld & resources=Just $ TTYd [(opts.devicePath, bgid, tty):m]})
Mart Lubbers's avatar
Mart Lubbers committed
71
72

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

		eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
76
77
		# (Just (TTYd ttys)) = resources
		# ((tty, bgid), ttys) = flt opts.devicePath ttys
Mart Lubbers's avatar
Mart Lubbers committed
78
		# (ok, world) = TTYclose tty world
79
		# iworld = {iworld & world=world,resources=Just $ TTYd ttys}
80
		= case removeBackgroundTask bgid iworld of
Mart Lubbers's avatar
Mart Lubbers committed
81
82
83
			(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
			(Ok _, iworld) = (DestroyedResult, iworld)

84
85
		rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath

86
87
88
89
90
91
92
93
94
95
flt :: String [(String, Int, *TTY)] -> ((*TTY, Int), [(String, Int, *TTY)])
flt m [] = abort "not found"
flt m [(p,b,t):ps]
| p == m = ((t, b), ps)
# (tty, pps) = flt m ps 
= (tty, [(p,b,t):pps])

import StdDebug, StdMisc
serialDeviceBackgroundTask :: String (b -> String) (String -> a) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask dp enc dec rw iworld
96
97
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
98
		//We need to stop
Mart Lubbers's avatar
Mart Lubbers committed
99
		(Ok (_,_,True), iworld) = (Ok (), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
100

101
		(Ok (r,s,ss), iworld)
102
103
		# (Just (TTYd ttys)) = iworld.resources
		# ((tty, bgid), ttys) = flt dp ttys
Mart Lubbers's avatar
Mart Lubbers committed
104
		# tty = foldr TTYwrite tty $ reverse $ map enc s
105
106
107
		# (ml, tty) = case TTYavailable tty of
			(False, tty) = ([], tty)
			(_, tty) = appFst (pure o dec) $ TTYreadline tty
108
		# iworld = {iworld & resources=Just (TTYd [(dp, bgid, tty):ttys])}
Mart Lubbers's avatar
Mart Lubbers committed
109
		| isEmpty ml && isEmpty s = (Ok (), iworld)
Mart Lubbers's avatar
update    
Mart Lubbers committed
110
111
		# (merr, iworld) = notify rw iworld
		| isError merr = (Error $ fromError merr, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
112
		= write (r++ml,[],False) rw iworld