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 ret data) = "t" +++ toByteCode to +++ toString ret +++ 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 ret data) = "Task timeout: " +++ toString to
78 +++ " return type: " +++ toString ret
79 +++ " data " +++ safePrint data
80 toString (MTTaskDel i) = "Task delete request: " +++ toString i
81 toString (MTUpd i v) = "Update id: " +++ toString i
82 +++ " value " +++ safePrint v
84 instance toString MTaskMSGRecv where
85 toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
86 +++ " free memory: " +++ toString mem
87 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
88 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
89 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
90 toString (MTPub i v) = "Publish id: " +++ toString i
91 +++ " value " +++ safePrint v
92 toString (MTDevSpec mt) = "Specification: " +++ printToString mt
93 toString (MTMessage m) = m
94 toString MTEmpty = "Empty message"
96 toByteVal :: BC -> String
97 toByteVal b = {toChar $ consIndex{|*|} b} +++
99 (BCPush (BCValue i)) = toByteCode i
100 (BCLab i) = {toChar i}
101 (BCSdsStore i) = to16bit i
102 (BCSdsFetch i) = to16bit i
103 (BCSdsPublish i) = to16bit i
104 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
105 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
106 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
107 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
108 (BCJmp i) = {toChar i}
109 (BCJmpT i) = {toChar i}
110 (BCJmpF i) = {toChar i}
113 parseBCValue :: Char String -> BCValue
114 parseBCValue c s = case c of
115 'b' = BCValue $ castfbc True s
116 'i' = BCValue $ castfbc 0 s
117 'l' = BCValue $ castfbc (L 0) s
118 'c' = BCValue $ castfbc ('0') s
119 'B' = BCValue $ castfbc (NoButton) s
120 'L' = BCValue $ castfbc (LED1) s
122 castfbc :: a -> (String -> a) | mTaskType a
123 castfbc _ = fromByteCode
125 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
126 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
127 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
128 instance toByteCode Char where toByteCode c = {'c',c}
129 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
130 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
131 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
132 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
134 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
135 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
136 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
137 instance fromByteCode Char where fromByteCode s = s.[1]
138 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
139 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
140 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
141 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
143 instance toByteCode MTaskInterval where
144 toByteCode OneShot = toByteCode (OnInterval 0)
145 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
146 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
147 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
148 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
149 instance fromByteCode MTaskInterval
153 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
156 = OnInterrupt $ fromByteCode s bitand 127
157 instance fromByteCode MTaskDeviceSpec where
158 fromByteCode s = let c = toInt s.[0] in
160 |haveLed=(c bitand 1) > 0
161 ,haveAio=(c bitand 2) > 0
162 ,haveDio=(c bitand 4) > 0
163 ,bytesMemory=from16bit $ s % (1,3)
166 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
167 derive class gCons BC
169 consIndex{|BCValue|} _ = 0
170 consName{|BCValue|} _ = "BCValue"
171 conses{|BCValue|} = [BCValue 0]
172 consNum{|BCValue|} _ = 1
173 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
175 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
177 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
178 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
179 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
181 castEditor :: a -> (Editor a) | mTaskType a
182 castEditor _ = gEditor{|*|}
184 gText{|BCValue|} fm Nothing = []
185 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
186 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
187 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
189 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
190 JSS = JSONDecode{|*|}
191 gDefault{|BCValue|} = BCValue 0
192 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
194 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
195 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
197 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
198 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
200 op :: (ByteCode a p) BC -> ByteCode a Expr
201 op (BC x) bc = BC $ x >>| tell [bc]
203 tell` x = BC $ tell x
205 instance arith ByteCode where
206 lit x = tell` [BCPush $ BCValue x]
207 (+.) x y = op2 x y BCAdd
208 (-.) x y = op2 x y BCSub
209 (*.) x y = op2 x y BCMul
210 (/.) x y = op2 x y BCDiv
212 instance boolExpr ByteCode where
213 (&.) x y = op2 x y BCAnd
214 (|.) x y = op2 x y BCOr
216 (==.) x y = op2 x y BCEq
217 (!=.) x y = op2 x y BCNeq
218 (<.) x y = op2 x y BCLes
219 (>.) x y = op2 x y BCGre
220 (<=.) x y = op2 x y BCLeq
221 (>=.) x y = op2 x y BCGeq
223 instance analogIO ByteCode where
224 analogRead p = tell` [BCAnalogRead $ pin p]
225 analogWrite p b = op b (BCAnalogWrite $ pin p)
227 instance digitalIO ByteCode where
228 digitalRead p = tell` [BCDigitalRead $ pin p]
229 digitalWrite p b = op b (BCDigitalWrite $ pin p)
231 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
232 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
233 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
234 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
235 instance IF ByteCode where
236 IF b t e = BCIfStmt b t e
237 (?) b t = BCIfStmt b t $ tell` mempty
238 BCIfStmt (BC b) (BC t) (BC e) = BC $
239 freshl >>= \else->freshl >>= \endif->
240 b >>| tell [BCJmpF else] >>|
241 t >>| tell [BCJmp endif, BCLab else] >>|
242 e >>| tell [BCLab endif]
244 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
245 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
247 instance noOp ByteCode where noOp = tell` [BCNop]
251 instance sds ByteCode where
252 sds f = {main = BC $ freshs
253 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
254 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
255 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
257 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
260 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
261 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
263 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
265 instance assign ByteCode where
266 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
268 //This is going to include pins as well, as variables
269 makeStore [BCSdsFetch i] = [BCSdsStore i]
271 instance seq ByteCode where
272 (>>=.) _ _ = abort "undef on >>=."
273 (:.) (BC x) (BC y) = BC $ x >>| y
275 instance serial ByteCode where
276 serialAvailable = tell` [BCSerialAvail]
277 serialPrint s = tell` [BCSerialPrint]
278 serialPrintln s = tell` [BCSerialPrintln]
279 serialRead = tell` [BCSerialRead]
280 serialParseInt = tell` [BCSerialParseInt]
282 instance userLed ByteCode where
283 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
284 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
286 instance retrn ByteCode where
287 retrn (BC l) = tell` [BCReturn]
289 instance zero BCState where
290 zero = {freshl=[1..], freshs=[1..], sdss=[]}
292 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
294 # (s, bc) = runBC x s
295 # (bc, gtmap) = computeGotos bc 1
296 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
298 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
299 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
300 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
303 bclength :: BC -> Int
304 bclength (BCPush s) = 1 + size (toByteCode s)
305 bclength (BCSdsStore _) = 3
306 bclength (BCSdsFetch _) = 3
307 bclength (BCSdsPublish _) = 3
308 bclength x = 1 + consNum{|*|} x
310 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
311 computeGotos [] _ = ([], 'DM'.newMap)
312 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
313 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
315 readable :: BC -> String
316 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
318 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
319 readable b = printToString b
321 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
322 runBC (BC x) = execRWS x ()
324 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
325 toReadableByteCode x s
326 # (s, bc) = runBC x s
327 # (bc, gtmap) = computeGotos bc 0
328 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
330 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
331 lineNumbers ls [] = []
332 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
334 (ex, newls) = splitAt (bclength b - 1) ls
336 derive gPrint BCShare
338 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
339 toMessages interval x s
340 # (bc, newstate) = toRealByteCode (unMain x) s
341 # newsdss = 'DL'.difference newstate.sdss s.sdss
342 | not (trace_tn $ printToString s.sdss) = undef
343 | not (trace_tn $ printToString newstate.sdss) = undef
344 | not (trace_tn $ printToString newsdss) = undef
345 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
346 [MTTask interval 'i' bc], newstate)
348 instance == BCShare where (==) a b = a.sdsi == b.sdsi
350 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
351 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
352 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
353 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
356 // bc = {main = ledOn (lit LED1)}
359 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
361 to16bit :: Int -> String
362 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
364 from16bit :: String -> Int
365 from16bit s = toInt s.[0] * 256 + toInt s.[1]
367 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode