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 instance == BCValue where (==) a b = toByteCode a == toByteCode b
45 encode :: MTaskMSGSend -> String
46 encode (MTTask to data) = "t" +++ toByteCode to +++ to16bit (size data) +++ data +++ "\n"
47 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
48 encode (MTSds i v) = "s" +++ to16bit i +++ toByteCode v +++ "\n"
49 encode (MTUpd i v) = "u" +++ to16bit i +++ toByteCode v +++ "\n"
50 encode (MTSpec) = "c\n"
51 encode (MTShutdown) = "h\n"
54 decode :: String -> MTaskMSGRecv
56 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
57 | size x == 0 = MTEmpty
59 't' = MTTaskAck (fromByteCode x) (fromByteCode (x % (2, size x)))
60 'd' = MTTaskDelAck $ fromByteCode x
62 's' = MTSDSAck $ fromByteCode x
63 'a' = MTSDSDelAck $ fromByteCode x
64 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
65 'c' = MTDevSpec $ fromByteCode (x % (1, size x))
68 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
70 safePrint :== toString o toJSON
72 instance toString MTaskInterval where
73 toString OneShot = "One shot"
74 toString (OnInterrupt i) = "Interrupt: " +++ toString i
75 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
77 instance toString MTaskMSGSend where
78 toString (MTSds i v) = "Sds id: " +++ toString i
79 +++ " value " +++ safePrint v
80 toString (MTTask to data) = "Task timeout: " +++ toString to
81 +++ " data " +++ safePrint data
82 toString (MTTaskDel i) = "Task delete request: " +++ toString i
83 toString (MTUpd i v) = "Update id: " +++ toString i
84 +++ " value " +++ safePrint v
85 toString (MTSpec) = "Spec request"
86 toString (MTShutdown) = "Shutdown request"
88 instance toString MTaskMSGRecv where
89 toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
90 +++ " free memory: " +++ toString mem
91 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
92 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
93 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
94 toString (MTPub i v) = "Publish id: " +++ toString i
95 +++ " value " +++ safePrint v
96 toString (MTDevSpec mt) = "Specification: " +++ printToString mt
97 toString (MTMessage m) = m
98 toString MTEmpty = "Empty message"
100 toByteVal :: BC -> String
101 toByteVal b = {toChar $ consIndex{|*|} b} +++
103 (BCPush (BCValue i)) = toByteCode i
104 (BCLab i) = {toChar i}
105 (BCSdsStore i) = to16bit i.sdsi
106 (BCSdsFetch i) = to16bit i.sdsi
107 (BCSdsPublish i) = to16bit i.sdsi
108 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
109 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
110 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
111 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
112 (BCJmp i) = {toChar i}
113 (BCJmpT i) = {toChar i}
114 (BCJmpF i) = {toChar i}
117 parseBCValue :: Char String -> BCValue
118 parseBCValue c s = case c of
119 'b' = BCValue $ castfbc True s
120 'i' = BCValue $ castfbc 0 s
121 'l' = BCValue $ castfbc (L 0) s
122 'c' = BCValue $ castfbc ('0') s
123 'B' = BCValue $ castfbc (NoButton) s
124 'L' = BCValue $ castfbc (LED1) s
126 castfbc :: a -> (String -> a) | mTaskType a
127 castfbc _ = fromByteCode
129 instance toByteCode Bool where toByteCode b = {'b',if b '\x01' '\0'}
130 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
131 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
132 instance toByteCode Char where toByteCode c = {'c',c}
133 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
134 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
135 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
136 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
138 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
139 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
140 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
141 instance fromByteCode Char where fromByteCode s = s.[1]
142 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
143 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
144 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
145 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
147 instance toByteCode MTaskInterval where
148 toByteCode OneShot = toByteCode (OnInterval 0)
149 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
150 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
151 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
152 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
153 instance fromByteCode MTaskInterval
157 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
160 = OnInterrupt $ fromByteCode s bitand 127
161 instance fromByteCode MTaskDeviceSpec where
162 fromByteCode s = let c = toInt s.[0] in
164 |haveLed=(c bitand 1) > 0
165 ,haveAio=(c bitand 2) > 0
166 ,haveDio=(c bitand 4) > 0
167 ,bytesMemory=from16bit $ s % (1,3)
170 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
171 derive class gCons BC, BCShare
173 consIndex{|BCValue|} _ = 0
174 consName{|BCValue|} _ = "BCValue"
175 conses{|BCValue|} = [BCValue 0]
176 consNum{|BCValue|} _ = 1
177 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
179 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
181 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
182 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
183 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
185 castEditor :: a -> (Editor a) | mTaskType a
186 castEditor _ = gEditor{|*|}
188 gText{|BCValue|} fm Nothing = []
189 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
190 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
191 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
193 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
194 JSS = JSONDecode{|*|}
195 gDefault{|BCValue|} = BCValue 0
196 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
198 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
199 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
201 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b p3
202 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
204 op :: (ByteCode a p) BC -> ByteCode b c
205 op (BC x) bc = BC $ x >>| tell [bc]
207 tell` :: [BC] -> (ByteCode a p)
208 tell` x = BC $ tell x
210 instance arith ByteCode where
211 lit x = tell` [BCPush $ BCValue x]
212 (+.) x y = op2 x y BCAdd
213 (-.) x y = op2 x y BCSub
214 (*.) x y = op2 x y BCMul
215 (/.) x y = op2 x y BCDiv
217 instance boolExpr ByteCode where
218 (&.) x y = op2 x y BCAnd
219 (|.) x y = op2 x y BCOr
221 (==.) x y = op2 x y BCEq
222 (!=.) x y = op2 x y BCNeq
223 (<.) x y = op2 x y BCLes
224 (>.) x y = op2 x y BCGre
225 (<=.) x y = op2 x y BCLeq
226 (>=.) x y = op2 x y BCGeq
228 instance analogIO ByteCode where
229 analogRead p = tell` [BCAnalogRead $ pin p]
230 analogWrite p b = op b (BCAnalogWrite $ pin p)
232 instance digitalIO ByteCode where
233 digitalRead p = tell` [BCDigitalRead $ pin p]
234 digitalWrite p b = op b (BCDigitalWrite $ pin p)
236 instance aIO ByteCode where
237 aIO p = tell` [BCAnalogRead $ pin p]
239 instance dIO ByteCode where
240 dIO p = tell` [BCDigitalRead $ pin p]
242 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
243 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
244 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
245 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
246 instance IF ByteCode where
247 IF b t e = BCIfStmt b t e
248 (?) b t = BCIfStmt b t $ tell` mempty
249 BCIfStmt (BC b) (BC t) (BC e) = BC $
250 freshl >>= \else->freshl >>= \endif->
251 b >>| tell [BCJmpF else] >>|
252 t >>| tell [BCJmp endif, BCLab else] >>|
253 e >>| tell [BCLab endif]
255 freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl
256 freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs
258 instance noOp ByteCode where noOp = tell` [BCNop]
260 unBC :: (ByteCode a p) -> RWS () [BC] BCState ()
263 instance sds ByteCode where
264 sds f = {main = BC $ freshs
265 >>= \sdsi->pure {BCShare | sdsi=sdsi,sdsval=BCValue 0}
266 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
267 >>= \(v In bdy)->modify (addSDS sds v)
268 >>| unBC (unMain bdy)}
270 addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
274 instance sdspub ByteCode where
275 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
277 instance assign ByteCode where
278 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
280 //This is going to include pins as well, as variables
281 makeStore [BCSdsFetch i] = [BCSdsStore i]
282 makeStore [BCDigitalRead i] = [BCDigitalWrite i]
283 makeStore [BCAnalogRead i] = [BCAnalogWrite i]
285 instance seq ByteCode where
286 (>>=.) _ _ = abort "undef on >>=."
287 (:.) (BC x) (BC y) = BC $ x >>| y
289 instance serial ByteCode where
290 serialAvailable = tell` [BCSerialAvail]
291 serialPrint s = tell` [BCSerialPrint]
292 serialPrintln s = tell` [BCSerialPrintln]
293 serialRead = tell` [BCSerialRead]
294 serialParseInt = tell` [BCSerialParseInt]
296 instance userLed ByteCode where
297 ledOn l = op l BCLedOn
298 ledOff l = op l BCLedOff
300 instance retrn ByteCode where
301 retrn = tell` [BCReturn]
303 instance zero BCState where
304 zero = {freshl=1, freshs=1, sdss=[]}
306 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
308 # (s, bc) = runBC x s
309 # (bc, gtmap) = computeGotos bc 1
310 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
312 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
313 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
314 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
317 bclength :: BC -> Int
318 bclength (BCPush s) = 1 + size (toByteCode s)
319 bclength (BCSdsStore _) = 3
320 bclength (BCSdsFetch _) = 3
321 bclength (BCSdsPublish _) = 3
322 bclength x = 1 + consNum{|*|} x
324 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
325 computeGotos [] _ = ([], 'DM'.newMap)
326 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
327 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
329 readable :: BC -> String
330 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
332 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
333 readable b = printToString b
335 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
336 runBC (BC x) = execRWS x ()
338 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
339 toReadableByteCode x s
340 # (s, bc) = runBC x s
341 # (bc, gtmap) = computeGotos bc 0
342 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
344 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
345 lineNumbers ls [] = []
346 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
348 (ex, newls) = splitAt (bclength b - 1) ls
350 derive gPrint BCShare
352 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
353 toMessages interval x s
354 # (bc, newstate) = toRealByteCode (unMain x) s
355 # newsdss = 'DL'.difference newstate.sdss s.sdss
356 | not (trace_tn $ printToString s.sdss) = undef
357 | not (trace_tn $ printToString newstate.sdss) = undef
358 | not (trace_tn $ printToString newsdss) = undef
359 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
360 [MTTask interval bc], newstate)
362 instance == BCShare where (==) a b = a.sdsi == b.sdsi
364 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
365 Start = fst $ toReadableByteCode (unMain $ bc) zero
366 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
367 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
370 // bc = {main = ledOn (lit LED1)}
373 // {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
375 IF (analogRead A0 >. lit 50)
376 ( digitalWrite D0 (lit True) )
377 ( digitalWrite D0 (lit False) )
381 to16bit :: Int -> String
382 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
384 from16bit :: String -> Int
385 from16bit s = toInt s.[0] * 256 + toInt s.[1]
387 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode