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" +++ tob +++ to16bit (size data) +++ data +++ "\n"
48 OnInterval i = to16bit i
49 OnInterrupt _ = abort "Interrupts not implemented yet"
50 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
51 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
52 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
54 decode :: String -> MTaskMSGRecv
56 | size x == 0 = MTEmpty
58 't' = MTTaskAck $ fromByteCode x
59 'd' = MTTaskDelAck $ fromByteCode x
61 's' = MTSDSAck $ fromByteCode x
62 'a' = MTSDSDelAck $ fromByteCode x
63 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
64 'c' = MTDevSpec $ fromByteCode (x % (1, size x))
67 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
69 safePrint :== toString o toJSON
71 instance toString MTaskInterval where
72 toString OneShot = "One shot"
73 toString (OnInterrupt i) = "Interrupt: " +++ toString i
74 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
76 instance toString MTaskMSGSend where
77 toString (MTSds i v) = "Sds id: " +++ toString i
78 +++ " value " +++ safePrint v
79 toString (MTTask to data) = "Task timeout: " +++ toString to
80 +++ " data " +++ safePrint data
81 toString (MTTaskDel i) = "Task delete request: " +++ toString i
82 toString (MTUpd i v) = "Update id: " +++ toString i
83 +++ " value " +++ safePrint v
85 instance toString MTaskMSGRecv where
86 toString (MTTaskAck i) = "Task added with id: " +++ toString i
87 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
88 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
89 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
90 toString (MTPub i v) = "Publish id: " +++ toString i
91 +++ " value " +++ safePrint v
92 toString (MTDevSpec mt) = "Specification: " +++ printToString mt
93 toString (MTMessage m) = m
94 toString MTEmpty = "Empty message"
96 toByteVal :: BC -> String
97 toByteVal b = {toChar $ consIndex{|*|} b} +++
99 (BCPush (BCValue i)) = toByteCode i
100 (BCLab i) = {toChar i}
101 (BCSdsStore i) = to16bit i
102 (BCSdsFetch i) = to16bit i
103 (BCSdsPublish i) = to16bit i
104 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
105 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
106 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
107 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
108 (BCJmp i) = {toChar i}
109 (BCJmpT i) = {toChar i}
110 (BCJmpF i) = {toChar i}
113 parseBCValue :: Char String -> BCValue
114 parseBCValue c s = case c of
115 'b' = BCValue $ castfbc True s
116 'i' = BCValue $ castfbc 0 s
117 'l' = BCValue $ castfbc (L 0) s
118 'c' = BCValue $ castfbc ('0') s
119 'B' = BCValue $ castfbc (NoButton) s
120 'L' = BCValue $ castfbc (LED1) s
122 castfbc :: a -> (String -> a) | mTaskType a
123 castfbc _ = fromByteCode
125 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
126 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
127 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
128 instance toByteCode Char where toByteCode c = {'c',c}
129 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
130 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
131 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
132 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
134 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
135 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
136 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
137 instance fromByteCode Char where fromByteCode s = s.[1]
138 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
139 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
140 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
141 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
143 instance toByteCode MTaskInterval where
144 toByteCode OneShot = toByteCode 0
145 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
146 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
147 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
148 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
149 instance fromByteCode MTaskInterval
153 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
156 = OnInterrupt $ fromByteCode s bitand 127
157 instance fromByteCode MTaskDeviceSpec where
158 fromByteCode s = let c = toInt s.[0] in
160 |haveLed=c bitand 1 > 0
161 ,haveAio=c bitand 2 > 0
162 ,haveDio=c bitand 4 > 0
163 ,maxTask=from16bit $ s % (1,3)
164 ,maxSDS=from16bit $ s % (3,5)
167 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
168 derive class gCons BC
170 consIndex{|BCValue|} _ = 0
171 consName{|BCValue|} _ = "BCValue"
172 conses{|BCValue|} = [BCValue 0]
173 consNum{|BCValue|} _ = 1
174 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
176 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
178 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
179 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
180 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
182 castEditor :: a -> (Editor a) | mTaskType a
183 castEditor _ = gEditor{|*|}
185 gText{|BCValue|} fm Nothing = []
186 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
187 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
188 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
190 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
191 JSS = JSONDecode{|*|}
192 gDefault{|BCValue|} = BCValue 0
193 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
195 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
196 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
198 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
199 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
201 op :: (ByteCode a p) BC -> ByteCode a Expr
202 op (BC x) bc = BC $ x >>| tell [bc]
204 tell` x = BC $ tell x
206 instance arith ByteCode where
207 lit x = tell` [BCPush $ BCValue x]
208 (+.) x y = op2 x y BCAdd
209 (-.) x y = op2 x y BCSub
210 (*.) x y = op2 x y BCMul
211 (/.) x y = op2 x y BCDiv
213 instance boolExpr ByteCode where
214 (&.) x y = op2 x y BCAnd
215 (|.) x y = op2 x y BCOr
217 (==.) x y = op2 x y BCEq
218 (!=.) x y = op2 x y BCNeq
219 (<.) x y = op2 x y BCLes
220 (>.) x y = op2 x y BCGre
221 (<=.) x y = op2 x y BCLeq
222 (>=.) x y = op2 x y BCGeq
224 instance analogIO ByteCode where
225 analogRead p = tell` [BCAnalogRead $ pin p]
226 analogWrite p b = op b (BCAnalogWrite $ pin p)
228 instance digitalIO ByteCode where
229 digitalRead p = tell` [BCDigitalRead $ pin p]
230 digitalWrite p b = op b (BCDigitalWrite $ pin p)
232 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
233 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
234 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
235 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
236 instance IF ByteCode where
237 IF b t e = BCIfStmt b t e
238 (?) b t = BCIfStmt b t $ tell` mempty
239 BCIfStmt (BC b) (BC t) (BC e) = BC $
240 freshl >>= \else->freshl >>= \endif->
241 b >>| tell [BCJmpF else] >>|
242 t >>| tell [BCJmp endif, BCLab else] >>|
243 e >>| tell [BCLab endif]
245 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
246 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
248 instance noOp ByteCode where noOp = tell` [BCNop]
252 instance sds ByteCode where
253 sds f = {main = BC $ freshs
254 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
255 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
256 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
258 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
261 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
262 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
264 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
266 instance assign ByteCode where
267 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
269 //This is going to include pins as well, as variables
270 makeStore [BCSdsFetch i] = [BCSdsStore i]
272 instance seq ByteCode where
273 (>>=.) _ _ = abort "undef on >>=."
274 (:.) (BC x) (BC y) = BC $ x >>| y
276 instance serial ByteCode where
277 serialAvailable = tell` [BCSerialAvail]
278 serialPrint s = tell` [BCSerialPrint]
279 serialPrintln s = tell` [BCSerialPrintln]
280 serialRead = tell` [BCSerialRead]
281 serialParseInt = tell` [BCSerialParseInt]
283 instance userLed ByteCode where
284 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
285 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
287 instance zero BCState where
288 zero = {freshl=[1..], freshs=[1..], sdss=[]}
290 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
292 # (s, bc) = runBC x s
293 # (bc, gtmap) = computeGotos bc 1
294 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
296 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
297 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
298 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
301 bclength :: BC -> Int
302 bclength (BCPush s) = 1 + size (toByteCode s)
303 bclength (BCSdsStore _) = 3
304 bclength (BCSdsFetch _) = 3
305 bclength (BCSdsPublish _) = 3
306 bclength x = 1 + consNum{|*|} x
308 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
309 computeGotos [] _ = ([], 'DM'.newMap)
310 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
311 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
313 readable :: BC -> String
314 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
316 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
317 readable b = printToString b
319 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
320 runBC (BC x) = execRWS x ()
322 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
323 toReadableByteCode x s
324 # (s, bc) = runBC x s
325 # (bc, gtmap) = computeGotos bc 0
326 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
328 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
329 lineNumbers ls [] = []
330 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
332 (ex, newls) = splitAt (bclength b - 1) ls
334 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
335 toMessages interval (bytes, st=:{sdss}) = (
336 [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
337 [MTTask interval bytes], st)
339 toSDSUpdate :: Int Int -> [MTaskMSGSend]
340 toSDSUpdate i v = [MTUpd i (to16bit v)]
342 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
343 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
344 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
345 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
348 // bc = {main = ledOn (lit LED1)}
351 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
353 to16bit :: Int -> String
354 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
356 from16bit :: String -> Int
357 from16bit s = toInt s.[0] * 256 + toInt s.[1]
359 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode