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 from Data.Func import $
  12 import Data.Tuple
  13 import Data.List
  14 import System.Directory
  15
  16 import iTasks.UI.Definition
  17
  18 import iTasks._Framework.TaskState
  19 import iTasks._Framework.TaskServer
  20 import iTasks._Framework.IWorld
  21 import iTasks._Framework.Store
  22
  23
  24 import TTY
  25
  26 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
  27 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
  28
  29 :: *Resource | TTYd !*TTY
  30 :: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool)
  31
  32 :: SerTCP = SerialDevice | TCPDevice
  33 :: MTaskDevice = {
  34                 deviceConnected :: Maybe String,
  35                 deviceName :: String
  36         }
  37
  38 Start :: *World -> *World
  39 Start world = startEngine (mTaskManager
  40         >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
  41
  42 bc :: Main (ByteCode () Stmt)
  43 bc = sds \x=1 In sds \pinnetje=1 In {main =
  44                 IF (digitalRead D3) (
  45                         x =. x +. lit 1 :.
  46                         pub x
  47                 ) (
  48                         noOp
  49                 ) :.
  50                 IF (pinnetje ==. lit 1) (
  51                         ledOn LED1
  52                 ) (
  53                         IF (pinnetje ==. lit 2) (
  54                                 ledOn LED2
  55                         ) (
  56                                 ledOn LED3
  57                         )
  58                 )}
  59
  60 bc2 :: UserLED -> Main (ByteCode () Stmt)
  61 bc2 d = {main = ledOn d}
  62
  63 bc3 :: UserLED -> Main (ByteCode () Stmt)
  64 bc3 d = {main = ledOff d}
  65
  66 :: MTaskDeviceStatus = {connected :: Bool, name :: String}
  67 derive class iTask MTaskDeviceStatus, MTaskDevice
  68
  69 mTaskManager :: Task ()
  70 mTaskManager = anyTask
  71                 [ viewmTasks @! ()
  72                 , whileUnchanged deviceStore viewDevices
  73                 , addDevice deviceStore
  74                 , viewChannels deviceStore
  75                 ] <<@ ApplyLayout layout
  76 //      ||- whileUnchanged deviceStore (\m->if (isEmpty m)
  77 //                      (viewInformation "No devices yet" [] "" @! ()) (connectDevice m)) @! ()
  78 //              )
  79         where
  80                 isValue (Value _ _) = True
  81                 isValue _                       = False
  82
  83                 viewmTasks = viewInformation "MTasks" [] ""
  84
  85                 layout = sequenceLayouts
  86                         [ arrangeWithSideBar 0 LeftSide 260 True
  87                         , arrangeSplit Vertical True
  88                         , layoutSubs (SelectByPath [1, 0]) arrangeWithTabs
  89                         ]
  90
  91                 viewChannels :: (Shared [MTaskDevice]) -> Task ()
  92                 viewChannels sh = whileUnchanged sh (\d->if (isEmpty d)
  93                                 (viewInformation "No channels yet" [] "")
  94                                 (viewInformation "Channels available" [] "")) @! ()
  95
  96                 viewDevices :: [MTaskDevice] -> [Task ()]
  97                 viewDevices [] = viewInformation "No devices yet" [] "" @! ()
  98                 viewDevices ds = [viewInformation "Device" [] d <<@ Title d.deviceName\\d<-ds]
  99
 100                 addDevice :: (Shared [MTaskDevice]) -> Task ()
 101                 addDevice devices = enterInformation "Device type and name" []
 102                         >>= \(name, ty)->get randomInt
 103                         >>= \ident->treturn (name +++ toString ident)
 104                         >>= \realname->let ch = channels realname in case ty of
 105                                 TCPDevice = enterInformation "Hostname and port" []
 106                                         >>= \(host, port)->cont realname name ||- syncNetworkChannel host port ch
 107                                 SerialDevice = accWorld getDevices
 108                                         >>= \dl->(enterChoice "Device" [] dl -&&- updateInformation "Settings" [] zero)
 109                                         >>= \(device, settings)->cont realname name ||- syncSerialChannel device settings ch
 110                         where
 111                                 cont rn nm = (upd (\l->[dev rn nm:l]) devices >>| addDevice devices)
 112                                 dev rn nm = {deviceConnected=Just rn,deviceName=nm}
 113
 114                                 channels :: String -> Shared Channels
 115                                 channels s = sdsFocus s $ memoryStore "" $ Just ([], [], False)
 116
 117                                 getDevices :: !*World -> *(![String], !*World)
 118                                 getDevices w = case readDirectory "/dev" w of
 119                                         (Error (errcode, errmsg), w) = abort errmsg
 120                                         (Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
 121
 122                                 isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
 123                                 prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
 124
 125 //              connectDevice :: [MTaskDevice] -> Task ()
 126 //              connectDevice [] = treturn ()
 127 //              connectDevice [d:ds] = (case d.deviceConnected of
 128 //                      (Just sh) = viewSharedInformation "Buffers" [] sh @! ()
 129 //                      Nothing = viewInformation ("Connect " +++ d.deviceName) [] "" >>* [
 130 //                              OnAction (Action "connect") (const $ Just $ connect d)]
 131 //                      ) -|| connectDevice ds
 132
 133                 deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
 134                 deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
 135                         connected = if (isNothing d.deviceConnected) False True}\\d<-ds]
 136
 137                 deviceStore :: Shared [MTaskDevice]
 138                 deviceStore = sdsFocus "mTaskDevices" $ memoryStore "" (Just [])
 139
 140 //              showTabbed :: [MTaskDevice] -> Task ()
 141 //              showTabbed [] = viewInformation "" [] "No devices yet" @! ()
 142 //              showTabbed [l:ls] = foldr (\e es->manageDevice e ||- es) (manageDevice l) ls
 143 //
 144 //              manageDevice :: MTaskDevice -> Task ()
 145 //              manageDevice md =
 146 //                              either viewTCP viewSer md.deviceSettings
 147 //                      ||- maybe
 148 //                              (treturn () >>* [OnAction (Action "Connect") (always shutDown)] @! ())
 149 //                              (\b->viewSharedInformation "Buffers" [] b @! ())
 150 //                              md.deviceConnected
 151 //                      <<@ ArrangeVertical
 152
 153                 mapPar :: (a -> Task a) [a] -> Task ()
 154                 mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
 155                 allAtOnce t = foldr1 (||-) t @! ()
 156                 //allAtOnce = (flip (@!) ()) o foldr1 (||-)
 157
 158
 159 //mTaskTask :: Task ()
 160 //mTaskTask = let (msgs, sdsShares) = makeMsgs 1000 bc in
 161 //      withDevice \ch->
 162 //                      sendMsg msgs ch
 163 //              ||- processMessages ch messageShare sdsShares
 164 //              ||- forever (enterChoice "Choose led to enable" [] [LED1, LED2, LED3]
 165 //                              >>= \p->sendMsg (fst (makeMsgs 0 (bc2 p))) ch)
 166 //              ||- forever (enterChoice "Choose led to disable" [] [LED1, LED2, LED3]
 167 //                              >>= \p->sendMsg (fst (makeMsgs 0 (bc3 p))) ch)
 168 //              ||- viewSharedInformation "channels" [ViewAs lens] ch
 169 //              ||- viewSharedInformation "messages" [] messageShare
 170 //              ||- viewSh sdsShares ch
 171 //              >>* [OnAction ActionFinish (always shutDown)]
 172 //      where
 173 //              messageShare :: Shared [String]
 174 //              messageShare = sharedStore "mTaskMessagesRecv" []
 175 //
 176 //              processMessages ch msgs sdss = forever (watch ch
 177 //                      >>* [OnValue (ifValue (not o isEmpty o fst3) (process ch))])
 178 //                      where
 179 //                              process :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> Task ()
 180 //                              process ch (r,_,_) = upd (appFst3 (const [])) ch >>| process` r
 181 //                                      where
 182 //                                              process` = foldr (\r t->updateSDSs sdss msgs r >>| t) (return ())
 183 //
 184 //              makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
 185 //              makeMsgs timeout bc
 186 //              # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
 187 //              = (msgs, map f st.sdss)
 188 //                      where
 189 //                              f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) (dd d))
 190 //                              dd [x,y] = toInt x*265 + toInt y
 191 //
 192 //              updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
 193 //              updateSDSs [(id, sh):xs] m n=:(MTPub i d)
 194 //              | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
 195 //              = updateSDSs xs m n
 196 //              updateSDSs _ m mtm = case mtm of
 197 //                      MTMessage s = upd (\l->take 5 [s:l]) m @! ()
 198 //                      mta=:(MTTaskAck _) = upd (\l->take 5 [toString mta:l]) m @! ()
 199 //                      //TODO other recv msgs
 200 //                      _ = return ()
 201 //
 202 //              lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
 203 //              lens (r,s,_) = (map toString r, map toString s)
 204 //
 205 //              viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 206 //              viewSh [] ch = return ()
 207 //              viewSh [(i, sh):xs] ch
 208 //              # sharename = "SDS-" +++ toString i
 209 //              = (
 210 //                              viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
 211 //                              forever (
 212 //                                      enterInformation sharename []
 213 //                                      >>* [OnAction ActionOk
 214 //                                                      (ifValue (\j->j>=1 && j <= 3)
 215 //                                                      (\c->set c sh
 216 //                                                              >>= \_->sendMsg (toSDSUpdate i c) ch
 217 //                                                              @! ()
 218 //                                                      )
 219 //                                              )]
 220 //                              )
 221 //                      ) ||- viewSh xs ch
 222
 223 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 224 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 225
 226 syncSerialChannel :: String TTYSettings (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 227 syncSerialChannel dev opts rw = Task eval
 228         where
 229                 eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
 230                 = case TTYopen dev opts world of
 231                         (False, _, world)
 232                         # (err, world) = TTYerror world
 233                         = (ExceptionResult (exception err), {iworld & world=world})
 234                         (True, tty, world)
 235                         # iworld = {iworld & world=world, resources=Just (TTYd tty)}
 236                         = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw)) iworld of
 237                                 (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 238                                 (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoChange (TCBasic taskId ts JSONNull False), iworld)
 239
 240                 eval _ _ tree=:(TCBasic _ ts _ _) iworld
 241                 = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoChange tree, iworld)
 242
 243                 eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
 244                 # (TTYd tty) = fromJust resources
 245                 # (ok, world) = TTYclose tty world
 246                 # iworld = {iworld & world=world,resources=Nothing}
 247                 = case removeBackgroundTask 42 iworld of
 248                         (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 249                         (Ok _, iworld) = (DestroyedResult, iworld)
 250
 251 serialDeviceBackgroundTask :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld)
 252 serialDeviceBackgroundTask rw iworld
 253         = case read rw iworld of
 254                 (Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
 255                 (Ok (r,s,ss), iworld)
 256                 # (Just (TTYd tty)) = iworld.resources
 257                 # tty = writet (map encode s) tty
 258                 # (ml, tty) = case TTYavailable tty of
 259                         (False, tty) = ([], tty)
 260                         (_, tty)
 261                         # (l, tty) = TTYreadline tty
 262                         = ([decode l], tty)
 263                 # iworld = {iworld & resources=Just (TTYd tty)}
 264                 = case write (r++ml,[],False) rw iworld of
 265                         (Error e, iworld) = (Error $ exception "share couldn't be written", iworld)
 266                         (Ok _, iworld) = case notify rw iworld of
 267                                 (Error e, iworld) = (Error $ exception "share couldn't be notified", iworld)
 268                                 (Ok _, iworld) = (Ok (), iworld)
 269         where
 270                 writet :: [String] -> (*TTY -> *TTY)
 271                 writet [] = id
 272                 writet [x:xs] = writet xs o TTYwrite x
 273
 274
 275 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
 276 syncNetworkChannel server port channel
 277         = tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ()
 278         where
 279                 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 280                 onConnect _ (msgs,send,sendStopped)
 281                         = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
 282
 283                 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 284                 whileConnected Nothing acc (msgs,send,sendStopped)
 285                 = (Ok acc, Nothing, [], False)
 286
 287                 whileConnected (Just newData) acc (msgs,send,sendStopped)
 288                 | sendStopped = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
 289                 = (Ok acc, Just (msgs ++ [decode newData],[],False), [], False)
 290
 291                 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
 292                 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)