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 (from16bit (x % (1,3)))
59 'd' = MTTaskDelAck (from16bit (x % (1,3)))
61 's' = MTSDSAck (from16bit (x % (1,3)))
62 'a' = MTSDSDelAck (from16bit (x % (1,3)))
63 'p' = MTPub (from16bit (x % (1,3))) (x % (3,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
84 instance toString MTaskMSGRecv where
85 toString (MTTaskAck i) = "Task added with id: " +++ toString i
86 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
87 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
88 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
89 toString (MTPub i v) = "Publish id: " +++ toString i
90 +++ " value " +++ safePrint v
91 toString (MTMessage m) = m
92 toString MTEmpty = "Empty message"
94 toByteVal :: BC -> String
95 toByteVal b = {toChar $ consIndex{|*|} b} +++
97 (BCPush (BCValue i)) = toByteCode i
98 (BCLab i) = {toChar i}
99 (BCSdsStore i) = to16bit i
100 (BCSdsFetch i) = to16bit i
101 (BCSdsPublish i) = to16bit i
102 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
103 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
104 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
105 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
106 (BCJmp i) = {toChar i}
107 (BCJmpT i) = {toChar i}
108 (BCJmpF i) = {toChar i}
111 parseBCValue :: Char String -> BCValue
112 parseBCValue c s = case c of
113 'b' = BCValue $ castfbc True s
114 'i' = BCValue $ castfbc 0 s
115 'l' = BCValue $ castfbc (L 0) s
116 'c' = BCValue $ castfbc ('0') s
117 'B' = BCValue $ castfbc (NoButton) s
118 'L' = BCValue $ castfbc (LED1) s
120 castfbc :: a -> (String -> a) | mTaskType a
121 castfbc _ = fromByteCode
123 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
124 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
125 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
126 instance toByteCode Char where toByteCode c = {'c',c}
127 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
128 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
129 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
130 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
132 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
133 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
134 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
135 instance fromByteCode Char where fromByteCode s = s.[1]
136 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
137 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
138 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
139 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
141 instance toByteCode MTaskInterval where
142 toByteCode OneShot = toByteCode 0
143 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
144 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
145 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
146 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
147 instance fromByteCode MTaskInterval
151 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
154 = OnInterrupt $ fromByteCode s bitand 127
156 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC
157 derive class gCons BC
159 consIndex{|BCValue|} _ = 0
160 consName{|BCValue|} _ = "BCValue"
161 conses{|BCValue|} = [BCValue 0]
162 consNum{|BCValue|} _ = 1
163 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
165 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
167 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
168 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
169 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
171 castEditor :: a -> (Editor a) | mTaskType a
172 castEditor _ = gEditor{|*|}
174 gText{|BCValue|} fm Nothing = []
175 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
176 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
177 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
179 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
180 JSS = JSONDecode{|*|}
181 gDefault{|BCValue|} = BCValue 0
182 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
184 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
185 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
187 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
188 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
190 op :: (ByteCode a p) BC -> ByteCode a Expr
191 op (BC x) bc = BC $ x >>| tell [bc]
193 tell` x = BC $ tell x
195 instance arith ByteCode where
196 lit x = tell` [BCPush $ BCValue x]
197 (+.) x y = op2 x y BCAdd
198 (-.) x y = op2 x y BCSub
199 (*.) x y = op2 x y BCMul
200 (/.) x y = op2 x y BCDiv
202 instance boolExpr ByteCode where
203 (&.) x y = op2 x y BCAnd
204 (|.) x y = op2 x y BCOr
206 (==.) x y = op2 x y BCEq
207 (!=.) x y = op2 x y BCNeq
208 (<.) x y = op2 x y BCLes
209 (>.) x y = op2 x y BCGre
210 (<=.) x y = op2 x y BCLeq
211 (>=.) x y = op2 x y BCGeq
213 instance analogIO ByteCode where
214 analogRead p = tell` [BCAnalogRead $ pin p]
215 analogWrite p b = op b (BCAnalogWrite $ pin p)
217 instance digitalIO ByteCode where
218 digitalRead p = tell` [BCDigitalRead $ pin p]
219 digitalWrite p b = op b (BCDigitalWrite $ pin p)
221 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
222 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
223 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
224 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
225 instance IF ByteCode where
226 IF b t e = BCIfStmt b t e
227 (?) b t = BCIfStmt b t $ tell` mempty
228 BCIfStmt (BC b) (BC t) (BC e) = BC $
229 freshl >>= \else->freshl >>= \endif->
230 b >>| tell [BCJmpF else] >>|
231 t >>| tell [BCJmp endif, BCLab else] >>|
232 e >>| tell [BCLab endif]
234 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
235 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
237 instance noOp ByteCode where noOp = tell` [BCNop]
241 instance sds ByteCode where
242 sds f = {main = BC $ freshs
243 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
244 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
245 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
247 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
250 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
251 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
253 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
255 instance assign ByteCode where
256 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
258 //This is going to include pins as well, as variables
259 makeStore [BCSdsFetch i] = [BCSdsStore i]
261 instance seq ByteCode where
262 (>>=.) _ _ = abort "undef on >>=."
263 (:.) (BC x) (BC y) = BC $ x >>| y
265 instance serial ByteCode where
266 serialAvailable = tell` [BCSerialAvail]
267 serialPrint s = tell` [BCSerialPrint]
268 serialPrintln s = tell` [BCSerialPrintln]
269 serialRead = tell` [BCSerialRead]
270 serialParseInt = tell` [BCSerialParseInt]
272 instance userLed ByteCode where
273 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
274 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
276 instance zero BCState where
277 zero = {freshl=[1..], freshs=[1..], sdss=[]}
279 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
281 # (s, bc) = runBC x s
282 # (bc, gtmap) = computeGotos bc 1
283 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
285 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
286 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
287 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
290 bclength :: BC -> Int
291 bclength (BCPush s) = 1 + size (toByteCode s)
292 bclength (BCSdsStore _) = 3
293 bclength (BCSdsFetch _) = 3
294 bclength (BCSdsPublish _) = 3
295 bclength x = 1 + consNum{|*|} x
297 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
298 computeGotos [] _ = ([], 'DM'.newMap)
299 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
300 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
302 readable :: BC -> String
303 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
305 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
306 readable b = printToString b
308 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
309 runBC (BC x) = execRWS x ()
311 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
312 toReadableByteCode x s
313 # (s, bc) = runBC x s
314 # (bc, gtmap) = computeGotos bc 0
315 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
317 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
318 lineNumbers ls [] = []
319 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
321 (ex, newls) = splitAt (bclength b - 1) ls
323 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
324 toMessages interval (bytes, st=:{sdss}) = (
325 [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
326 [MTTask interval bytes], st)
328 toSDSUpdate :: Int Int -> [MTaskMSGSend]
329 toSDSUpdate i v = [MTUpd i (to16bit v)]
331 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
332 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
333 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
334 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
337 // bc = {main = ledOn (lit LED1)}
340 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
342 to16bit :: Int -> String
343 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
345 from16bit :: String -> Int
346 from16bit s = toInt s.[0] * 256 + toInt s.[1]
348 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode