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)
168 , stackSize = from16bit $ s % (3,5)
169 , aPins = toInt s.[5]
170 , dPins = toInt s.[6]
173 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
174 derive class gCons BC, BCShare
176 consIndex{|BCValue|} _ = 0
177 consName{|BCValue|} _ = "BCValue"
178 conses{|BCValue|} = [BCValue 0]
179 consNum{|BCValue|} _ = 1
180 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
182 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
184 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
185 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
186 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
188 castEditor :: a -> (Editor a) | mTaskType a
189 castEditor _ = gEditor{|*|}
191 gText{|BCValue|} fm Nothing = []
192 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
193 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
194 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
196 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
197 JSS = JSONDecode{|*|}
198 gDefault{|BCValue|} = BCValue 0
199 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
201 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
202 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
204 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b p3
205 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
207 op :: (ByteCode a p) BC -> ByteCode b c
208 op (BC x) bc = BC $ x >>| tell [bc]
210 tell` :: [BC] -> (ByteCode a p)
211 tell` x = BC $ tell x
213 instance arith ByteCode where
214 lit x = tell` [BCPush $ BCValue x]
215 (+.) x y = op2 x y BCAdd
216 (-.) x y = op2 x y BCSub
217 (*.) x y = op2 x y BCMul
218 (/.) x y = op2 x y BCDiv
220 instance boolExpr ByteCode where
221 (&.) x y = op2 x y BCAnd
222 (|.) x y = op2 x y BCOr
224 (==.) x y = op2 x y BCEq
225 (!=.) x y = op2 x y BCNeq
226 (<.) x y = op2 x y BCLes
227 (>.) x y = op2 x y BCGre
228 (<=.) x y = op2 x y BCLeq
229 (>=.) x y = op2 x y BCGeq
231 instance analogIO ByteCode where
232 analogRead p = tell` [BCAnalogRead $ pin p]
233 analogWrite p b = op b (BCAnalogWrite $ pin p)
235 instance digitalIO ByteCode where
236 digitalRead p = tell` [BCDigitalRead $ pin p]
237 digitalWrite p b = op b (BCDigitalWrite $ pin p)
239 instance aIO ByteCode where
240 aIO p = tell` [BCAnalogRead $ pin p]
242 instance dIO ByteCode where
243 dIO p = tell` [BCDigitalRead $ pin p]
245 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
246 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
247 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
248 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
249 instance IF ByteCode where
250 IF b t e = BCIfStmt b t e
251 (?) b t = BCIfStmt b t $ tell` mempty
252 BCIfStmt (BC b) (BC t) (BC e) = BC $
253 freshl >>= \else->freshl >>= \endif->
254 b >>| tell [BCJmpF else] >>|
255 t >>| tell [BCJmp endif, BCLab else] >>|
256 e >>| tell [BCLab endif]
258 freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl
259 freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs
261 instance noOp ByteCode where noOp = tell` [BCNop]
263 unBC :: (ByteCode a p) -> RWS () [BC] BCState ()
266 instance sds ByteCode where
267 sds f = {main = BC $ freshs
268 >>= \sdsi->pure {BCShare | sdsi=sdsi,sdsval=BCValue 0}
269 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
270 >>= \(v In bdy)->modify (addSDS sds v)
271 >>| unBC (unMain bdy)}
273 addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
277 instance sdspub ByteCode where
278 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
280 instance assign ByteCode where
281 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
283 //This is going to include pins as well, as variables
284 makeStore [BCSdsFetch i] = [BCSdsStore i]
285 makeStore [BCDigitalRead i] = [BCDigitalWrite i]
286 makeStore [BCAnalogRead i] = [BCAnalogWrite i]
288 instance seq ByteCode where
289 (>>=.) _ _ = abort "undef on >>=."
290 (:.) (BC x) (BC y) = BC $ x >>| y
292 instance serial ByteCode where
293 serialAvailable = tell` [BCSerialAvail]
294 serialPrint s = tell` [BCSerialPrint]
295 serialPrintln s = tell` [BCSerialPrintln]
296 serialRead = tell` [BCSerialRead]
297 serialParseInt = tell` [BCSerialParseInt]
299 instance userLed ByteCode where
300 ledOn l = op l BCLedOn
301 ledOff l = op l BCLedOff
303 instance retrn ByteCode where
304 retrn = tell` [BCReturn]
306 instance zero BCState where
307 zero = {freshl=1, freshs=1, sdss=[]}
309 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
311 # (s, bc) = runBC x s
312 # (bc, gtmap) = computeGotos bc 1
313 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
315 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
316 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
317 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
320 bclength :: BC -> Int
321 bclength (BCPush s) = 1 + size (toByteCode s)
322 bclength (BCSdsStore _) = 3
323 bclength (BCSdsFetch _) = 3
324 bclength (BCSdsPublish _) = 3
325 bclength x = 1 + consNum{|*|} x
327 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
328 computeGotos [] _ = ([], 'DM'.newMap)
329 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
330 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
332 readable :: BC -> String
333 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
335 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
336 readable b = printToString b
338 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
339 runBC (BC x) = execRWS x ()
341 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
342 toReadableByteCode x s
343 # (s, bc) = runBC x s
344 # (bc, gtmap) = computeGotos bc 0
345 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
347 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
348 lineNumbers ls [] = []
349 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
351 (ex, newls) = splitAt (bclength b - 1) ls
353 derive gPrint BCShare
355 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
356 toMessages interval x s
357 # (bc, newstate) = toRealByteCode (unMain x) s
358 # newsdss = 'DL'.difference newstate.sdss s.sdss
359 | not (trace_tn $ printToString s.sdss) = undef
360 | not (trace_tn $ printToString newstate.sdss) = undef
361 | not (trace_tn $ printToString newsdss) = undef
362 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
363 [MTTask interval bc], newstate)
365 instance == BCShare where (==) a b = a.sdsi == b.sdsi
367 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
368 Start = [fst $ toReadableByteCode (unMain $ p0) zero
369 ,'Text'.concat $ compile p0
372 p0 :: (Main (a Int Expr)) | assign a & arith a & sds a
373 p0 = sds \x = 6 In {main = x =. x *. lit 7}
376 IF (analogRead A0 >. lit 50)
377 ( digitalWrite D0 (lit True) )
378 ( digitalWrite D0 (lit False) )
382 to16bit :: Int -> String
383 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
385 from16bit :: String -> Int
386 from16bit s = toInt s.[0] * 256 + toInt s.[1]
388 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode