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