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

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

Mart Lubbers's avatar
Mart Lubbers committed
53
54
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
55
	where
56
		eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world,ioTasks={todo}}
Mart Lubbers's avatar
Mart Lubbers committed
57
		= case TTYopen opts world of
Mart Lubbers's avatar
Mart Lubbers committed
58
59
60
61
			(False, _, world)
			# (err, world) = TTYerror world
			= (ExceptionResult (exception err), {iworld & world=world})
			(True, tty, world)
62
63
			# iworld = {iworld & world=world}
			= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask enc dec rw)) iworld of
Mart Lubbers's avatar
Mart Lubbers committed
64
				(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
65
				(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
66
67

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

		eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
71
		# (TTYd tty bgid) = fromJust resources
Mart Lubbers's avatar
Mart Lubbers committed
72
73
		# (ok, world) = TTYclose tty world
		# iworld = {iworld & world=world,resources=Nothing}
74
		= case removeBackgroundTask bgid iworld of
Mart Lubbers's avatar
Mart Lubbers committed
75
76
77
			(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
			(Ok _, iworld) = (DestroyedResult, iworld)

78
79
80
81
82
83
		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)
84
		//We need to stop
Mart Lubbers's avatar
Mart Lubbers committed
85
		(Ok (_,_,True), iworld) = (Ok (), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
86

87
88
		(Ok (r,s,ss), iworld)
		# (Just (TTYd tty bgid)) = iworld.resources
Mart Lubbers's avatar
Mart Lubbers committed
89
		# tty = foldr TTYwrite tty $ reverse $ map enc s
90
91
92
93
		# (ml, tty) = case TTYavailable tty of
			(False, tty) = ([], tty)
			(_, tty) = appFst (pure o dec) $ TTYreadline tty
		# iworld = {iworld & resources=Just (TTYd tty bgid)}
Mart Lubbers's avatar
Mart Lubbers committed
94
		| isEmpty ml && isEmpty s = (Ok (), iworld)
Mart Lubbers's avatar
update    
Mart Lubbers committed
95
96
		# (merr, iworld) = notify rw iworld
		| isError merr = (Error $ fromError merr, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
97
		= write (r++ml,[],False) rw iworld