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"
49 encode (MTShutdown) = "h\n"
52 decode :: String -> MTaskMSGRecv
54 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
55 | size x == 0 = MTEmpty
57 't' = MTTaskAck (fromByteCode x) (fromByteCode (x % (2, size x)))
58 'd' = MTTaskDelAck $ fromByteCode x
60 's' = MTSDSAck $ fromByteCode x
61 'a' = MTSDSDelAck $ fromByteCode x
62 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
63 'c' = MTDevSpec $ fromByteCode (x % (1, size x))
66 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
68 safePrint :== toString o toJSON
70 instance toString MTaskInterval where
71 toString OneShot = "One shot"
72 toString (OnInterrupt i) = "Interrupt: " +++ toString i
73 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
75 instance toString MTaskMSGSend where
76 toString (MTSds i v) = "Sds id: " +++ toString i
77 +++ " value " +++ safePrint v
78 toString (MTTask to data) = "Task timeout: " +++ toString to
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
83 toString (MTSpec) = "Spec request"
84 toString (MTShutdown) = "Shutdown request"
86 instance toString MTaskMSGRecv where
87 toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
88 +++ " free memory: " +++ toString mem
89 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
90 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
91 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
92 toString (MTPub i v) = "Publish id: " +++ toString i
93 +++ " value " +++ safePrint v
94 toString (MTDevSpec mt) = "Specification: " +++ printToString mt
95 toString (MTMessage m) = m
96 toString MTEmpty = "Empty message"
98 toByteVal :: BC -> String
99 toByteVal b = {toChar $ consIndex{|*|} b} +++
101 (BCPush (BCValue i)) = toByteCode i
102 (BCLab i) = {toChar i}
103 (BCSdsStore i) = to16bit i
104 (BCSdsFetch i) = to16bit i
105 (BCSdsPublish i) = to16bit i
106 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
107 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
108 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
109 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
110 (BCJmp i) = {toChar i}
111 (BCJmpT i) = {toChar i}
112 (BCJmpF i) = {toChar i}
115 parseBCValue :: Char String -> BCValue
116 parseBCValue c s = case c of
117 'b' = BCValue $ castfbc True s
118 'i' = BCValue $ castfbc 0 s
119 'l' = BCValue $ castfbc (L 0) s
120 'c' = BCValue $ castfbc ('0') s
121 'B' = BCValue $ castfbc (NoButton) s
122 'L' = BCValue $ castfbc (LED1) s
124 castfbc :: a -> (String -> a) | mTaskType a
125 castfbc _ = fromByteCode
127 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
128 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
129 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
130 instance toByteCode Char where toByteCode c = {'c',c}
131 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
132 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
133 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
134 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
136 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
137 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
138 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
139 instance fromByteCode Char where fromByteCode s = s.[1]
140 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
141 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
142 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
143 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
145 instance toByteCode MTaskInterval where
146 toByteCode OneShot = toByteCode (OnInterval 0)
147 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
148 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
149 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
150 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
151 instance fromByteCode MTaskInterval
155 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
158 = OnInterrupt $ fromByteCode s bitand 127
159 instance fromByteCode MTaskDeviceSpec where
160 fromByteCode s = let c = toInt s.[0] in
162 |haveLed=(c bitand 1) > 0
163 ,haveAio=(c bitand 2) > 0
164 ,haveDio=(c bitand 4) > 0
165 ,bytesMemory=from16bit $ s % (1,3)
168 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
169 derive class gCons BC
171 consIndex{|BCValue|} _ = 0
172 consName{|BCValue|} _ = "BCValue"
173 conses{|BCValue|} = [BCValue 0]
174 consNum{|BCValue|} _ = 1
175 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
177 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
179 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
180 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
181 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
183 castEditor :: a -> (Editor a) | mTaskType a
184 castEditor _ = gEditor{|*|}
186 gText{|BCValue|} fm Nothing = []
187 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
188 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
189 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
191 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
192 JSS = JSONDecode{|*|}
193 gDefault{|BCValue|} = BCValue 0
194 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
196 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
197 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
199 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
200 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
202 op :: (ByteCode a p) BC -> ByteCode a Expr
203 op (BC x) bc = BC $ x >>| tell [bc]
205 tell` x = BC $ tell x
207 instance arith ByteCode where
208 lit x = tell` [BCPush $ BCValue x]
209 (+.) x y = op2 x y BCAdd
210 (-.) x y = op2 x y BCSub
211 (*.) x y = op2 x y BCMul
212 (/.) x y = op2 x y BCDiv
214 instance boolExpr ByteCode where
215 (&.) x y = op2 x y BCAnd
216 (|.) x y = op2 x y BCOr
218 (==.) x y = op2 x y BCEq
219 (!=.) x y = op2 x y BCNeq
220 (<.) x y = op2 x y BCLes
221 (>.) x y = op2 x y BCGre
222 (<=.) x y = op2 x y BCLeq
223 (>=.) x y = op2 x y BCGeq
225 instance analogIO ByteCode where
226 analogRead p = tell` [BCAnalogRead $ pin p]
227 analogWrite p b = op b (BCAnalogWrite $ pin p)
229 instance digitalIO ByteCode where
230 digitalRead p = tell` [BCDigitalRead $ pin p]
231 digitalWrite p b = op b (BCDigitalWrite $ pin p)
233 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
234 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
235 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
236 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
237 instance IF ByteCode where
238 IF b t e = BCIfStmt b t e
239 (?) b t = BCIfStmt b t $ tell` mempty
240 BCIfStmt (BC b) (BC t) (BC e) = BC $
241 freshl >>= \else->freshl >>= \endif->
242 b >>| tell [BCJmpF else] >>|
243 t >>| tell [BCJmp endif, BCLab else] >>|
244 e >>| tell [BCLab endif]
246 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
247 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
249 instance noOp ByteCode where noOp = tell` [BCNop]
253 instance sds ByteCode where
254 sds f = {main = BC $ freshs
255 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
256 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
257 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
259 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
262 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
263 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
265 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
267 instance assign ByteCode where
268 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
270 //This is going to include pins as well, as variables
271 makeStore [BCSdsFetch i] = [BCSdsStore i]
273 instance seq ByteCode where
274 (>>=.) _ _ = abort "undef on >>=."
275 (:.) (BC x) (BC y) = BC $ x >>| y
277 instance serial ByteCode where
278 serialAvailable = tell` [BCSerialAvail]
279 serialPrint s = tell` [BCSerialPrint]
280 serialPrintln s = tell` [BCSerialPrintln]
281 serialRead = tell` [BCSerialRead]
282 serialParseInt = tell` [BCSerialParseInt]
284 instance userLed ByteCode where
285 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
286 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
288 instance retrn ByteCode where
289 retrn = tell` [BCReturn]
291 instance zero BCState where
292 zero = {freshl=[1..], freshs=[1..], sdss=[]}
294 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
296 # (s, bc) = runBC x s
297 # (bc, gtmap) = computeGotos bc 1
298 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
300 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
301 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
302 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
305 bclength :: BC -> Int
306 bclength (BCPush s) = 1 + size (toByteCode s)
307 bclength (BCSdsStore _) = 3
308 bclength (BCSdsFetch _) = 3
309 bclength (BCSdsPublish _) = 3
310 bclength x = 1 + consNum{|*|} x
312 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
313 computeGotos [] _ = ([], 'DM'.newMap)
314 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
315 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
317 readable :: BC -> String
318 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
320 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
321 readable b = printToString b
323 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
324 runBC (BC x) = execRWS x ()
326 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
327 toReadableByteCode x s
328 # (s, bc) = runBC x s
329 # (bc, gtmap) = computeGotos bc 0
330 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
332 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
333 lineNumbers ls [] = []
334 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
336 (ex, newls) = splitAt (bclength b - 1) ls
338 derive gPrint BCShare
340 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
341 toMessages interval x s
342 # (bc, newstate) = toRealByteCode (unMain x) s
343 # newsdss = 'DL'.difference newstate.sdss s.sdss
344 | not (trace_tn $ printToString s.sdss) = undef
345 | not (trace_tn $ printToString newstate.sdss) = undef
346 | not (trace_tn $ printToString newsdss) = undef
347 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
348 [MTTask interval bc], newstate)
350 instance == BCShare where (==) a b = a.sdsi == b.sdsi
352 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
353 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
354 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
355 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
358 // bc = {main = ledOn (lit LED1)}
361 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
363 to16bit :: Int -> String
364 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
366 from16bit :: String -> Int
367 from16bit s = toInt s.[0] * 256 + toInt s.[1]
369 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode