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 import Data.Tuple
  12 import System.Directory
  13
  14 import iTasks.UI.Definition
  15
  16 import iTasks._Framework.TaskState
  17 import iTasks._Framework.TaskServer
  18 import iTasks._Framework.IWorld
  19 import iTasks._Framework.Store
  20
  21 import TTY
  22
  23 derive class iTask Queue, TTYSettings, Parity, BaudRate, ByteSize
  24 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP
  25
  26 :: SerTCP = Serial | TCP
  27 :: *Resource | TTYd !*TTY
  28
  29 Start :: *World -> *World
  30 Start world = startEngine mTaskTask world
  31 //Start world = startEngine mTaskTask world
  32
  33 bc :: Main (ByteCode () Stmt)
  34 bc = sds \x=1 In sds \pinnetje=1 In {main =
  35                 IF (digitalRead D3 ==. lit True) (
  36                         x =. x +. lit 1 :.
  37                         pub x
  38                 ) (
  39                         noOp
  40                 ) :.
  41                 IF (pinnetje ==. lit 1) (
  42                         digitalWrite D0 (lit True) :.
  43                         digitalWrite D1 (lit False) :.
  44                         digitalWrite D2 (lit False)
  45                 ) (
  46                         IF (pinnetje ==. lit 2) (
  47                                 digitalWrite D0 (lit False) :.
  48                                 digitalWrite D1 (lit True) :.
  49                                 digitalWrite D2 (lit False)
  50                         ) (
  51                                 digitalWrite D0 (lit False) :.
  52                                 digitalWrite D1 (lit False) :.
  53                                 digitalWrite D2 (lit True)
  54                         )
  55                 )}
  56
  57 deviceSelector :: (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
  58 deviceSelector ch = enterInformation "Type" []
  59         >>= \ty->case ty of
  60                 TCP = (enterInformation "Host" [] -&&- enterInformation "Port" [])
  61                         >>= \(port,host)->syncNetworkChannel host port ch
  62 //              Serial = accWorld getDevices
  63 //                      >>= \dl->(enterChoice "Device" [] dl -&&- enterInformation "Settings" [])
  64 //                      >>= \(dev,set)->syncSerialChannel dev set decode encode ch
  65         where
  66                 getDevices :: !*World -> *(![String], !*World)
  67                 getDevices w = case readDirectory "/dev" w of
  68                         (Error (errcode, errmsg), w) = abort errmsg
  69                         (Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
  70                         where
  71                                 isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
  72                                 prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial"]
  73
  74
  75 mTaskTask :: Task ()
  76 mTaskTask = let (msgs, sdsShares) = makeMsgs 500 bc in
  77         withShared ([], msgs, False) (\ch->
  78                         deviceSelector ch
  79 //              ||- sendTasks msgs ch//sendMsg msgs ch
  80 //              ||- (whileUnchanged ch (process sdsShares messageShare ch))
  81                 ||- viewSharedInformation "channels" [ViewWith lens] ch
  82                 ||- viewSharedInformation "messages" [] messageShare
  83                 ||- viewSh sdsShares ch
  84                 >>* [OnAction ActionFinish (always shutDown)]
  85         )
  86         where
  87                 messageShare :: Shared [String]
  88                 messageShare = sharedStore "mTaskMessagesRecv" []
  89
  90                 makeMsgs :: Int (Main (ByteCode () Stmt)) -> ([MTaskMSGSend], [(Int, Shared Int)])
  91                 makeMsgs timeout bc
  92                 # (msgs, st) = toMessages timeout (toRealByteCode (unMain bc))
  93                 = (msgs, map f st.sdss)
  94                         where
  95                                 f (i,d) = (i, sharedStore ("mTaskSDS-" +++ toString i) 0)
  96
  97                 updateSDSs :: [(Int, Shared Int)] (Shared [String]) MTaskMSGRecv -> Task ()
  98                 updateSDSs _ m (MTMessage s) = upd (\l->take 20 [s:l]) m @! ()
  99                 updateSDSs _ _ MTEmpty = return ()
 100                 updateSDSs [(id, sh):xs] m n=:(MTPub i d)
 101                 | id == i = set ((toInt d.[0])*265 + toInt d.[1]) sh @! ()
 102                 = updateSDSs xs m n
 103
 104                 lens :: ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> ([String], [String])
 105                 lens (r,s,_) = (map toString r, map toString s)
 106
 107                 viewSh :: [(Int, Shared Int)] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 108                 viewSh [] ch = return ()
 109                 viewSh [(i, sh):xs] ch
 110                 # sharename = "SDS-" +++ toString i
 111                 = (
 112                                 viewSharedInformation ("SDS-" +++ toString i) [] sh ||-
 113                                 forever (
 114                                         enterInformation sharename []
 115                                         >>* [OnAction ActionOk
 116                                                         (ifValue (\j->j>=1 && j <= 3)
 117                                                         (\c->set c sh
 118                                                                 >>= \_->sendMsg (toSDSUpdate i c) ch
 119                                                                 @! ()
 120                                                         )
 121                                                 )]
 122                                 )
 123                         ) ||- viewSh xs ch
 124
 125 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
 126 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
 127
 128 syncSerialChannel :: String TTYSettings (String -> m) (n -> String) (Shared ([m],Bool,[n],Bool)) -> Task () | iTask m & iTask n
 129 syncSerialChannel dev opts decodeFun encodeFun rw = Task eval
 130         where
 131                 eval event evalOpts tree=:(TCInit taskId ts) iworld=:{IWorld|world}
 132                 = case TTYopen dev opts world of
 133                         (False, _, world)
 134                         # (err, world) = TTYerror world
 135                         = (ExceptionResult (exception err), {iworld & world=world})
 136                         (True, tty, world)
 137                         # iworld = {iworld & world=world, resources=Just (TTYd tty)}
 138                         = case addBackgroundTask 42 (BackgroundTask (serialDeviceBackgroundTask rw decodeFun encodeFun)) iworld of
 139                                 (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 140                                 (Ok _, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} NoRep (TCBasic taskId ts JSONNull False), iworld)
 141
 142                 eval _ _ tree=:(TCBasic _ ts _ _) iworld
 143                 = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} NoRep tree, iworld)
 144
 145                 eval event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
 146                 # (TTYd tty) = fromJust resources
 147                 # (ok, world) = TTYclose tty world
 148                 # iworld = {iworld & world=world,resources=Nothing}
 149                 = case removeBackgroundTask 42 iworld of
 150                         (Error e, iworld) = (ExceptionResult (exception "h"), iworld)
 151                         (Ok _, iworld) = (DestroyedResult, iworld)
 152
 153 serialDeviceBackgroundTask :: (Shared ([m],Bool,[n],Bool)) (String -> m) (n -> String) !*IWorld -> *IWorld
 154 serialDeviceBackgroundTask rw de en iworld
 155         = case read rw iworld of
 156                 (Error e, iworld) = abort "share couldn't be read"
 157                 (Ok (r,rs,s,ss), iworld)
 158                 # (Just (TTYd tty)) = iworld.resources
 159                 # tty = writet (map en s) tty
 160                 # (ml, tty) = case TTYavailable tty of
 161                         (False, tty) = ([], tty)
 162                         (_, tty)
 163                         # (l, tty) = TTYreadline tty
 164                         = ([de l], tty)
 165                 # iworld = {iworld & resources=Just (TTYd tty)}
 166                 = case write (r++ml,rs,[],ss) rw iworld of
 167                         (Error e, iworld) = abort "share couldn't be written"
 168                         (Ok _, iworld) = case notify rw iworld of
 169                                 (Error e, iworld) = abort "share couldn't be notified"
 170                                 (Ok _, iworld) = iworld
 171         where
 172                 writet :: [String] !*TTY -> *TTY
 173                 writet [] t = t
 174                 writet [x:xs] t = writet xs (TTYwrite x t)
 175
 176
 177 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
 178 syncNetworkChannel server port channel
 179         = tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ()
 180         where
 181                 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 182                 onConnect _ (msgs,send,sendStopped)
 183                         = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
 184
 185                 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
 186                 whileConnected maybeNewData acc (msgs,send,sendStopped)
 187                 # l = map decode (maybeToList maybeNewData)
 188                 # send = if (not sendStopped) [] (map encode send)
 189                 = (Ok acc, Just (msgs ++ l,[],sendStopped), send, False)
 190
 191                 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
 192                 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)