1 implementation module mTaskInterpret
5 import GenEq, StdMisc, StdArray, GenBimap
14 from StdFunc import o, const
21 from Data.Func import $
22 from Text import class Text(subString,lpad,concat,toUpperCase), instance Text String
26 import Control.Monad.RWST
27 import Control.Monad.Identity
29 import Control.Applicative
34 import qualified Data.Map as DM
35 import qualified Data.List as DL
36 import Text.Encodings.Base64
40 encode :: MTaskMSGSend -> String
41 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
45 OnInterval i = to16bit i
46 OnInterrupt _ = abort "Interrupts not implemented yet"
47 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
48 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
49 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
51 decode :: String -> MTaskMSGRecv
53 | size x == 0 = MTEmpty
55 't' = MTTaskAck (from16bit (x % (1,3)))
56 'd' = MTTaskDelAck (from16bit (x % (1,3)))
58 's' = MTSDSAck (from16bit (x % (1,3)))
59 'a' = MTSDSDelAck (from16bit (x % (1,3)))
60 'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
63 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
65 safePrint :== toString o toJSON
67 instance toString MTaskInterval where
68 toString OneShot = "One shot"
69 toString (OnInterrupt i) = "Interrupt: " +++ toString i
70 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
72 instance toString MTaskMSGSend where
73 toString (MTSds i v) = "Sds id: " +++ toString i
74 +++ " value " +++ safePrint v
75 toString (MTTask to data) = "Task timeout: " +++ toString to
76 +++ " data " +++ safePrint data
77 toString (MTTaskDel i) = "Task delete request: " +++ toString i
78 toString (MTUpd i v) = "Update id: " +++ toString i
79 +++ " value " +++ safePrint v
81 instance toString MTaskMSGRecv where
82 toString (MTTaskAck i) = "Task added with id: " +++ toString i
83 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
84 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
85 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
86 toString (MTPub i v) = "Publish id: " +++ toString i
87 +++ " value " +++ safePrint v
88 toString (MTMessage m) = m
89 toString MTEmpty = "Empty message"
91 toByteVal :: BC -> String
92 toByteVal b = {toChar $ consIndex{|*|} b} +++
94 (BCPush i) = toByteCode i
95 (BCLab i) = {toChar i}
96 (BCSdsStore i) = to16bit i
97 (BCSdsFetch i) = to16bit i
98 (BCSdsPublish i) = to16bit i
99 (BCAnalogRead i) = {toChar i}
100 (BCAnalogWrite i) = {toChar i}
101 (BCDigitalRead i) = {toChar i}
102 (BCDigitalWrite i) = {toChar i}
103 (BCJmp i) = {toChar i}
104 (BCJmpT i) = {toChar i}
105 (BCJmpF i) = {toChar i}
108 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
109 instance toByteCode Bool where toByteCode b = toByteCode $ if b 1 0
110 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
111 instance toByteCode Long where toByteCode (L n) = toByteCode n
112 instance toByteCode Char where toByteCode c = toByteCode $ toInt c
113 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
114 instance toByteCode Button where toByteCode s = toByteCode $ consIndex{|*|} s
115 instance toByteCode UserLED where toByteCode s = toByteCode $ consIndex{|*|} s
116 instance toByteCode MTaskInterval where
117 toByteCode OneShot = toByteCode 0
118 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
119 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
120 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
121 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
123 //parseByteCode :: String -> BCValue
124 //parseByteCode "b" = BCValue True
125 //parseByteCode "i" = BCValue 0
127 instance fromByteCode Bool where fromByteCode s = fromByteCode s == 1
128 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
129 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
130 instance fromByteCode Char where fromByteCode s = fromInt $ fromByteCode s
131 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
132 instance fromByteCode Button where fromByteCode s = conses{|*|} !! fromByteCode s
133 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! fromByteCode s
134 instance fromByteCode BCValue
136 fromByteCode s = let tail = subString 1 (size s) s in case s.[0] of
137 'b' = BCValue $ castfbc True tail
138 'i' = BCValue $ castfbc 0 tail
139 'l' = BCValue $ castfbc (L 0) tail
140 'c' = BCValue $ castfbc ('0') tail
141 'B' = BCValue $ castfbc (NoButton) tail
142 'L' = BCValue $ castfbc (LED1) tail
144 castfbc :: a -> (String -> a) | mTaskType a
145 castfbc _ = fromByteCode
147 instance fromByteCode MTaskInterval
151 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
154 = OnInterrupt $ fromByteCode s bitand 127
156 instance toChar Pin where
157 toChar (Digital p) = toChar $ consIndex{|*|} p
158 toChar (Analog p) = toChar $ consIndex{|*|} p
160 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC
161 derive class gCons BC
163 consIndex{|BCValue|} _ = 0
164 consName{|BCValue|} _ = "BCValue"
165 conses{|BCValue|} = [BCValue 0]
166 consNum{|BCValue|} _ = 1
167 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
169 gEditor{|BCValue|} = undef
170 gText{|BCValue|} fm Nothing = []
171 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
172 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
173 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
175 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
176 JSS = JSONDecode{|*|}
177 gDefault{|BCValue|} = BCValue 0
178 gEq{|BCValue|} (BCValue e) (BCValue f) = False
180 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
181 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
183 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
184 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
186 op :: (ByteCode a p) BC -> ByteCode a Expr
187 op (BC x) bc = BC $ x >>| tell [bc]
189 tell` x = BC $ tell x
191 instance arith ByteCode where
192 lit x = tell` [BCPush $ BCValue x]
193 (+.) x y = op2 x y BCAdd
194 (-.) x y = op2 x y BCSub
195 (*.) x y = op2 x y BCMul
196 (/.) x y = op2 x y BCDiv
198 instance boolExpr ByteCode where
199 (&.) x y = op2 x y BCAnd
200 (|.) x y = op2 x y BCOr
202 (==.) x y = op2 x y BCEq
203 (!=.) x y = op2 x y BCNeq
204 (<.) x y = op2 x y BCLes
205 (>.) x y = op2 x y BCGre
206 (<=.) x y = op2 x y BCLeq
207 (>=.) x y = op2 x y BCGeq
209 instance analogIO ByteCode where
210 analogRead p = tell` [BCAnalogRead $ pin p]
211 analogWrite p b = op b (BCAnalogWrite $ pin p)
213 instance digitalIO ByteCode where
214 digitalRead p = tell` [BCDigitalRead $ pin p]
215 digitalWrite p b = op b (BCDigitalWrite $ pin p)
217 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
218 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
219 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
220 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
221 instance IF ByteCode where
222 IF b t e = BCIfStmt b t e
223 (?) b t = BCIfStmt b t $ tell` mempty
224 BCIfStmt (BC b) (BC t) (BC e) = BC $
225 freshl >>= \else->freshl >>= \endif->
226 b >>| tell [BCJmpF else] >>|
227 t >>| tell [BCJmp endif, BCLab else] >>|
228 e >>| tell [BCLab endif]
230 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
231 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
233 instance noOp ByteCode where noOp = tell` [BCNop]
237 instance sds ByteCode where
238 sds f = {main = BC $ freshs
239 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
240 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
241 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
243 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(dynamic v),sdsbc=toByteCode v}:s.sdss]}
246 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
247 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
249 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
251 instance assign ByteCode where
252 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
254 //This is going to include pins as well, as variables
255 makeStore [BCSdsFetch i] = [BCSdsStore i]
257 instance seq ByteCode where
258 (>>=.) _ _ = abort "undef on >>=."
259 (:.) (BC x) (BC y) = BC $ x >>| y
261 instance serial ByteCode where
262 serialAvailable = tell` [BCSerialAvail]
263 serialPrint s = tell` [BCSerialPrint]
264 serialPrintln s = tell` [BCSerialPrintln]
265 serialRead = tell` [BCSerialRead]
266 serialParseInt = tell` [BCSerialParseInt]
268 instance userLed ByteCode where
269 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
270 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
272 func :: (a -> BC) [BC] -> [BC] | mTaskType a
273 func f b = abort ('Text'.join "\n" (map printToString b))
275 instance zero BCState where
276 zero = {freshl=[1..], freshs=[1..], sdss=[]}
278 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
280 # (s, bc) = runBC x s
281 # (bc, gtmap) = computeGotos bc 1
282 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
284 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
285 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
286 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 | not (trace_tn $ ('Text'.join "\n" $ lineNumbers numbers bc) +++ "\n") = undef
315 # (bc, gtmap) = computeGotos bc 0
316 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
318 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
319 lineNumbers ls [] = []
320 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
322 (ex, newls) = splitAt (bclength b - 1) ls
324 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
325 toMessages interval (bytes, st=:{sdss}) = (
326 [MTSds s.sdsi s.sdsbc\\s<-sdss] ++
327 [MTTask interval bytes], st)
329 toSDSUpdate :: Int Int -> [MTaskMSGSend]
330 toSDSUpdate i v = [MTUpd i (to16bit v)]
332 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) 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