3 import StdDebug, StdMisc
4 from StdFunc import flip
9 from Text import class Text(startsWith,concat,split,join), instance Text String
11 import qualified Data.Map as DM
13 from Data.Func import $
16 import System.Directory
18 import iTasks._Framework.Store
22 derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED
24 :: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool)
26 :: SerTCP = SerialDevice | TCPDevice
28 deviceTask :: Maybe TaskId,
29 deviceConnected :: Maybe String,
31 deviceTasks :: [(String, Int)]
40 Start :: *World -> *World
41 Start world = startEngine (mTaskManager
42 >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
44 memoryShare :: String a -> Shared a | iTask a
45 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
47 deviceStore :: Shared [MTaskDevice]
48 deviceStore = sharedStore "mTaskDevices" []
50 sdsStore :: Shared [MTaskShare]
51 sdsStore = memoryShare "mTaskShares" []
53 bcStateStore :: Shared BCState
54 bcStateStore = memoryShare "mTaskBCState" zero
56 mTaskTaskStore :: Shared [String]
57 mTaskTaskStore = memoryShare "mTaskTasks" ["count", "ledon", "ledoff"]
59 mTaskMap :: Map String (Main (ByteCode () Stmt))
60 mTaskMap = 'DM'.fromList [("count", bc), ("ledon", bc2 LED1), ("ledoff", bc3 LED3)]
62 bc :: Main (ByteCode () Stmt)
63 bc = sds \x=1 In sds \pinnetje=1 In {main =
70 IF (pinnetje ==. lit 1) (
73 IF (pinnetje ==. lit 2) (
80 bc2 :: UserLED -> Main (ByteCode () Stmt)
81 bc2 d = {main = ledOn d}
83 bc3 :: UserLED -> Main (ByteCode () Stmt)
84 bc3 d = {main = ledOff d}
86 :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [String]}
87 derive class iTask MTaskDeviceStatus, MTaskDevice, MTaskShare, BCState
89 mTaskManager :: Task ()
90 mTaskManager = anyTask
92 , whileUnchanged sdsStore viewShares
93 , whileUnchanged deviceStore viewDevices
94 ] <<@ ApplyLayout layout
96 layout = sequenceLayouts
97 [ arrangeWithSideBar 0 LeftSide 260 True
98 , arrangeSplit Vertical True
101 viewmTasks = listmTasks
102 >&^ \sh->whileUnchanged sh $ \mi->forever (case mi of
103 Nothing = viewInformation "No task selected" [] ()
104 Just mTaskTask = get deviceStore
105 >>= \devices->case devices of
106 [] = viewInformation "No devices yet" [] ()
107 ds = sendmTask mTaskTask ds @! ())
109 listmTasks :: Task String
110 listmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
112 sendmTask mTaskId ds =
113 (enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] ds
114 -&&- enterInformation "Timeout, 0 for one-shot" [])
115 >>* [OnAction (Action "Send") (withValue $ Just o sendToDevice mTaskId)]
117 sendToDevice :: String (MTaskDevice, Int) -> Task ()
118 sendToDevice mTask (device, timeout) =
119 get bcStateStore @ createBytecode
120 >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
121 >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
123 >>| upd (\(r,s,ss)->(r,s++msgs,ss)) (channels device)
126 createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask mTaskMap)) st
127 sharename i = fromJust (device.deviceConnected) +++ "-" +++ toString i
128 toSDSRecords st = [{MTaskShare |
129 initValue=toInt d1*265 + toInt d2,
132 realShare="mTaskSDS-" +++ toString i}
133 \\(i,[d1,d2])<-st.sdss]
134 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
136 getSDSStore :: MTaskShare -> Shared Int
137 getSDSStore sh = memoryShare sh.realShare 0
139 getSDSRecord :: Int -> Task MTaskShare
140 getSDSRecord i = get sdsStore @ \l->hd [s\\s<-l | s.identifier == i]
142 channels :: MTaskDevice -> Shared Channels
143 channels d = memoryShare (fromJust d.deviceConnected) ([], [], False)
145 viewShares :: [MTaskShare] -> Task ()
146 viewShares st = anyTask $ map viewer st
148 viewer :: MTaskShare -> Task ()
149 viewer m = viewSharedInformation "" [] (getSDSStore m)
150 <<@ Title ("SDS: " +++ toString m.identifier) @! ()
151 // enterChoiceWithShared "Shares" [ChooseFromList id] sdsStore
152 // >>* [OnValue $ withValue $ Just o updateShare]
153 // >>* [OnAction (Action "Back") (const $ Just $ treturn ())]
155 // sdsvw (k, v) = concat ["SDS ", toString k, ": ", toString v]
156 // updateShare s = viewInformation "" [] ()
157 // updateShare (k, v) = (viewInformation "Key" [] k
158 // ||- updateInformation "Value" [] v)
161 viewDevices :: [MTaskDevice] -> Task ()
162 viewDevices ds = anyTask [
163 addDevice deviceStore <<@ Title "Add new device" @! ():
164 [viewDevice d <<@ Title d.deviceName\\d<-ds]]
165 <<@ ArrangeWithTabs @! ()
167 viewDevice :: MTaskDevice -> Task ()
168 viewDevice d = (viewInformation "Device settings" [] d
169 ||- (case d.deviceConnected of
170 Just s = viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
171 Nothing = viewInformation "No channels yet" [] "" @! ()
172 )) <<@ ArrangeHorizontal
174 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
176 addDevice :: (Shared [MTaskDevice]) -> Task SerTCP
177 addDevice devices = enterInformation "Device type" []
178 >&^ \sh->whileUnchanged sh $ \mty->case mty of
179 Nothing = viewInformation "No type selected yet" [] "" @! ()
181 TCPDevice = (enterInformation "Name" [] -&&- enterInformation "Hostname" [] -&&- enterInformation "Port" [])
182 >>= \(name, (host, port))->cont name (syncNetworkChannel host port)
183 SerialDevice = (enterInformation "Name" [] -&&- enterTTYSettings)
184 >>= \(name, set)->cont name (syncSerialChannel set encode decode)
186 cont :: String ((Shared Channels) -> Task ()) -> Task ()
187 cont name synfun = get randomInt
188 @ (\randint->{deviceConnected=Just (name +++ toString randint), deviceName=name, deviceTasks=[], deviceTask=Nothing})
189 >>= \dev->appendTopLevelTask 'DM'.newMap True (let ch = channels dev in process ch -||- synfun ch)
190 >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
193 process :: (Shared Channels) -> Task ()
194 process ch = forever (watch ch >>* [OnValue (
195 ifValue (not o isEmpty o fst3)
196 (\t->upd (appFst3 (const [])) ch >>| process (fst3 t)))])
198 process :: [MTaskMSGRecv] -> Task ()
199 process [] = treturn ()
200 process [m:ms] = (case m of
201 MTTaskAck i = traceValue (toString m) @! ()
202 MTTaskDelAck i = traceValue (toString m) @! ()
203 MTSDSAck i = traceValue (toString m) @! ()
204 MTSDSDelAck i = traceValue (toString m) @! ()
205 MTPub i val = getSDSRecord i >>= set (toInt val.[0]*256 + toInt val.[1]) o getSDSStore @! ()
206 MTMessage val = traceValue (toString m) @! ()
210 deviceviewer :: [MTaskDevice] -> [MTaskDeviceStatus]
211 deviceviewer ds = [{MTaskDeviceStatus | name = d.deviceName,
212 connected = if (isNothing d.deviceConnected) False True,
213 tasks = [s +++ toString i\\(s, i)<-d.deviceTasks]}\\d<-ds]
215 mapPar :: (a -> Task a) [a] -> Task ()
216 mapPar f l = foldr1 (\x y->f x ||- y) l <<@ ArrangeWithTabs @! ()
217 allAtOnce t = foldr1 (||-) t @! ()
218 //allAtOnce = (flip (@!) ()) o foldr1 (||-)
220 sendMsg :: [MTaskMSGSend] (Shared ([MTaskMSGRecv],[MTaskMSGSend],Bool)) -> Task ()
221 sendMsg m ch = upd (\(r,s,ss)->(r,s ++ m,True)) ch @! ()
223 syncNetworkChannel :: String Int (Shared ([MTaskMSGRecv], [MTaskMSGSend], Bool)) -> Task ()
224 syncNetworkChannel server port channel = catchAll
225 (tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @! ())
226 (\v->traceValue v @! ())
228 onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
229 onConnect _ (msgs,send,sendStopped)
230 = (Ok "", Just (msgs,[],sendStopped), map encode send, False)
232 whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool)
233 whileConnected Nothing acc (msgs,send,sendStopped)
234 = (Ok acc, Nothing, [], False)
236 whileConnected (Just newData) acc (msgs,send,sendStopped)
237 = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
238 //| sendStopped = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False)
239 // = (Ok acc, Just (msgs ++ [decode newData],[],False), [], False)
241 onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool))
242 onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing)