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