1 implementation module mTaskInterpret
5 import iTasks.UI.Editor.Common
6 import iTasks.UI.Editor
8 import GenEq, StdMisc, StdArray, GenBimap
17 from StdFunc import o, const
24 from Data.Func import $
25 from Text import class Text(subString,lpad,concat,toUpperCase), instance Text String
29 import Control.Monad.RWST
30 import Control.Monad.Identity
32 import Control.Applicative
37 import qualified Data.Map as DM
38 import qualified Data.List as DL
39 import Text.Encodings.Base64
43 encode :: MTaskMSGSend -> String
44 encode (MTTask to data) = "t" +++ toByteCode to +++ to16bit (size data) +++ data +++ "\n"
45 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
46 encode (MTSds i v) = "s" +++ to16bit i +++ toByteCode v +++ "\n"
47 encode (MTUpd i v) = "u" +++ to16bit i +++ toByteCode v +++ "\n"
48 encode (MTSpec) = "c\n"
51 decode :: String -> MTaskMSGRecv
53 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
54 | size x == 0 = MTEmpty
56 't' = MTTaskAck (fromByteCode x) (fromByteCode (x % (2, size x)))
57 'd' = MTTaskDelAck $ fromByteCode x
59 's' = MTSDSAck $ fromByteCode x
60 'a' = MTSDSDelAck $ fromByteCode x
61 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
62 'c' = MTDevSpec $ fromByteCode (x % (1, size x))
65 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
67 safePrint :== toString o toJSON
69 instance toString MTaskInterval where
70 toString OneShot = "One shot"
71 toString (OnInterrupt i) = "Interrupt: " +++ toString i
72 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
74 instance toString MTaskMSGSend where
75 toString (MTSds i v) = "Sds id: " +++ toString i
76 +++ " value " +++ safePrint v
77 toString (MTTask to data) = "Task timeout: " +++ toString to
78 +++ " data " +++ safePrint data
79 toString (MTTaskDel i) = "Task delete request: " +++ toString i
80 toString (MTUpd i v) = "Update id: " +++ toString i
81 +++ " value " +++ safePrint v
83 instance toString MTaskMSGRecv where
84 toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
85 +++ " free memory: " +++ toString mem
86 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
87 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
88 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
89 toString (MTPub i v) = "Publish id: " +++ toString i
90 +++ " value " +++ safePrint v
91 toString (MTDevSpec mt) = "Specification: " +++ printToString mt
92 toString (MTMessage m) = m
93 toString MTEmpty = "Empty message"
95 toByteVal :: BC -> String
96 toByteVal b = {toChar $ consIndex{|*|} b} +++
98 (BCPush (BCValue i)) = toByteCode i
99 (BCLab i) = {toChar i}
100 (BCSdsStore i) = to16bit i
101 (BCSdsFetch i) = to16bit i
102 (BCSdsPublish i) = to16bit i
103 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
104 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
105 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
106 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
107 (BCJmp i) = {toChar i}
108 (BCJmpT i) = {toChar i}
109 (BCJmpF i) = {toChar i}
112 parseBCValue :: Char String -> BCValue
113 parseBCValue c s = case c of
114 'b' = BCValue $ castfbc True s
115 'i' = BCValue $ castfbc 0 s
116 'l' = BCValue $ castfbc (L 0) s
117 'c' = BCValue $ castfbc ('0') s
118 'B' = BCValue $ castfbc (NoButton) s
119 'L' = BCValue $ castfbc (LED1) s
121 castfbc :: a -> (String -> a) | mTaskType a
122 castfbc _ = fromByteCode
124 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
125 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
126 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
127 instance toByteCode Char where toByteCode c = {'c',c}
128 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
129 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
130 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
131 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
133 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
134 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
135 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
136 instance fromByteCode Char where fromByteCode s = s.[1]
137 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
138 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
139 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
140 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
142 instance toByteCode MTaskInterval where
143 toByteCode OneShot = toByteCode (OnInterval 0)
144 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
145 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
146 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
147 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
148 instance fromByteCode MTaskInterval
152 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
155 = OnInterrupt $ fromByteCode s bitand 127
156 instance fromByteCode MTaskDeviceSpec where
157 fromByteCode s = let c = toInt s.[0] in
159 |haveLed=(c bitand 1) > 0
160 ,haveAio=(c bitand 2) > 0
161 ,haveDio=(c bitand 4) > 0
162 ,bytesMemory=from16bit $ s % (1,3)
165 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
166 derive class gCons BC
168 consIndex{|BCValue|} _ = 0
169 consName{|BCValue|} _ = "BCValue"
170 conses{|BCValue|} = [BCValue 0]
171 consNum{|BCValue|} _ = 1
172 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
174 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
176 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
177 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
178 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
180 castEditor :: a -> (Editor a) | mTaskType a
181 castEditor _ = gEditor{|*|}
183 gText{|BCValue|} fm Nothing = []
184 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
185 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
186 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
188 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
189 JSS = JSONDecode{|*|}
190 gDefault{|BCValue|} = BCValue 0
191 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
193 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
194 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
196 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
197 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
199 op :: (ByteCode a p) BC -> ByteCode a Expr
200 op (BC x) bc = BC $ x >>| tell [bc]
202 tell` x = BC $ tell x
204 instance arith ByteCode where
205 lit x = tell` [BCPush $ BCValue x]
206 (+.) x y = op2 x y BCAdd
207 (-.) x y = op2 x y BCSub
208 (*.) x y = op2 x y BCMul
209 (/.) x y = op2 x y BCDiv
211 instance boolExpr ByteCode where
212 (&.) x y = op2 x y BCAnd
213 (|.) x y = op2 x y BCOr
215 (==.) x y = op2 x y BCEq
216 (!=.) x y = op2 x y BCNeq
217 (<.) x y = op2 x y BCLes
218 (>.) x y = op2 x y BCGre
219 (<=.) x y = op2 x y BCLeq
220 (>=.) x y = op2 x y BCGeq
222 instance analogIO ByteCode where
223 analogRead p = tell` [BCAnalogRead $ pin p]
224 analogWrite p b = op b (BCAnalogWrite $ pin p)
226 instance digitalIO ByteCode where
227 digitalRead p = tell` [BCDigitalRead $ pin p]
228 digitalWrite p b = op b (BCDigitalWrite $ pin p)
230 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
231 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
232 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
233 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
234 instance IF ByteCode where
235 IF b t e = BCIfStmt b t e
236 (?) b t = BCIfStmt b t $ tell` mempty
237 BCIfStmt (BC b) (BC t) (BC e) = BC $
238 freshl >>= \else->freshl >>= \endif->
239 b >>| tell [BCJmpF else] >>|
240 t >>| tell [BCJmp endif, BCLab else] >>|
241 e >>| tell [BCLab endif]
243 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
244 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
246 instance noOp ByteCode where noOp = tell` [BCNop]
250 instance sds ByteCode where
251 sds f = {main = BC $ freshs
252 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
253 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
254 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
256 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
259 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
260 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
262 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
264 instance assign ByteCode where
265 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
267 //This is going to include pins as well, as variables
268 makeStore [BCSdsFetch i] = [BCSdsStore i]
270 instance seq ByteCode where
271 (>>=.) _ _ = abort "undef on >>=."
272 (:.) (BC x) (BC y) = BC $ x >>| y
274 instance serial ByteCode where
275 serialAvailable = tell` [BCSerialAvail]
276 serialPrint s = tell` [BCSerialPrint]
277 serialPrintln s = tell` [BCSerialPrintln]
278 serialRead = tell` [BCSerialRead]
279 serialParseInt = tell` [BCSerialParseInt]
281 instance userLed ByteCode where
282 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
283 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
285 instance retrn ByteCode where
286 retrn (BC l) = tell` [BCReturn]
288 instance zero BCState where
289 zero = {freshl=[1..], freshs=[1..], sdss=[]}
291 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
293 # (s, bc) = runBC x s
294 # (bc, gtmap) = computeGotos bc 1
295 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
297 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
298 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
299 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
302 bclength :: BC -> Int
303 bclength (BCPush s) = 1 + size (toByteCode s)
304 bclength (BCSdsStore _) = 3
305 bclength (BCSdsFetch _) = 3
306 bclength (BCSdsPublish _) = 3
307 bclength x = 1 + consNum{|*|} x
309 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
310 computeGotos [] _ = ([], 'DM'.newMap)
311 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
312 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
314 readable :: BC -> String
315 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
317 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
318 readable b = printToString b
320 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
321 runBC (BC x) = execRWS x ()
323 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
324 toReadableByteCode x s
325 # (s, bc) = runBC x s
326 # (bc, gtmap) = computeGotos bc 0
327 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
329 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
330 lineNumbers ls [] = []
331 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
333 (ex, newls) = splitAt (bclength b - 1) ls
335 derive gPrint BCShare
337 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
338 toMessages interval x s
339 # (bc, newstate) = toRealByteCode (unMain x) s
340 # newsdss = 'DL'.difference newstate.sdss s.sdss
341 | not (trace_tn $ printToString s.sdss) = undef
342 | not (trace_tn $ printToString newstate.sdss) = undef
343 | not (trace_tn $ printToString newsdss) = undef
344 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
345 [MTTask interval bc], newstate)
347 instance == BCShare where (==) a b = a.sdsi == b.sdsi
349 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
350 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
351 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
352 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
355 // bc = {main = ledOn (lit LED1)}
358 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
360 to16bit :: Int -> String
361 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
363 from16bit :: String -> Int
364 from16bit s = toInt s.[0] * 256 + toInt s.[1]
366 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode