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