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
  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                 deviceConnected :: Maybe String,
  37                 deviceName :: String,
  38                 deviceTasks :: [(String, Int)]
  39         }
  40 :: MTaskShare = {
  41                 identifier :: Int,
  42                 realShare :: String
  43         }
  44
  45 Start :: *World -> *World
  46 Start world = startEngine (mTaskManager
  47         >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
  48
  49 memoryShare :: String a -> Shared a | iTask a
  50 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
  51
  52 deviceStore :: Shared [MTaskDevice]
  53 deviceStore = memoryShare "mTaskDevices" []
  54
  55 sdsStore :: Shared [MTaskShare]
  56 sdsStore = memoryShare "mTaskShares" []
  57
  58 bcStateStore :: Shared BCState
  59 bcStateStore = memoryShare "mTaskBCState" zero
  60
  61 mTaskTaskStore :: Shared [String]
  62 mTaskTaskStore = memoryShare "mTaskTasks" ["ledder", "ledon", "ledoff"]
  63
  64 mTaskMap :: Map String (Main (ByteCode () Stmt))
  65 mTaskMap = 'DM'.fromList [("ledder", bc), ("ledon", bc2 LED1), ("ledoff", bc3 LED3)]
  66
  67 bc :: Main (ByteCode () Stmt)
  68 bc = sds \x=1 In sds \pinnetje=1 In {main =
  69                 IF (digitalRead D3) (
  70                         x =. x +. lit 1 :.
  71                         pub x
  72                 ) (
  73                         noOp
  74                 ) :.
  75                 IF (pinnetje ==. lit 1) (
  76                         ledOn LED1
  77                 ) (
  78                         IF (pinnetje ==. lit 2) (
  79                                 ledOn LED2
  80                         ) (
  81                                 ledOn LED3
  82                         )
  83                 )}
  84
  85 bc2 :: UserLED -> Main (ByteCode () Stmt)
  86 bc2 d = {main = ledOn d}
  87
  88 bc3 :: UserLED -> Main (ByteCode () Stmt)
  89 bc3 d = {main = ledOff d}
  90
  91 :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [(String, Int)]}
  92 derive class iTask MTaskDeviceStatus, MTaskDevice, MTaskShare, BCState
  93
  94 mTaskManager :: Task ()
  95 mTaskManager = anyTask
  96                 [ viewmTasks @! ()
  97                 , viewShares
  98                 , whileUnchanged deviceStore viewDevices
  99                 ] <<@ ApplyLayout layout
 100         where
 101                 isValue (Value _ _) = True
 102                 isValue _                       = False
 103
 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 @! ()
 111                         where
 112                                 listmTasks :: Task String
 113                                 listmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
 114
 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)]
 119
 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
 124                                         //@ map f
 125                                         >>| upd (\(r,s,ss)->(r,s++msgs,ss)) (channels device)
 126                                         @! ()
 127                                         where
 128                                                 f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
 129                                                 dd [x,y] = toInt x*265 + toInt y
 130
 131 //              = (msgs, map f st.sdss)
 132 //                      where
 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)
 137 //                                      where
 138 //                                              f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
 139 //                                              dd [x,y] = toInt x*265 + toInt y
 140 //                                      #
 141 //                              = Just $ viewInformation "" [] device
 142
 143
 144                 channels :: MTaskDevice -> Shared Channels
 145                 channels d = memoryShare (fromJust d.deviceConnected) ([], [], False)
 146
 147                 layout = sequenceLayouts
 148                         [ arrangeWithSideBar 0 LeftSide 260 True
 149                         , arrangeSplit Vertical True
 150                         ]
 151
 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 ())]
 157                         where
 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)
 162
 163
 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 @! ()
 169
 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
 176                         where
 177                                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 178
 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
 188                         where
 189                                 cont d = (upd (\l->[d:l]) devices >>| addDevice devices)
 190
 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)
 195
 196                                 isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
 197                                 prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
 198
 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
 206
 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]
 211
 212 //              showTabbed :: [MTaskDevice] -> Task ()
 213 //              showTabbed [] = viewInformation "" [] "No devices yet" @! ()
 214 //              showTabbed [l:ls] = foldr (\e es->manageDevice e ||- es) (manageDevice l) ls
 215 //
 216 //              manageDevice :: MTaskDevice -> Task ()
 217 //              manageDevice md =
 218 //                              either viewTCP viewSer md.deviceSettings
 219 //                      ||- maybe
 220 //                              (treturn () >>* [OnAction (Action "Connect") (always shutDown)] @! ())
 221 //                              (\b->viewSharedInformation "Buffers" [] b @! ())
 222 //                              md.deviceConnected
 223 //                      <<@ ArrangeVertical
 224
 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 (||-)
 229
 230
 231 //mTaskTask :: Task ()
 232 //mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
 233 //      withDevice \ch->
 234 //                      sendMsg msgs ch
 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)]
 244 //      where
 245 //              messageShare :: Shared [String]
 246 //              messageShare = sharedStore "mTaskMessagesRecv" []
 247 //
 248 //              processMessages ch msgs sdss = forever (watch ch
 249 //                      >>* [OnValue (ifValue (not o isEmpty o fst3) (process ch))])
 250 //                      where
 251 //                              process :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> Task ()
 252 //                              process ch (r,_,_) = upd (appFst3 (const [])) ch >>| process` r
 253 //                                      where
 254 //                                              process` = foldr (\r t->updateSDSs sdss msgs r >>| t) (return ())
 255 //
 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)
 260 //                      where
 261 //                              f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
 262 //                              dd [x,y] = toInt x*265 + toInt y
 263 //
 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
 272 //                      _ = return ()
 273 //
 274 //              lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
 275 //              lens (r,s,_) = (map toString r, map toString s)
 276 //
 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
 281 //              = (
 282 //                              viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
 283 //                              forever (
 284 //                                      enterInformation sharename []
 285 //                                      >>* [OnAction ActionOk
 286 //                                                      (ifValue (\j->j>=1 && j <= 3)
 287 //                                                      (\c->set c sh
 288 //                                                              >>= \_->sendMsg (toSDSUpdate i c) ch
 289 //                                                              @! ()
 290 //                                                      )
 291 //                                              )]
 292 //                              )
 293 //                      ) ||- viewSh xs ch
 294
 295 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 296 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 297
 298 syncSerialChannel :: String TTYSettings (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 299 syncSerialChannel dev opts rw = Task eval
 300         where
 301                 eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
 302                 = case TTYopen dev opts world of
 303                         (False, _, world)
 304                         # (err, world) = TTYerror world
 305                         = (ExceptionResult (exception err), {iworld & world=world})
 306                         (True, tty, 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)
 311
 312                 eval _ _ tree=:(TCBasic _ ts _ _) iworld
 313                 = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
 314
 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)
 322
 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)
 332                         (_, tty)
 333                         # (l, tty) = TTYreadline tty
 334                         = ([decode l], 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)
 341         where
 342                 writet :: [String] -> (*TTY -> *TTY)
 343                 writet [] = id
 344                 writet [x:xs] = writet xs o TTYwrite x
 345
 346
 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 @! ())
 351         where
 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)
 355
 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)
 359
 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)
 364
 365                 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
 366                 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)