Commit 8a5d4227 authored by Mart Lubbers's avatar Mart Lubbers

better background instance handling

parent ad5a279b
......@@ -21,6 +21,8 @@ from StdClass import class zero
instance zero TTYSettings
makeTTYSettings :: String BaudRate ByteSize Parity Bool Bool -> TTYSettings
TTYclose :: !*TTY !*env -> (!Bool, !*env)
TTYerror :: !*env -> (!String, !*env)
TTYopen :: !TTYSettings !*env -> (!Bool,!*TTY,!*env)
......
......@@ -34,6 +34,10 @@ instance toInt Parity where
ParityNone = 0; ParityOdd = 1; ParityEven = 2; ParitySpace = 3;
ParityMark = 4
makeTTYSettings :: String BaudRate ByteSize Parity Bool Bool -> TTYSettings
makeTTYSettings dp br bs pr sb xx = {TTYSettings | devicePath=dp, baudrate=br,
bytesize=bs, parity=pr, stop2bits=sb, xonxoff=xx}
TTYopen :: !TTYSettings !*env -> (!Bool, !*TTY, !*env)
TTYopen ts w = TTYopen2
ts.devicePath
......
......@@ -7,4 +7,6 @@ derive class iTask TTYSettings
getTTYDevices :: !*env -> *(![String], !*env)
enterTTYSettings :: Task TTYSettings
syncSerialChannel :: TTYSettings (b -> String) (String -> a) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
......@@ -6,9 +6,12 @@ import StdList
from StdFunc import o, flip
import StdMisc
import StdString
import Data.List
import System.Directory
import iTasks
import Data.Tuple
import Control.Applicative
from Data.Func import $
from Text import class Text(startsWith), instance Text String
......@@ -19,7 +22,7 @@ import iTasks._Framework.TaskServer
import iTasks._Framework.IWorld
import iTasks._Framework.Store
:: *Resource | TTYd !*TTY
:: *Resource | TTYd !*TTY Int
derive class iTask TTYSettings, Parity, BaudRate, ByteSize
......@@ -31,50 +34,60 @@ getTTYDevices w = case readDirectory "/dev" w of
isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
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
syncSerialChannel :: TTYSettings (b -> String) (String -> a) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel opts enc dec rw = Task eval
where
eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world,ioTasks={todo}}
= case TTYopen opts world of
(False, _, world)
# (err, world) = TTYerror world
= (ExceptionResult (exception err), {iworld & world=world})
(True, tty, world)
# iworld = {iworld & world=world, resources=Just (TTYd tty)}
= case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
# iworld = {iworld & world=world}
= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask enc dec rw)) iworld of
(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
(Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoChange (TCBasic taskId ts JSONNull False), iworld)
(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False), {iworld & resources=Just (TTYd tty bgid)})
eval _ _ tree=:(TCBasic _ ts _ _) iworld
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} rep tree, iworld)
eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
# (TTYd tty) = fromJust resources
# (TTYd tty bgid) = fromJust resources
# (ok, world) = TTYclose tty world
# iworld = {iworld & world=world,resources=Nothing}
= case removeBackgroundTask 42 iworld of
= case removeBackgroundTask bgid iworld of
(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
(Ok _, iworld) = (DestroyedResult, iworld)
// serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld)
serialDeviceBackgroundTask 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)) = iworld.resources
# tty = writet (map enc s) tty
# (ml, tty) = case TTYavailable tty of
(False, tty) = ([], tty)
(_, tty)
# (l, tty) = TTYreadline tty
= ([dec l], tty)
# iworld = {iworld & resources=Just (TTYd tty)}
= case write (r++ml,[],False) rw iworld of
(Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
(Ok _, iworld) = case notify rw iworld of
(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
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)
(Ok _, iworld) = case notify rw iworld of
(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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment