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