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