3 import StdDebug, StdMisc
4 from StdFunc import flip
9 from Text import class Text(startsWith,concat,split,join), instance Text String
11 import qualified Data.Map as DM
13 from Data.Func import $
16 import System.Directory
18 import iTasks.UI.Definition
20 import iTasks._Framework.TaskState
21 import iTasks._Framework.TaskServer
22 import iTasks._Framework.IWorld
23 import iTasks._Framework.Store
28 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
29 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
31 :: *Resource | TTYd !*TTY
32 :: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool)
34 :: SerTCP = SerialDevice | TCPDevice
36 deviceConnected :: Maybe String,
38 deviceTasks :: [(String, Int)]
45 Start :: *World -> *World
46 Start world = startEngine (mTaskManager
47 >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
49 memoryShare :: String a -> Shared a | iTask a
50 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
52 deviceStore :: Shared [MTaskDevice]
53 deviceStore = memoryShare "mTaskDevices" []
55 sdsStore :: Shared [MTaskShare]
56 sdsStore = memoryShare "mTaskShares" []
58 bcStateStore :: Shared BCState
59 bcStateStore = memoryShare "mTaskBCState" zero
61 mTaskTaskStore :: Shared [String]
62 mTaskTaskStore = memoryShare "mTaskTasks" ["ledder", "ledon", "ledoff"]
64 mTaskMap :: Map String (Main (ByteCode () Stmt))
65 mTaskMap = 'DM'.fromList [("ledder", bc), ("ledon", bc2 LED1), ("ledoff", bc3 LED3)]
67 bc :: Main (ByteCode () Stmt)
68 bc = sds \x=1 In sds \pinnetje=1 In {main =
75 IF (pinnetje ==. lit 1) (
78 IF (pinnetje ==. lit 2) (
85 bc2 :: UserLED -> Main (ByteCode () Stmt)
86 bc2 d = {main = ledOn d}
88 bc3 :: UserLED -> Main (ByteCode () Stmt)
89 bc3 d = {main = ledOff d}
91 :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [(String, Int)]}
92 derive class iTask MTaskDeviceStatus, MTaskDevice, MTaskShare, BCState
94 mTaskManager :: Task ()
95 mTaskManager = anyTask
98 , whileUnchanged deviceStore viewDevices
99 ] <<@ ApplyLayout layout
101 isValue (Value _ _) = True
104 viewmTasks = listmTasks
105 >&^ \sh->whileUnchanged sh $ \mi->case mi of
106 Nothing = viewInformation "No task selected" [] ()
107 Just mTaskTask = get deviceStore
108 >>= \devices->case devices of
109 [] = viewInformation "No devices yet" [] ()
110 ds = sendmTask mTaskTask ds @! ()
112 listmTasks :: Task String
113 listmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
115 sendmTask mTaskId ds =
116 (enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] ds
117 -&&- enterInformation "Timeout, 0 for one-shot" [])
118 >>* [OnAction (Action "Send") (withValue $ Just o sendToDevice mTaskId)]
120 sendToDevice :: String (MTaskDevice, Int) -> Task ()
121 sendToDevice mTask (device, timeout) = get bcStateStore
122 @ toMessages timeout o toRealByteCode (unMain $ fromJust ('DM'.get mTask mTaskMap))
123 >>= \(msgs, st1)->set st1 bcStateStore
125 >>| upd (\(r,s,ss)->(r,s++msgs,ss)) (channels device)
128 f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
129 dd [x,y] = toInt x*265 + toInt y
131 // = (msgs, map f st.sdss)
133 // upd (\(r,s,ss)->(r,s++[],ss)) (channels device) @! ()
134 // # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
135 // = Just $ viewInformation "" [] device
136 // = (msgs, map f st.sdss)
138 // f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
139 // dd [x,y] = toInt x*265 + toInt y
141 // = Just $ viewInformation "" [] device
144 channels :: MTaskDevice -> Shared Channels
145 channels d = memoryShare (fromJust d.deviceConnected) ([], [], False)
147 layout = sequenceLayouts
148 [ arrangeWithSideBar 0 LeftSide 260 True
149 , arrangeSplit Vertical True
152 viewShares :: Task ()
153 viewShares = forever $
154 enterChoiceWithShared "Shares" [ChooseFromList id] sdsStore
155 >>* [OnValue $ withValue $ Just o updateShare]
156 >>* [OnAction (Action "Back") (const $ Just $ treturn ())]
158 sdsvw (k, v) = concat ["SDS ", toString k, ": ", toString v]
159 updateShare s = viewInformation "" [] ()
160 // updateShare (k, v) = (viewInformation "Key" [] k
161 // ||- updateInformation "Value" [] v)
164 viewDevices :: [MTaskDevice] -> Task ()
165 viewDevices ds = anyTask [
166 addDevice deviceStore <<@ Title "Add new device" @! ():
167 [viewDevice d <<@ Title d.deviceName\\d<-ds]]
168 <<@ ArrangeWithTabs @! ()
170 viewDevice :: MTaskDevice -> Task ()
171 viewDevice d = (viewInformation "Device settings" [] d
172 ||- (case d.deviceConnected of
173 Just s = viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
174 Nothing = viewInformation "No channels yet" [] "" @! ()
175 )) <<@ ArrangeHorizontal
177 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
179 addDevice :: (Shared [MTaskDevice]) -> Task ()
180 addDevice devices = enterInformation "Device type and name" []
181 >>= \(name, ty)->get randomInt @ (\randint->{deviceConnected=Just (name +++ toString randint), deviceName=name, deviceTasks=[]})
182 >>= \dev->let ch = channels dev in case ty of
183 TCPDevice = enterInformation "Hostname and port" []
184 >>= \(host, port)->cont dev ||- syncNetworkChannel host port ch
185 SerialDevice = accWorld getDevices
186 >>= \dl->(enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
187 >>= \(device, settings)->cont dev ||- syncSerialChannel device settings ch
189 cont d = (upd (\l->[d:l]) devices >>| addDevice devices)
191 getDevices :: !*World -> *(![String], !*World)
192 getDevices w = case readDirectory "/dev" w of
193 (Error (errcode, errmsg), w) = abort errmsg
194 (Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
196 isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
197 prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
199 // connectDevice :: [MTaskDevice] -> Task ()
200 // connectDevice [] = treturn ()
201 // connectDevice [d:ds] = (case d.deviceConnected of
202 // (Just sh) = viewSharedInformation "Buffers" [] sh @! ()
203 // Nothing = viewInformation ("Connect " +++ d.deviceName) [] "" >>* [
204 // OnAction (Action "connect") (const $ Just $ connect d)]
205 // ) -|| connectDevice ds
207 deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
208 deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
209 connected = if (isNothing d.deviceConnected) False True,
210 tasks = d.deviceTasks}\\d<-ds]
212 // showTabbed :: [MTaskDevice] -> Task ()
213 // showTabbed [] = viewInformation "" [] "No devices yet" @! ()
214 // showTabbed [l:ls] = foldr (\e es->manageDevice e ||- es) (manageDevice l) ls
216 // manageDevice :: MTaskDevice -> Task ()
218 // either viewTCP viewSer md.deviceSettings
220 // (treturn () >>* [OnAction (Action "Connect") (always shutDown)] @! ())
221 // (\b->viewSharedInformation "Buffers" [] b @! ())
222 // md.deviceConnected
223 // <<@ ArrangeVertical
225 mapPar :: (a -> Task a) [a] -> Task ()
226 mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
227 allAtOnce t = foldr1 (||-) t @! ()
228 //allAtOnce = (flip (@!) ()) o foldr1 (||-)
231 //mTaskTask :: Task ()
232 //mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
235 // ||- processMessages ch messageShare sdsShares
236 // ||- forever (enterChoice "Choose led to enable" [] [LED1, LED2, LED3]
237 // >>= \p->sendMsg (fst (makeMsgs 0 (bc2 p))) ch)
238 // ||- forever (enterChoice "Choose led to disable" [] [LED1, LED2, LED3]
239 // >>= \p->sendMsg (fst (makeMsgs 0 (bc3 p))) ch)
240 // ||- viewSharedInformation "channels" [ViewAs lens] ch
241 // ||- viewSharedInformation "messages" [] messageShare
242 // ||- viewSh sdsShares ch
243 // >>* [OnAction ActionFinish (always shutDown)]
245 // messageShare :: Shared [String]
246 // messageShare = sharedStore "mTaskMessagesRecv" []
248 // processMessages ch msgs sdss = forever (watch ch
249 // >>* [OnValue (ifValue (not o isEmpty o fst3) (process ch))])
251 // process :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> Task ()
252 // process ch (r,_,_) = upd (appFst3 (const [])) ch >>| process` r
254 // process` = foldr (\r t->updateSDSs sdss msgs r >>| t) (return ())
256 // makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
257 // makeMsgs timeout bc
258 // # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
259 // = (msgs, map f st.sdss)
261 // f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
262 // dd [x,y] = toInt x*265 + toInt y
264 // updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
265 // updateSDSs [(id, sh):xs] m n=:(MTPub i d)
266 // | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
267 // = updateSDSs xs m n
268 // updateSDSs _ m mtm = case mtm of
269 // MTMessage s = upd (\l->take 5 [s:l]) m @! ()
270 // mta=:(MTTaskAck _) = upd (\l->take 5 [toString mta:l]) m @! ()
271 // //TODO other recv msgs
274 // lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
275 // lens (r,s,_) = (map toString r, map toString s)
277 // viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
278 // viewSh [] ch = return ()
279 // viewSh [(i, sh):xs] ch
280 // # sharename = "SDS-" +++ toString i
282 // viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
284 // enterInformation sharename []
285 // >>* [OnAction ActionOk
286 // (ifValue (\j->j>=1 && j <= 3)
288 // >>= \_->sendMsg (toSDSUpdate i c) ch
293 // ) ||- viewSh xs ch
295 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
296 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
298 syncSerialChannel :: String TTYSettings (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
299 syncSerialChannel dev opts rw = Task eval
301 eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
302 = case TTYopen dev opts world of
304 # (err, world) = TTYerror world
305 = (ExceptionResult (exception err), {iworld & world=world})
307 # iworld = {iworld & world=world, resources=Just (TTYd tty)}
308 = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
309 (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
310 (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoChange (TCBasic taskId ts JSONNull False), iworld)
312 eval _ _ tree=:(TCBasic _ ts _ _) iworld
313 = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
315 eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
316 # (TTYd tty) = fromJust resources
317 # (ok, world) = TTYclose tty world
318 # iworld = {iworld & world=world,resources=Nothing}
319 = case removeBackgroundTask 42 iworld of
320 (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
321 (Ok _, iworld) = (DestroyedResult, iworld)
323 serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld)
324 serialDeviceBackgroundTask rw iworld
325 = case read rw iworld of
326 (Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
327 (Ok (r,s,ss), iworld)
328 # (Just (TTYd tty)) = iworld.resources
329 # tty = writet (map encode s) tty
330 # (ml, tty) = case TTYavailable tty of
331 (False, tty) = ([], tty)
333 # (l, tty) = TTYreadline tty
335 # iworld = {iworld & resources=Just (TTYd tty)}
336 = case write (r++ml,[],False) rw iworld of
337 (Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
338 (Ok _, iworld) = case notify rw iworld of
339 (Error e, iworld) = (Error $ exception "share couldn't be notified", iworld)
340 (Ok _, iworld) = (Ok (), iworld)
342 writet :: [String] -> (*TTY -> *TTY)
344 writet [x:xs] = writet xs o TTYwrite x
347 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
348 syncNetworkChannel server port channel = catchAll
349 (tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ())
350 (\v->traceValue v @! ())
352 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
353 onConnect _ (msgs,send,sendStopped)
354 = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
356 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
357 whileConnected Nothing acc (msgs,send,sendStopped)
358 = (Ok acc, Nothing, [], False)
360 whileConnected (Just newData) acc (msgs,send,sendStopped)
361 = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
362 //| sendStopped = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
363 // = (Ok acc, Just (msgs ++ [decode newData],[],False), [], False)
365 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
366 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)