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(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} +++
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 Bool where toByteCode b = toByteCode $ if b 1 0
109 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
110 instance toByteCode Long where toByteCode (L n) = toByteCode n
111 instance toByteCode Char where toByteCode c = toByteCode $ toInt c
112 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
113 instance toByteCode Button where toByteCode s = toByteCode $ consIndex{|*|} s
114 instance toByteCode UserLED where toByteCode s = toByteCode $ consIndex{|*|} s
115 instance toByteCode MTaskInterval where
116 toByteCode OneShot = toByteCode 0
117 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
118 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
119 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
120 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
122 instance fromByteCode Bool where fromByteCode s = fromByteCode s == 1
123 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
124 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
125 instance fromByteCode Char where fromByteCode s = fromInt $ fromByteCode s
126 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
127 instance fromByteCode Button where fromByteCode s = conses{|*|} !! fromByteCode s
128 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! fromByteCode s
129 instance fromByteCode MTaskInterval
133 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
136 = OnInterrupt $ fromByteCode s bitand 127
138 instance toChar Pin where
139 toChar (Digital p) = toChar $ consIndex{|*|} p
140 toChar (Analog p) = toChar $ consIndex{|*|} p
143 derive class gCons BC
145 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
146 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
148 op :: (ByteCode a p) BC -> ByteCode a Expr
149 op (BC x) bc = BC $ x >>| tell [bc]
151 tell` x = BC $ tell x
153 instance zero Bool where zero = False
155 instance arith ByteCode where
156 lit x = tell` [BCPush $ toByteCode x]
157 (+.) x y = op2 x y BCAdd
158 (-.) x y = op2 x y BCSub
159 (*.) x y = op2 x y BCMul
160 (/.) x y = op2 x y BCDiv
162 instance boolExpr ByteCode where
163 (&.) x y = op2 x y BCAnd
164 (|.) x y = op2 x y BCOr
166 (==.) x y = op2 x y BCEq
167 (!=.) x y = op2 x y BCNeq
168 (<.) x y = op2 x y BCLes
169 (>.) x y = op2 x y BCGre
170 (<=.) x y = op2 x y BCLeq
171 (>=.) x y = op2 x y BCGeq
173 instance analogIO ByteCode where
174 analogRead p = tell` [BCAnalogRead $ pin p]
175 analogWrite p b = op b (BCAnalogWrite $ pin p)
177 instance digitalIO ByteCode where
178 digitalRead p = tell` [BCDigitalRead $ pin p]
179 digitalWrite p b = op b (BCDigitalWrite $ pin p)
181 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
182 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
183 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
184 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
185 instance IF ByteCode where
186 IF b t e = BCIfStmt b t e
187 (?) b t = BCIfStmt b t $ tell` mempty
188 BCIfStmt (BC b) (BC t) (BC e) = BC $
189 freshl >>= \else->freshl >>= \endif->
190 b >>| tell [BCJmpF else] >>|
191 t >>| tell [BCJmp endif, BCLab else] >>|
192 e >>| tell [BCLab endif]
194 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
195 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
197 instance noOp ByteCode where noOp = tell` [BCNop]
201 instance sds ByteCode where
202 sds f = {main = BC $ freshs
203 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
204 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
205 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
207 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(dynamic v),sdsbc=toByteCode v}:s.sdss]}
210 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
211 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
213 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
215 instance assign ByteCode where
216 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
218 //This is going to include pins as well, as variables
219 makeStore [BCSdsFetch i] = [BCSdsStore i]
221 instance seq ByteCode where
222 (>>=.) _ _ = abort "undef on >>=."
223 (:.) (BC x) (BC y) = BC $ x >>| y
225 instance serial ByteCode where
226 serialAvailable = tell` [BCSerialAvail]
227 serialPrint s = tell` [BCSerialPrint]
228 serialPrintln s = tell` [BCSerialPrintln]
229 serialRead = tell` [BCSerialRead]
230 serialParseInt = tell` [BCSerialParseInt]
232 instance userLed ByteCode where
233 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
234 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
236 func :: (a -> BC) [BC] -> [BC] | mTaskType a
237 func f b = abort ('Text'.join "\n" (map printToString b))
239 instance zero BCState where
240 zero = {freshl=[1..], freshs=[1..], sdss=[]}
242 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
244 # (s, bc) = runBC x s
245 # (bc, gtmap) = computeGotos bc 1
246 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
248 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
249 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
250 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
254 bclength :: BC -> Int
255 bclength (BCPush s) = 1 + size s
256 bclength (BCSdsStore _) = 3
257 bclength (BCSdsFetch _) = 3
258 bclength (BCSdsPublish _) = 3
259 bclength x = 1 + consNum{|*|} x
261 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
262 computeGotos [] _ = ([], 'DM'.newMap)
263 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
264 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
266 readable :: BC -> String
267 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
269 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
270 readable b = printToString b
272 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
273 runBC (BC x) = execRWS x ()
275 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
276 toReadableByteCode x s
277 # (s, bc) = runBC x s
278 | not (trace_tn $ ('Text'.join "\n" $ lineNumbers numbers bc) +++ "\n") = undef
279 # (bc, gtmap) = computeGotos bc 0
280 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
282 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
283 lineNumbers ls [] = []
284 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
286 (ex, newls) = splitAt (bclength b - 1) ls
288 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
289 toMessages interval (bytes, st=:{sdss}) = (
290 [MTSds s.sdsi s.sdsbc\\s<-sdss] ++
291 [MTTask interval bytes], st)
293 toSDSUpdate :: Int Int -> [MTaskMSGSend]
294 toSDSUpdate i v = [MTUpd i (to16bit v)]
296 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
297 Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
298 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
301 // bc = {main = ledOn (lit LED1)}
304 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
306 to16bit :: Int -> String
307 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
309 from16bit :: String -> Int
310 from16bit s = toInt s.[0] * 256 + toInt s.[1]