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