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 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 >>= \sdsi->pure {BCShare | sdsi=sdsi,sdsval=BCValue 0}
256 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
257 >>= \(v In bdy)->modify (addSDS sds v)
258 >>| unBC (unMain bdy)}
260 addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
263 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
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 = 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 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