iTasksTTY.icl 3.66 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
11

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

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

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

25
:: *Resource | TTYd !*TTY Int
Mart Lubbers's avatar
Mart Lubbers committed
26
27
28

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

29
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))
		prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
Mart Lubbers's avatar
Mart Lubbers committed
36

37
38
39
40
41
42
43
44
45
46
enterTTYSettings :: Task TTYSettings
enterTTYSettings = accWorld getTTYDevices
	>>= \ds->(((((enterChoice "Device" [] ds
	-&&- updateInformation "Baudrate" [] B9600)
	-&&- updateInformation "Bytesize" [] BytesizeEight)
	-&&- updateInformation "Parity" [] ParityNone)
	-&&- updateInformation "Stop2bits" [] False)
	-&&- updateInformation "Xonoff" [] False)
	@ (uncurry o uncurry o uncurry o uncurry o uncurry) makeTTYSettings

Mart Lubbers's avatar
Mart Lubbers committed
47
48
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
49
	where
50
		eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world,ioTasks={todo}}
Mart Lubbers's avatar
Mart Lubbers committed
51
		= case TTYopen opts world of
Mart Lubbers's avatar
Mart Lubbers committed
52
53
54
55
			(False, _, world)
			# (err, world) = TTYerror world
			= (ExceptionResult (exception err), {iworld & world=world})
			(True, tty, world)
56
57
			# iworld = {iworld & world=world}
			= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask enc dec rw)) iworld of
Mart Lubbers's avatar
Mart Lubbers committed
58
				(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
59
				(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False), {iworld & resources=Just (TTYd tty bgid)})
Mart Lubbers's avatar
Mart Lubbers committed
60
61

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

		eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
65
		# (TTYd tty bgid) = fromJust resources
Mart Lubbers's avatar
Mart Lubbers committed
66
67
		# (ok, world) = TTYclose tty world
		# iworld = {iworld & world=world,resources=Nothing}
68
		= case removeBackgroundTask bgid iworld of
Mart Lubbers's avatar
Mart Lubbers committed
69
70
71
			(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
			(Ok _, iworld) = (DestroyedResult, iworld)

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
		rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath

serialDeviceBackgroundTask :: (b -> String) (String -> a) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask enc dec rw iworld
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
		(Ok (r,s,ss), iworld)
		# (Just (TTYd tty bgid)) = iworld.resources
		# tty = writet (map enc s) tty
		# (ml, tty) = case TTYavailable tty of
			(False, tty) = ([], tty)
			(_, tty) = appFst (pure o dec) $ TTYreadline tty
		# iworld = {iworld & resources=Just (TTYd tty bgid)}
		= case write (r++ml,[],False) rw iworld of
			(Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
Mart Lubbers's avatar
Mart Lubbers committed
87
88
89
			(Ok _, iworld)
			| isEmpty r = (Ok (), iworld)
			= case notify rw iworld of
90
91
92
93
94
95
				(Error e, iworld) = (Error $ exception "share couldn't be notified", iworld)
				(Ok _, iworld) = (Ok (), iworld)
	where
		writet :: [String] -> (*TTY -> *TTY)
		writet [] = id
		writet [x:xs] = writet xs o TTYwrite x