miTask.icl

   1 module miTask
   2
   3 import StdDebug, StdMisc
   4 from StdFunc import flip
   5
   6 import iTasks
   7 import mTask
   8 import Devices.mTaskDevice
   9
  10 from Text import class Text(startsWith,concat,split,join), instance Text String
  11
  12 import qualified Data.Map as DM
  13
  14 from Data.Func import $
  15 import Data.Tuple
  16 import Data.List
  17 import System.Directory
  18
  19 import iTasks._Framework.Store
  20
  21 import TTY, iTasksTTY
  22
  23 derive class iTask UserLED
  24
  25 :: MTaskShare = {
  26                 initValue :: Int,
  27                 withTask :: String,
  28                 identifier :: Int,
  29                 realShare :: String
  30         }
  31
  32 Start :: *World -> *World
  33 Start world = startEngine (mTaskManager
  34         >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
  35
  36 memoryShare :: String a -> Shared a | iTask a
  37 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
  38
  39 deviceStore :: Shared [MTaskDevice]
  40 deviceStore = sharedStore "mTaskDevices" []
  41
  42 sdsStore :: Shared [MTaskShare]
  43 sdsStore = memoryShare "mTaskShares" []
  44
  45 bcStateStore :: Shared BCState
  46 bcStateStore = memoryShare "mTaskBCState" zero
  47
  48 mTaskTaskStore :: Shared [String]
  49 mTaskTaskStore = memoryShare "mTaskTasks" ["count", "ledon", "ledoff"]
  50
  51 mTaskMap :: Map String (Main (ByteCode () Stmt))
  52 mTaskMap = 'DM'.fromList [("count", bc), ("ledon", bc2 LED1), ("ledoff", bc3 LED3)]
  53
  54 bc :: Main (ByteCode () Stmt)
  55 bc = sds \x=1 In sds \pinnetje=1 In {main =
  56                 IF (digitalRead D3) (
  57                         x =. x +. lit 1 :.
  58                         pub x
  59                 ) (
  60                         noOp
  61                 ) :.
  62                 IF (pinnetje ==. lit 1) (
  63                         ledOn LED1
  64                 ) (
  65                         IF (pinnetje ==. lit 2) (
  66                                 ledOn LED2
  67                         ) (
  68                                 ledOn LED3
  69                         )
  70                 )}
  71
  72 bc2 :: UserLED -> Main (ByteCode () Stmt)
  73 bc2 d = {main = ledOn d}
  74
  75 bc3 :: UserLED -> Main (ByteCode () Stmt)
  76 bc3 d = {main = ledOff d}
  77
  78 :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [String]}
  79 derive class iTask MTaskDeviceStatus, MTaskShare, BCState
  80
  81 mTaskManager :: Task ()
  82 mTaskManager = anyTask
  83                 [ viewmTasks @! ()
  84                 , whileUnchanged sdsStore viewShares
  85                 , whileUnchanged deviceStore viewDevices
  86                 ] <<@ ApplyLayout layout
  87         where
  88                 layout = sequenceLayouts
  89                         [ arrangeWithSideBar 0 LeftSide 260 True
  90                         , arrangeSplit Vertical True
  91                         ]
  92
  93                 viewmTasks = listmTasks
  94                         >&^ \sh->whileUnchanged sh $ \mi->forever (case mi of
  95                                 Nothing = viewInformation "No task selected" [] ()
  96                                 Just mTaskTask = get deviceStore
  97                                         >>= \devices->case devices of
  98                                                 [] = viewInformation "No devices yet" [] ()
  99                                                 ds = sendmTask mTaskTask ds @! ())
 100                         where
 101                                 listmTasks :: Task String
 102                                 listmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
 103
 104                                 sendmTask mTaskId ds =
 105                                                 (enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] ds
 106                                                 -&&- enterInformation "Timeout, 0 for one-shot" [])
 107                                         >>* [OnAction (Action "Send") (withValue $ Just o sendToDevice mTaskId)]
 108
 109                                 sendToDevice :: String (MTaskDevice, Int) -> Task ()
 110                                 sendToDevice mTask (device, timeout) =
 111                                                 get bcStateStore @ createBytecode
 112                                         >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
 113                                         >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
 114                                         >>| makeShares sdss
 115                                         >>| upd (\(r,s,ss)->(r,s++msgs,ss)) (channels device)
 116                                         @! ()
 117                                         where
 118                                                 createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask mTaskMap)) st
 119                                                 sharename i = device.deviceChannels +++ "-" +++ toString i
 120                                                 toSDSRecords st = [{MTaskShare |
 121                                                         initValue=toInt d1*265 + toInt d2,
 122                                                         withTask=mTask,
 123                                                         identifier=i,
 124                                                         realShare="mTaskSDS-" +++ toString i}
 125                                                                 \\(i,[d1,d2])<-st.sdss]
 126                                                 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
 127
 128                 getSDSStore :: MTaskShare -> Shared Int
 129                 getSDSStore sh = memoryShare sh.realShare 0
 130
 131                 getSDSRecord :: Int -> Task MTaskShare
 132                 getSDSRecord i = get sdsStore @ \l->hd [s\\s<-l | s.identifier == i]
 133
 134                 viewShares :: [MTaskShare] -> Task ()
 135                 viewShares st = anyTask $ map viewer st
 136                         where
 137                                 viewer :: MTaskShare -> Task ()
 138                                 viewer m = viewSharedInformation "" [] (getSDSStore m)
 139                                         <<@ Title ("SDS: " +++ toString m.identifier) @! ()
 140 //                              enterChoiceWithShared "Shares" [ChooseFromList id] sdsStore
 141 //                      >>* [OnValue $ withValue $ Just o updateShare]
 142 //                      >>* [OnAction (Action "Back") (const $ Just $ treturn ())]
 143 //                      where
 144 //                              sdsvw (k, v) = concat ["SDS ", toString k, ": ", toString v]
 145 //                              updateShare s = viewInformation "" [] ()
 146 //                              updateShare (k, v) = (viewInformation "Key" [] k
 147 //                                      ||- updateInformation "Value" [] v)
 148
 149
 150                 viewDevices :: [MTaskDevice] -> Task ()
 151                 viewDevices ds = anyTask [
 152                                 addDevice deviceStore <<@ Title "Add new device" @! ():
 153                                         [viewDevice d <<@ Title d.deviceName\\d<-ds]]
 154                         <<@ ArrangeWithTabs @! ()
 155
 156                 viewDevice :: MTaskDevice -> Task ()
 157                 viewDevice d = (viewInformation "Device settings" [] d
 158                                 ||- viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
 159                                 ) <<@ ArrangeHorizontal
 160                         where
 161                                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 162
 163
 164 //              addDevice :: (Shared [MTaskDevice]) -> Task SerTCP
 165 //              addDevice devices = enterInformation "Device type" []
 166 //                      >&^ \sh->whileUnchanged sh $ \mty->case mty of
 167 //                              Nothing = viewInformation "No type selected yet" [] "" @! ()
 168 //                              Just ty = case ty of
 169 //                                      TCPDevice = (enterInformation "Name" [] -&&- enterInformation "Hostname" [] -&&- enterInformation "Port" [])
 170 //                                              >>= \(name, (host, port))->cont name (syncNetworkChannel host port)
 171 //                                      SerialDevice = (enterInformation "Name" [] -&&- enterTTYSettings)
 172 //                                              >>= \(name, set)->cont name (syncSerialChannel set encode decode)
 173 //                      where
 174 //                              cont :: String ((Shared Channels) -> Task ()) -> Task ()
 175 //                              cont name synfun = get randomInt
 176 //                                      @ (\randint->{deviceChannels=name +++ toString randint, deviceName=name, deviceTasks=[], deviceTask=Nothing})
 177 //                                      >>= \dev->appendTopLevelTask 'DM'.newMap True (let ch = channels dev in process ch -||- synfun ch)
 178 //                                      >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
 179 //                                      @! ()
 180
 181                 process :: (Shared Channels) -> Task ()
 182                 process ch = forever (watch ch >>* [OnValue (
 183                                 ifValue (not o isEmpty o fst3)
 184                                 (\t->upd (appFst3 (const [])) ch >>| process (fst3 t)))])
 185                         where
 186                                 process :: [MTaskMSGRecv] -> Task ()
 187                                 process [] = treturn ()
 188                                 process [m:ms] = (case m of
 189                                         MTTaskAck i = traceValue (toString m) @! ()
 190                                         MTTaskDelAck i = traceValue (toString m) @! ()
 191                                         MTSDSAck i = traceValue (toString m) @! ()
 192                                         MTSDSDelAck i = traceValue (toString m) @! ()
 193                                         MTPub i val = getSDSRecord i >>= set (toInt val.[0]*256 + toInt val.[1]) o getSDSStore @! ()
 194                                         MTMessage val = traceValue (toString m) @! ()
 195                                         MTEmpty = treturn ()
 196                                         ) >>| process ms
 197
 198                 deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
 199                 deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
 200                         connected = if (isNothing d.deviceTask) False True,
 201                         tasks = [s +++ toString i\\(s, i)<-d.deviceTasks]}\\d<-ds]
 202
 203                 mapPar :: (a -> Task a) [a] -> Task ()
 204                 mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
 205                 allAtOnce t = foldr1 (||-) t @! ()
 206                 //allAtOnce = (flip (@!) ()) o foldr1 (||-)
 207
 208 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 209 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 210
 211 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
 212 syncNetworkChannel server port channel = catchAll
 213                 (tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ())
 214                 (\v->traceValue v @! ())
 215         where
 216                 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 217                 onConnect _ (msgs,send,sendStopped)
 218                         = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
 219
 220                 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 221
 222                 //whileConnected Nothing acc (msgs,send,sendStopped)
 223                 //= (Ok acc, Just (msgs,[],sendStopped), map encode send, False)
 224                 whileConnected mnewData acc (msgs,send,sendStopped)
 225                 = (Ok acc, Just (msgs ++ map decode (maybeToList mnewData),[],sendStopped), map encode send, False)
 226                 //| sendStopped = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
 227 //              = (Ok acc, Just (msgs ++ [decode newData],[],False), [], False)
 228
 229                 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
 230                 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)