miTask.icl

   1 module miTask
   2
   3 import StdDebug, StdMisc
   4 from StdFunc import flip
   5
   6 import iTasks
   7 import mTask
   8
   9 from Text import class Text(startsWith,concat,split,join), instance Text String
  10
  11 import qualified Data.Map as DM
  12
  13 from Data.Func import $
  14 import Data.Tuple
  15 import Data.List
  16 import System.Directory
  17
  18 import iTasks.UI.Definition
  19
  20 import iTasks._Framework.TaskState
  21 import iTasks._Framework.TaskServer
  22 import iTasks._Framework.IWorld
  23 import iTasks._Framework.Store
  24
  25
  26 import TTY, iTasksTTY
  27
  28 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
  29 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
  30
  31 :: *Resource | TTYd !*TTY
  32 :: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool)
  33
  34 :: SerTCP = SerialDevice | TCPDevice
  35 :: MTaskDevice = {
  36                 deviceTask :: Maybe TaskId,
  37                 deviceConnected :: Maybe String,
  38                 deviceName :: String,
  39                 deviceTasks :: [(String, Int)]
  40         }
  41 :: MTaskShare = {
  42                 initValue :: Int,
  43                 withTask :: String,
  44                 identifier :: Int,
  45                 realShare :: String
  46         }
  47
  48 Start :: *World -> *World
  49 Start world = startEngine (mTaskManager
  50         >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
  51
  52 memoryShare :: String a -> Shared a | iTask a
  53 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
  54
  55 deviceStore :: Shared [MTaskDevice]
  56 deviceStore = memoryShare "mTaskDevices" []
  57
  58 sdsStore :: Shared [MTaskShare]
  59 sdsStore = memoryShare "mTaskShares" []
  60
  61 bcStateStore :: Shared BCState
  62 bcStateStore = memoryShare "mTaskBCState" zero
  63
  64 mTaskTaskStore :: Shared [String]
  65 mTaskTaskStore = memoryShare "mTaskTasks" ["ledder", "ledon", "ledoff"]
  66
  67 mTaskMap :: Map String (Main (ByteCode () Stmt))
  68 mTaskMap = 'DM'.fromList [("ledder", bc), ("ledon", bc2 LED1), ("ledoff", bc3 LED3)]
  69
  70 bc :: Main (ByteCode () Stmt)
  71 bc = sds \x=1 In sds \pinnetje=1 In {main =
  72                 IF (digitalRead D3) (
  73                         x =. x +. lit 1 :.
  74                         pub x
  75                 ) (
  76                         noOp
  77                 ) :.
  78                 IF (pinnetje ==. lit 1) (
  79                         ledOn LED1
  80                 ) (
  81                         IF (pinnetje ==. lit 2) (
  82                                 ledOn LED2
  83                         ) (
  84                                 ledOn LED3
  85                         )
  86                 )}
  87
  88 bc2 :: UserLED -> Main (ByteCode () Stmt)
  89 bc2 d = {main = ledOn d}
  90
  91 bc3 :: UserLED -> Main (ByteCode () Stmt)
  92 bc3 d = {main = ledOff d}
  93
  94 :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [(String, Int)]}
  95 derive class iTask MTaskDeviceStatus, MTaskDevice, MTaskShare, BCState
  96
  97 mTaskManager :: Task ()
  98 mTaskManager = anyTask
  99                 [ viewmTasks @! ()
 100                 , viewShares
 101                 , whileUnchanged deviceStore viewDevices
 102                 ] <<@ ApplyLayout layout
 103         where
 104                 layout = sequenceLayouts
 105                         [ arrangeWithSideBar 0 LeftSide 260 True
 106                         , arrangeSplit Vertical True
 107                         ]
 108
 109                 viewmTasks = listmTasks
 110                         >&^ \sh->whileUnchanged sh $ \mi->case mi of
 111                                 Nothing = viewInformation "No task selected" [] ()
 112                                 Just mTaskTask = get deviceStore
 113                                         >>= \devices->case devices of
 114                                                 [] = viewInformation "No devices yet" [] ()
 115                                                 ds = sendmTask mTaskTask ds @! ()
 116                         where
 117                                 listmTasks :: Task String
 118                                 listmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
 119
 120                                 sendmTask mTaskId ds =
 121                                                 (enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] ds
 122                                                 -&&- enterInformation "Timeout, 0 for one-shot" [])
 123                                         >>* [OnAction (Action "Send") (withValue $ Just o sendToDevice mTaskId)]
 124
 125                                 sendToDevice :: String (MTaskDevice, Int) -> Task ()
 126                                 sendToDevice mTask (device, timeout) =
 127                                                 get bcStateStore @ createBytecode
 128                                         >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
 129                                         >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
 130                                         >>| makeShares sdss
 131                                         >>| upd (\(r,s,ss)->(r,s++msgs,ss)) (channels device)
 132                                         @! ()
 133                                         where
 134                                                 createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask mTaskMap)) st
 135                                                 sharename i = fromJust (device.deviceConnected) +++ "-" +++ toString i
 136                                                 toSDSRecords st = [{MTaskShare |
 137                                                         initValue=toInt d1*265 + toInt d2,
 138                                                         withTask=mTask,
 139                                                         identifier=i,
 140                                                         realShare="mTaskSDS-" +++ toString i}
 141                                                                 \\(i,[d1,d2])<-st.sdss]
 142                                                 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
 143
 144                 getSDSStore :: MTaskShare -> Shared Int
 145                 getSDSStore sh = memoryShare sh.realShare 0
 146
 147                 channels :: MTaskDevice -> Shared Channels
 148                 channels d = memoryShare (fromJust d.deviceConnected) ([], [], False)
 149
 150                 viewShares :: Task ()
 151                 viewShares = forever $ viewSharedInformation "Shares" [] sdsStore @! ()
 152 //                              enterChoiceWithShared "Shares" [ChooseFromList id] sdsStore
 153 //                      >>* [OnValue $ withValue $ Just o updateShare]
 154 //                      >>* [OnAction (Action "Back") (const $ Just $ treturn ())]
 155 //                      where
 156 //                              sdsvw (k, v) = concat ["SDS ", toString k, ": ", toString v]
 157 //                              updateShare s = viewInformation "" [] ()
 158 //                              updateShare (k, v) = (viewInformation "Key" [] k
 159 //                                      ||- updateInformation "Value" [] v)
 160
 161
 162                 viewDevices :: [MTaskDevice] -> Task ()
 163                 viewDevices ds = anyTask [
 164                                 addDevice deviceStore <<@ Title "Add new device" @! ():
 165                                         [viewDevice d <<@ Title d.deviceName\\d<-ds]]
 166                         <<@ ArrangeWithTabs @! ()
 167
 168                 viewDevice :: MTaskDevice -> Task ()
 169                 viewDevice d = (viewInformation "Device settings" [] d
 170                                 ||- (case d.deviceConnected of
 171                                         Just s = viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
 172                                         Nothing = viewInformation "No channels yet" [] "" @! ()
 173                                 )) <<@ ArrangeHorizontal
 174                         where
 175                                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 176
 177                 addDevice :: (Shared [MTaskDevice]) -> Task SerTCP
 178                 addDevice devices = enterInformation "Device type" []
 179                         >&^ \sh->whileUnchanged sh $ \mty->case mty of
 180                                 Nothing = viewInformation "No type selected yet" [] "" @! ()
 181                                 Just ty = case ty of
 182                                         TCPDevice = (enterInformation "Name" [] -&&- enterInformation "Hostname" [] -&&- enterInformation "Port" [])
 183                                                 >>= \(name, (host, port))->cont name (syncNetworkChannel host port)
 184                                         SerialDevice = accWorld getTTYDevices
 185                                                 >>= \dl->(enterInformation "Name" [] -&&- enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
 186                                                 >>= \(name, (dev, set))->cont name (syncSerialChannel dev set)
 187                         where
 188                                 cont :: String ((Shared Channels) -> Task ()) -> Task ()
 189                                 cont name synfun = get randomInt
 190                                         @ (\randint->{deviceConnected=Just (name +++ toString randint), deviceName=name, deviceTasks=[], deviceTask=Nothing})
 191                                         >>= \dev->appendTopLevelTask 'DM'.newMap True (synfun $ channels dev)
 192                                         >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
 193                                         @! ()
 194
 195 //                              >= \ty->get randomInt @ (\randint->{deviceConnected=Just (name +++ toString randint), deviceName=name, deviceTasks=[]})
 196 //                      >>= \dev->let ch = channels dev in case ty of
 197 //                              TCPDevice = enterInformation "Hostname and port" []
 198 //                                      >>= \(host, port)->cont dev ||- syncNetworkChannel host port ch
 199 //                              SerialDevice = accWorld getDevices
 200 //                                      >>= \dl->(enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
 201 //                                      >>= \(device, settings)->cont dev ||- syncSerialChannel device settings ch
 202 //                      where
 203 //                              cont d = (upd (\l->[d:l]) devices >>| addDevice devices)
 204
 205 //              connectDevice :: [MTaskDevice] -> Task ()
 206 //              connectDevice [] = treturn ()
 207 //              connectDevice [d:ds] = (case d.deviceConnected of
 208 //                      (Just sh) = viewSharedInformation "Buffers" [] sh @! ()
 209 //                      Nothing = viewInformation ("Connect " +++ d.deviceName) [] "" >>* [
 210 //                              OnAction (Action "connect") (const $ Just $ connect d)]
 211 //                      ) -|| connectDevice ds
 212
 213                 deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
 214                 deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
 215                         connected = if (isNothing d.deviceConnected) False True,
 216                         tasks = d.deviceTasks}\\d<-ds]
 217
 218 //              showTabbed :: [MTaskDevice] -> Task ()
 219 //              showTabbed [] = viewInformation "" [] "No devices yet" @! ()
 220 //              showTabbed [l:ls] = foldr (\e es->manageDevice e ||- es) (manageDevice l) ls
 221 //
 222 //              manageDevice :: MTaskDevice -> Task ()
 223 //              manageDevice md =
 224 //                              either viewTCP viewSer md.deviceSettings
 225 //                      ||- maybe
 226 //                              (treturn () >>* [OnAction (Action "Connect") (always shutDown)] @! ())
 227 //                              (\b->viewSharedInformation "Buffers" [] b @! ())
 228 //                              md.deviceConnected
 229 //                      <<@ ArrangeVertical
 230
 231                 mapPar :: (a -> Task a) [a] -> Task ()
 232                 mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
 233                 allAtOnce t = foldr1 (||-) t @! ()
 234                 //allAtOnce = (flip (@!) ()) o foldr1 (||-)
 235
 236
 237 //mTaskTask :: Task ()
 238 //mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
 239 //      withDevice \ch->
 240 //                      sendMsg msgs ch
 241 //              ||- processMessages ch messageShare sdsShares
 242 //              ||- forever (enterChoice "Choose led to enable" [] [LED1, LED2, LED3]
 243 //                              >>= \p->sendMsg (fst (makeMsgs 0 (bc2 p))) ch)
 244 //              ||- forever (enterChoice "Choose led to disable" [] [LED1, LED2, LED3]
 245 //                              >>= \p->sendMsg (fst (makeMsgs 0 (bc3 p))) ch)
 246 //              ||- viewSharedInformation "channels" [ViewAs lens] ch
 247 //              ||- viewSharedInformation "messages" [] messageShare
 248 //              ||- viewSh sdsShares ch
 249 //              >>* [OnAction ActionFinish (always shutDown)]
 250 //      where
 251 //              messageShare :: Shared [String]
 252 //              messageShare = sharedStore "mTaskMessagesRecv" []
 253 //
 254 //              makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
 255 //              makeMsgs timeout bc
 256 //              # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
 257 //              = (msgs, map f st.sdss)
 258 //                      where
 259 //                              f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
 260 //                              dd [x,y] = toInt x*265 + toInt y
 261 //
 262 //              updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
 263 //              updateSDSs [(id, sh):xs] m n=:(MTPub i d)
 264 //              | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
 265 //              = updateSDSs xs m n
 266 //              updateSDSs _ m mtm = case mtm of
 267 //                      MTMessage s = upd (\l->take 5 [s:l]) m @! ()
 268 //                      mta=:(MTTaskAck _) = upd (\l->take 5 [toString mta:l]) m @! ()
 269 //                      //TODO other recv msgs
 270 //                      _ = return ()
 271 //
 272 //              lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
 273 //              lens (r,s,_) = (map toString r, map toString s)
 274 //
 275 //              viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 276 //              viewSh [] ch = return ()
 277 //              viewSh [(i, sh):xs] ch
 278 //              # sharename = "SDS-" +++ toString i
 279 //              = (
 280 //                              viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
 281 //                              forever (
 282 //                                      enterInformation sharename []
 283 //                                      >>* [OnAction ActionOk
 284 //                                                      (ifValue (\j->j>=1 && j <= 3)
 285 //                                                      (\c->set c sh
 286 //                                                              >>= \_->sendMsg (toSDSUpdate i c) ch
 287 //                                                              @! ()
 288 //                                                      )
 289 //                                              )]
 290 //                              )
 291 //                      ) ||- viewSh xs ch
 292
 293 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 294 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 295
 296 syncSerialChannel :: String TTYSettings (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 297 syncSerialChannel dev opts rw = Task eval
 298         where
 299                 eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
 300                 = case TTYopen dev opts world of
 301                         (False, _, world)
 302                         # (err, world) = TTYerror world
 303                         = (ExceptionResult (exception err), {iworld & world=world})
 304                         (True, tty, world)
 305                         # iworld = {iworld & world=world, resources=Just (TTYd tty)}
 306                         = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
 307                                 (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 308                                 (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoChange (TCBasic taskId ts JSONNull False), iworld)
 309
 310                 eval _ _ tree=:(TCBasic _ ts _ _) iworld
 311                 = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
 312
 313                 eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
 314                 # (TTYd tty) = fromJust resources
 315                 # (ok, world) = TTYclose tty world
 316                 # iworld = {iworld & world=world,resources=Nothing}
 317                 = case removeBackgroundTask 42 iworld of
 318                         (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 319                         (Ok _, iworld) = (DestroyedResult, iworld)
 320
 321 serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld)
 322 serialDeviceBackgroundTask rw iworld
 323         = case read rw iworld of
 324                 (Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
 325                 (Ok (r,s,ss), iworld)
 326                 # (Just (TTYd tty)) = iworld.resources
 327                 # tty = writet (map encode s) tty
 328                 # (ml, tty) = case TTYavailable tty of
 329                         (False, tty) = ([], tty)
 330                         (_, tty)
 331                         # (l, tty) = TTYreadline tty
 332                         = ([decode l], tty)
 333                 # iworld = {iworld & resources=Just (TTYd tty)}
 334                 = case write (r++ml,[],False) rw iworld of
 335                         (Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
 336                         (Ok _, iworld) = case notify rw iworld of
 337                                 (Error e, iworld) = (Error $ exception "share couldn't be notified", iworld)
 338                                 (Ok _, iworld) = (Ok (), iworld)
 339         where
 340                 writet :: [String] -> (*TTY -> *TTY)
 341                 writet [] = id
 342                 writet [x:xs] = writet xs o TTYwrite x
 343
 344
 345 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
 346 syncNetworkChannel server port channel = catchAll
 347                 (tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ())
 348                 (\v->traceValue v @! ())
 349         where
 350                 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 351                 onConnect _ (msgs,send,sendStopped)
 352                         = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
 353
 354                 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 355                 whileConnected Nothing acc (msgs,send,sendStopped)
 356                 = (Ok acc, Nothing, [], False)
 357
 358                 whileConnected (Just newData) acc (msgs,send,sendStopped)
 359                 = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
 360                 //| sendStopped = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
 361 //              = (Ok acc, Just (msgs ++ [decode newData],[],False), [], False)
 362
 363                 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
 364                 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)