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.sdsi
104 (BCSdsFetch i) = to16bit i.sdsi
105 (BCSdsPublish i) = to16bit i.sdsi
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, BCShare
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 aIO ByteCode where
236 instance dIO ByteCode where
237 dIO p = tell` [BCDigitalRead $ pin p]
239 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
240 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
241 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
242 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
243 instance IF ByteCode where
244 IF b t e = BCIfStmt b t e
245 (?) b t = BCIfStmt b t $ tell` mempty
246 BCIfStmt (BC b) (BC t) (BC e) = BC $
247 freshl >>= \else->freshl >>= \endif->
248 b >>| tell [BCJmpF else] >>|
249 t >>| tell [BCJmp endif, BCLab else] >>|
250 e >>| tell [BCLab endif]
252 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
253 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
255 instance noOp ByteCode where noOp = tell` [BCNop]
259 instance sds ByteCode where
260 sds f = {main = BC $ freshs
261 >>= \sdsi->pure {BCShare | sdsi=sdsi,sdsval=BCValue 0}
262 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
263 >>= \(v In bdy)->modify (addSDS sds v)
264 >>| unBC (unMain bdy)}
266 addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
269 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
271 instance assign ByteCode where
272 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
274 //This is going to include pins as well, as variables
275 makeStore [BCSdsFetch i] = [BCSdsStore i]
276 makeStore [BCDigitalRead i] = [BCDigitalWrite i]
277 makeStore [BCAnalogRead i] = [BCAnalogWrite i]
279 instance seq ByteCode where
280 (>>=.) _ _ = abort "undef on >>=."
281 (:.) (BC x) (BC y) = BC $ x >>| y
283 instance serial ByteCode where
284 serialAvailable = tell` [BCSerialAvail]
285 serialPrint s = tell` [BCSerialPrint]
286 serialPrintln s = tell` [BCSerialPrintln]
287 serialRead = tell` [BCSerialRead]
288 serialParseInt = tell` [BCSerialParseInt]
290 instance userLed ByteCode where
291 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
292 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
294 instance retrn ByteCode where
295 retrn = tell` [BCReturn]
297 instance zero BCState where
298 zero = {freshl=[1..], freshs=[1..], sdss=[]}
300 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
302 # (s, bc) = runBC x s
303 # (bc, gtmap) = computeGotos bc 1
304 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
306 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
307 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
308 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
311 bclength :: BC -> Int
312 bclength (BCPush s) = 1 + size (toByteCode s)
313 bclength (BCSdsStore _) = 3
314 bclength (BCSdsFetch _) = 3
315 bclength (BCSdsPublish _) = 3
316 bclength x = 1 + consNum{|*|} x
318 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
319 computeGotos [] _ = ([], 'DM'.newMap)
320 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
321 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
323 readable :: BC -> String
324 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
326 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
327 readable b = printToString b
329 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
330 runBC (BC x) = execRWS x ()
332 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
333 toReadableByteCode x s
334 # (s, bc) = runBC x s
335 # (bc, gtmap) = computeGotos bc 0
336 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
338 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
339 lineNumbers ls [] = []
340 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
342 (ex, newls) = splitAt (bclength b - 1) ls
344 derive gPrint BCShare
346 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
347 toMessages interval x s
348 # (bc, newstate) = toRealByteCode (unMain x) s
349 # newsdss = 'DL'.difference newstate.sdss s.sdss
350 | not (trace_tn $ printToString s.sdss) = undef
351 | not (trace_tn $ printToString newstate.sdss) = undef
352 | not (trace_tn $ printToString newsdss) = undef
353 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
354 [MTTask interval bc], newstate)
356 instance == BCShare where (==) a b = a.sdsi == b.sdsi
358 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
359 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
360 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
361 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
364 // bc = {main = ledOn (lit LED1)}
367 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
369 to16bit :: Int -> String
370 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
372 from16bit :: String -> Int
373 from16bit s = toInt s.[0] * 256 + toInt s.[1]
375 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode