iTasksTTY.icl 5.12 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
			= case dec (acc +++ newdata) of
				(Left err, newacc) = (Error (exception "Error while parsing"), iworld)
				(Right msgs, newacc)
					# (merr, iworld) = if (msgs =: [])
131 132 133
						if (s =: [])
							(Ok (), iworld)
							(write (r, [], False) rw iworld)
Mart Lubbers's avatar
Mart Lubbers committed
134 135 136 137 138 139 140 141 142 143 144
						(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)