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"
55 decode :: String -> MTaskMSGRecv
57 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
58 | size x == 0 = MTEmpty
60 't' = MTTaskAck $ fromByteCode x
61 'd' = MTTaskDelAck $ fromByteCode x
63 's' = MTSDSAck $ fromByteCode x
64 'a' = MTSDSDelAck $ fromByteCode x
65 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
66 'c' = MTDevSpec $ fromByteCode (x % (1, size x))
69 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
71 safePrint :== toString o toJSON
73 instance toString MTaskInterval where
74 toString OneShot = "One shot"
75 toString (OnInterrupt i) = "Interrupt: " +++ toString i
76 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
78 instance toString MTaskMSGSend where
79 toString (MTSds i v) = "Sds id: " +++ toString i
80 +++ " value " +++ safePrint v
81 toString (MTTask to data) = "Task timeout: " +++ toString to
82 +++ " data " +++ safePrint data
83 toString (MTTaskDel i) = "Task delete request: " +++ toString i
84 toString (MTUpd i v) = "Update id: " +++ toString i
85 +++ " value " +++ safePrint v
87 instance toString MTaskMSGRecv where
88 toString (MTTaskAck i) = "Task added with id: " +++ toString i
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
104 (BCSdsFetch i) = to16bit i
105 (BCSdsPublish i) = to16bit i
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 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 ,maxTask=from16bit $ s % (1,3)
166 ,maxSDS=from16bit $ s % (3,5)
169 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
170 derive class gCons BC
172 consIndex{|BCValue|} _ = 0
173 consName{|BCValue|} _ = "BCValue"
174 conses{|BCValue|} = [BCValue 0]
175 consNum{|BCValue|} _ = 1
176 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
178 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
180 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
181 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
182 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
184 castEditor :: a -> (Editor a) | mTaskType a
185 castEditor _ = gEditor{|*|}
187 gText{|BCValue|} fm Nothing = []
188 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
189 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
190 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
192 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
193 JSS = JSONDecode{|*|}
194 gDefault{|BCValue|} = BCValue 0
195 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
197 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
198 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
200 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
201 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
203 op :: (ByteCode a p) BC -> ByteCode a Expr
204 op (BC x) bc = BC $ x >>| tell [bc]
206 tell` x = BC $ tell x
208 instance arith ByteCode where
209 lit x = tell` [BCPush $ BCValue x]
210 (+.) x y = op2 x y BCAdd
211 (-.) x y = op2 x y BCSub
212 (*.) x y = op2 x y BCMul
213 (/.) x y = op2 x y BCDiv
215 instance boolExpr ByteCode where
216 (&.) x y = op2 x y BCAnd
217 (|.) x y = op2 x y BCOr
219 (==.) x y = op2 x y BCEq
220 (!=.) x y = op2 x y BCNeq
221 (<.) x y = op2 x y BCLes
222 (>.) x y = op2 x y BCGre
223 (<=.) x y = op2 x y BCLeq
224 (>=.) x y = op2 x y BCGeq
226 instance analogIO ByteCode where
227 analogRead p = tell` [BCAnalogRead $ pin p]
228 analogWrite p b = op b (BCAnalogWrite $ pin p)
230 instance digitalIO ByteCode where
231 digitalRead p = tell` [BCDigitalRead $ pin p]
232 digitalWrite p b = op b (BCDigitalWrite $ pin p)
234 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
235 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
236 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
237 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
238 instance IF ByteCode where
239 IF b t e = BCIfStmt b t e
240 (?) b t = BCIfStmt b t $ tell` mempty
241 BCIfStmt (BC b) (BC t) (BC e) = BC $
242 freshl >>= \else->freshl >>= \endif->
243 b >>| tell [BCJmpF else] >>|
244 t >>| tell [BCJmp endif, BCLab else] >>|
245 e >>| tell [BCLab endif]
247 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
248 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
250 instance noOp ByteCode where noOp = tell` [BCNop]
254 instance sds ByteCode where
255 sds f = {main = BC $ freshs
256 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
257 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
258 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
260 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
263 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
264 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
266 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
268 instance assign ByteCode where
269 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
271 //This is going to include pins as well, as variables
272 makeStore [BCSdsFetch i] = [BCSdsStore i]
274 instance seq ByteCode where
275 (>>=.) _ _ = abort "undef on >>=."
276 (:.) (BC x) (BC y) = BC $ x >>| y
278 instance serial ByteCode where
279 serialAvailable = tell` [BCSerialAvail]
280 serialPrint s = tell` [BCSerialPrint]
281 serialPrintln s = tell` [BCSerialPrintln]
282 serialRead = tell` [BCSerialRead]
283 serialParseInt = tell` [BCSerialParseInt]
285 instance userLed ByteCode where
286 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
287 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
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 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
337 toMessages interval (bytes, st=:{sdss}) = (
338 [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
339 [MTTask interval bytes], st)
341 toSDSUpdate :: Int Int -> [MTaskMSGSend]
342 toSDSUpdate i v = [MTUpd i (to16bit v)]
344 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
345 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
346 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
347 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
350 // bc = {main = ledOn (lit LED1)}
353 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
355 to16bit :: Int -> String
356 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
358 from16bit :: String -> Int
359 from16bit s = toInt s.[0] * 256 + toInt s.[1]
361 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode