add some task control
[mTask.git] / miTask.icl
index 2757450..d84121a 100644 (file)
@@ -8,7 +8,9 @@ import mTask
 
 from Text import class Text(startsWith,concat,split,join), instance Text String
 
 
 from Text import class Text(startsWith,concat,split,join), instance Text String
 
+from Data.Func import $
 import Data.Tuple
 import Data.Tuple
+import Data.List
 import System.Directory
 
 import iTasks.UI.Definition
 import System.Directory
 
 import iTasks.UI.Definition
@@ -23,11 +25,19 @@ import TTY
 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
 
 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
 
+derive class iTask MTaskDevice
+
 :: SerTCP = Serial | TCP
 :: *Resource | TTYd !*TTY
 :: SerTCP = Serial | TCP
 :: *Resource | TTYd !*TTY
+:: MTaskDevice = {
+               deviceConnected :: Maybe (Shared ([String], [String], Bool)),
+               deviceName :: String,
+               deviceSettings :: Either (String, Int) (String, TTYSettings)
+       }
 
 Start :: *World -> *World
 
 Start :: *World -> *World
-Start world = startEngine mTaskTask world
+Start world = startEngine (mTaskManager
+       >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
 //Start world = startEngine mTaskTask world
 
 bc :: Main (ByteCode () Stmt)
 //Start world = startEngine mTaskTask world
 
 bc :: Main (ByteCode () Stmt)
@@ -54,16 +64,69 @@ bc2 d = {main = ledOn d}
 bc3 :: UserLED -> Main (ByteCode () Stmt)
 bc3 d = {main = ledOff d}
 
 bc3 :: UserLED -> Main (ByteCode () Stmt)
 bc3 d = {main = ledOff d}
 
+:: MTaskDeviceStatus = {connected :: Bool, name :: String}
+derive class iTask MTaskDeviceStatus
+
+mTaskManager :: Task ()
+mTaskManager = forever (addDevice >>= \d->upd (\l->[d:l]) deviceStore)
+       ||- viewSharedInformation "Devices" [ViewAs deviceviewer] deviceStore
+       ||- whileUnchanged deviceStore (\m->if (isEmpty m)
+                       (viewInformation "No devices yet" [] "" @! ()) (connectDevice m)) @! ()
+//             )
+       where
+               connectDevice :: [MTaskDevice] -> Task ()
+               connectDevice [] = treturn ()
+               connectDevice [d:ds] = (case d.deviceConnected of
+                       (Just sh) = viewSharedInformation "Buffers" [] sh @! ()
+                       Nothing = viewInformation ("Connect " +++ d.deviceName) [] "" >>* [
+                               OnAction (Action "connect") (const $ Just $ connect d)]
+                       ) -|| connectDevice ds
+
+               connect :: MTaskDevice -> Task ()
+               connect d=:{deviceSettings} = withShared ([], [], False) $ \ch->
+                       case deviceSettings of
+                               Left (host, port) = syncNetworkChannel host port ch
+                               Right (dev, sett) = syncSerialChannel dev sett ch
+                       ||- viewSharedInformation "Buffers" [] ch @! ()
+
+               deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
+               deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
+                       connected = if (isNothing d.deviceConnected) False True}\\d<-ds]
+       
+               deviceStore :: Shared [MTaskDevice]
+               deviceStore = sdsFocus "mTaskDevices" $ memoryStore "" (Just [])
 
 
-withDevice :: ((Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task a) -> Task a | iTask a
-withDevice t = withShared ([], [], False) \ch->
-               enterInformation "Type" []
-       >>= \ty->case ty of
+//             showTabbed :: [MTaskDevice] -> Task ()
+//             showTabbed [] = viewInformation "" [] "No devices yet" @! ()
+//             showTabbed [l:ls] = foldr (\e es->manageDevice e ||- es) (manageDevice l) ls
+//
+//             manageDevice :: MTaskDevice -> Task ()
+//             manageDevice md = 
+//                             either viewTCP viewSer md.deviceSettings
+//                     ||- maybe
+//                             (treturn () >>* [OnAction (Action "Connect") (always shutDown)] @! ())
+//                             (\b->viewSharedInformation "Buffers" [] b @! ())
+//                             md.deviceConnected
+//                     <<@ ArrangeVertical
+
+               mapPar :: (a -> Task a) [a] -> Task ()
+               mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
+               allAtOnce t = foldr1 (||-) t @! ()
+               //allAtOnce = (flip (@!) ()) o foldr1 (||-)
+
+addDevice :: Task MTaskDevice
+addDevice = enterInformation "Device name" []
+       -&&- enterInformation "Device type" []
+       >>= \(name, ty)->(case ty of
                TCP = (enterInformation "Host" [] -&&- enterInformation "Port" [])
                TCP = (enterInformation "Host" [] -&&- enterInformation "Port" [])
-                       >>= \(port,host)->t ch -|| syncNetworkChannel host port ch
+                       >>= treturn o Left
                Serial = accWorld getDevices
                        >>= \dl->(enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
                Serial = accWorld getDevices
                        >>= \dl->(enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
-                       >>= \(dev,set)->t ch -|| syncSerialChannel dev set ch
+                       >>= treturn o Right
+       ) >>= \set->treturn {MTaskDevice |
+               deviceConnected=Nothing,
+               deviceName=name,
+               deviceSettings=set}
        where
                getDevices :: !*World -> *(![String], !*World)
                getDevices w = case readDirectory "/dev" w of
        where
                getDevices :: !*World -> *(![String], !*World)
                getDevices w = case readDirectory "/dev" w of
@@ -73,68 +136,69 @@ withDevice t = withShared ([], [], False) \ch->
                                isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
                                prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
 
                                isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
                                prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
 
-mTaskTask :: Task ()
-mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
-       withDevice \ch->
-                       sendMsg msgs ch
-               ||- processMessages ch messageShare sdsShares
-               ||- forever (enterChoice "Choose led to enable" [] [LED1, LED2, LED3]
-                               >>= \p->sendMsg (fst (makeMsgs 0 (bc2 p))) ch)
-               ||- forever (enterChoice "Choose led to disable" [] [LED1, LED2, LED3]
-                               >>= \p->sendMsg (fst (makeMsgs 0 (bc3 p))) ch)
-               ||- viewSharedInformation "channels" [ViewWith lens] ch
-               ||- viewSharedInformation "messages" [] messageShare
-               ||- viewSh sdsShares ch
-               >>* [OnAction ActionFinish (always shutDown)]
-       where
-               messageShare :: Shared [String]
-               messageShare = sharedStore "mTaskMessagesRecv" []
-
-               processMessages ch msgs sdss = forever (watch ch
-                       >>* [OnValue (ifValue (not o isEmpty o fst3) (process ch))])
-                       where
-                               process :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> Task ()
-                               process ch (r,_,_) = upd (appFst3 (const [])) ch >>| process` r
-                                       where
-                                               process` = foldr (\r t->updateSDSs sdss msgs r >>| t) (return ())
-
-               makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
-               makeMsgs timeout bc
-               # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
-               = (msgs, map f st.sdss)
-                       where 
-                               f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
-                               dd [x,y] = toInt x*265 + toInt y
-
-               updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
-               updateSDSs [(id, sh):xs] m n=:(MTPub i d)
-               | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
-               = updateSDSs xs m n
-               updateSDSs _ m mtm = case mtm of
-                       MTMessage s = upd (\l->take 5 [s:l]) m @! ()
-                       mta=:(MTTaskAdded _) = upd (\l->take 5 [toString mta:l]) m @! ()
-                       _ = return ()
-
-               lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
-               lens (r,s,_) = (map toString r, map toString s)
-
-               viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
-               viewSh [] ch = return ()
-               viewSh [(i, sh):xs] ch
-               # sharename = "SDS-" +++ toString i
-               = (
-                               viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
-                               forever (
-                                       enterInformation sharename []
-                                       >>* [OnAction ActionOk 
-                                                       (ifValue (\j->j>=1 && j <= 3) 
-                                                       (\c->set c sh
-                                                               >>= \_->sendMsg (toSDSUpdate i c) ch
-                                                               @! ()
-                                                       )
-                                               )]
-                               )
-                       ) ||- viewSh xs ch
+//mTaskTask :: Task ()
+//mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
+//     withDevice \ch->
+//                     sendMsg msgs ch
+//             ||- processMessages ch messageShare sdsShares
+//             ||- forever (enterChoice "Choose led to enable" [] [LED1, LED2, LED3]
+//                             >>= \p->sendMsg (fst (makeMsgs 0 (bc2 p))) ch)
+//             ||- forever (enterChoice "Choose led to disable" [] [LED1, LED2, LED3]
+//                             >>= \p->sendMsg (fst (makeMsgs 0 (bc3 p))) ch)
+//             ||- viewSharedInformation "channels" [ViewAs lens] ch
+//             ||- viewSharedInformation "messages" [] messageShare
+//             ||- viewSh sdsShares ch
+//             >>* [OnAction ActionFinish (always shutDown)]
+//     where
+//             messageShare :: Shared [String]
+//             messageShare = sharedStore "mTaskMessagesRecv" []
+//
+//             processMessages ch msgs sdss = forever (watch ch
+//                     >>* [OnValue (ifValue (not o isEmpty o fst3) (process ch))])
+//                     where
+//                             process :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> Task ()
+//                             process ch (r,_,_) = upd (appFst3 (const [])) ch >>| process` r
+//                                     where
+//                                             process` = foldr (\r t->updateSDSs sdss msgs r >>| t) (return ())
+//
+//             makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
+//             makeMsgs timeout bc
+//             # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
+//             = (msgs, map f st.sdss)
+//                     where 
+//                             f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
+//                             dd [x,y] = toInt x*265 + toInt y
+//
+//             updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
+//             updateSDSs [(id, sh):xs] m n=:(MTPub i d)
+//             | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
+//             = updateSDSs xs m n
+//             updateSDSs _ m mtm = case mtm of
+//                     MTMessage s = upd (\l->take 5 [s:l]) m @! ()
+//                     mta=:(MTTaskAck _) = upd (\l->take 5 [toString mta:l]) m @! ()
+//                     //TODO other recv msgs
+//                     _ = return ()
+//
+//             lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
+//             lens (r,s,_) = (map toString r, map toString s)
+//
+//             viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
+//             viewSh [] ch = return ()
+//             viewSh [(i, sh):xs] ch
+//             # sharename = "SDS-" +++ toString i
+//             = (
+//                             viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
+//                             forever (
+//                                     enterInformation sharename []
+//                                     >>* [OnAction ActionOk 
+//                                                     (ifValue (\j->j>=1 && j <= 3) 
+//                                                     (\c->set c sh
+//                                                             >>= \_->sendMsg (toSDSUpdate i c) ch
+//                                                             @! ()
+//                                                     )
+//                                             )]
+//                             )
+//                     ) ||- viewSh xs ch
 
 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 
 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
@@ -151,10 +215,10 @@ syncSerialChannel dev opts rw = Task eval
                        # iworld = {iworld & world=world, resources=Just (TTYd tty)}
                        = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
                                (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
                        # iworld = {iworld & world=world, resources=Just (TTYd tty)}
                        = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
                                (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
-                               (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoRep (TCBasic taskId ts JSONNull False), iworld)
+                               (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoChange (TCBasic taskId ts JSONNull False), iworld)
 
                eval _ _ tree=:(TCBasic _ ts _ _) iworld
 
                eval _ _ tree=:(TCBasic _ ts _ _) iworld
-               = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoRep tree, iworld)
+               = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
 
                eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
                # (TTYd tty) = fromJust resources
 
                eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
                # (TTYd tty) = fromJust resources
@@ -164,10 +228,10 @@ syncSerialChannel dev opts rw = Task eval
                        (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
                        (Ok _, iworld) = (DestroyedResult, iworld)
 
                        (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
                        (Ok _, iworld) = (DestroyedResult, iworld)
 
-serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> *IWorld
+serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld)
 serialDeviceBackgroundTask rw iworld
        = case read rw iworld of
 serialDeviceBackgroundTask rw iworld
        = case read rw iworld of
-               (Error e, iworld) = abort "share couldn't be read"
+               (Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
                (Ok (r,s,ss), iworld)
                # (Just (TTYd tty)) = iworld.resources
                # tty = writet (map encode s) tty
                (Ok (r,s,ss), iworld)
                # (Just (TTYd tty)) = iworld.resources
                # tty = writet (map encode s) tty
@@ -178,10 +242,10 @@ serialDeviceBackgroundTask rw iworld
                        = ([decode l], tty)
                # iworld = {iworld & resources=Just (TTYd tty)}
                = case write (r++ml,[],False) rw iworld of
                        = ([decode l], tty)
                # iworld = {iworld & resources=Just (TTYd tty)}
                = case write (r++ml,[],False) rw iworld of
-                       (Error e, iworld) = abort "share couldn't be written"
+                       (Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
                        (Ok _, iworld) = case notify rw iworld of
                        (Ok _, iworld) = case notify rw iworld of
-                               (Error e, iworld) = abort "share couldn't be notified"
-                               (Ok _, iworld) = iworld
+                               (Error e, iworld) = (Error $ exception "share couldn't be notified", iworld)
+                               (Ok _, iworld) = (Ok (), iworld)
        where
                writet :: [String] -> (*TTY -> *TTY)
                writet [] = id
        where
                writet :: [String] -> (*TTY -> *TTY)
                writet [] = id