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(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
38 encode :: MTaskMSGSend -> String
39 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
43 OnInterval i = to16bit i
44 OnInterrupt _ = abort "Interrupts not implemented yet"
45 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
46 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
47 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
49 decode :: String -> MTaskMSGRecv
51 | size x == 0 = MTEmpty
53 't' = MTTaskAck (from16bit (x % (1,3)))
54 'd' = MTTaskDelAck (from16bit (x % (1,3)))
56 's' = MTSDSAck (from16bit (x % (1,3)))
57 'a' = MTSDSDelAck (from16bit (x % (1,3)))
58 'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
61 _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
63 safePrint :== toString o toJSON
65 instance toString MTaskInterval where
66 toString OneShot = "One shot"
67 toString (OnInterrupt i) = "Interrupt: " +++ toString i
68 toString (OnInterval i) = "Every " +++ toString i +++ "ms"
70 instance toString MTaskMSGSend where
71 toString (MTSds i v) = "Sds id: " +++ toString i
72 +++ " value " +++ safePrint v
73 toString (MTTask to data) = "Task timeout: " +++ toString to
74 +++ " data " +++ safePrint data
75 toString (MTTaskDel i) = "Task delete request: " +++ toString i
76 toString (MTUpd i v) = "Update id: " +++ toString i
77 +++ " value " +++ safePrint v
79 instance toString MTaskMSGRecv where
80 toString (MTTaskAck i) = "Task added with id: " +++ toString i
81 toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
82 toString (MTSDSAck i) = "SDS added with id: " +++ toString i
83 toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
84 toString (MTPub i v) = "Publish id: " +++ toString i
85 +++ " value " +++ safePrint v
86 toString (MTMessage m) = m
87 toString MTEmpty = "Empty message"
89 toByteVal :: BC -> String
90 toByteVal b = {toChar $ consIndex{|*|} b} +++
93 (BCLab i) = {toChar i}
94 (BCSdsStore i) = to16bit i
95 (BCSdsFetch i) = to16bit i
96 (BCSdsPublish i) = to16bit i
97 (BCAnalogRead i) = {toChar i}
98 (BCAnalogWrite i) = {toChar i}
99 (BCDigitalRead i) = {toChar i}
100 (BCDigitalWrite i) = {toChar i}
101 (BCJmp i) = {toChar i}
102 (BCJmpT i) = {toChar i}
103 (BCJmpF i) = {toChar i}
106 //(>>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode b q
107 //(>>) m n = BC \s->(let (_, s1) = runBC m s in
108 // let (a, s2) = runBC n s1
109 // in (a, {s2 & bytecode=(s2.BCState.bytecode ++ s1.BCState.bytecode)}))
112 //(<+->) m n :== m >> tell n
116 //tell :: [BC] -> ByteCode a p | mTaskType a
117 //tell b = BC \s->(zero, {s & bytecode=b++s.bytecode})
119 //fmp :: (a -> BC) (ByteCode a p) -> ByteCode a q
120 //fmp f b = BC \s->let (a, s`) = runBC b s in (a, {s` & code=[f a:s`.code]})
122 instance toByteCode Bool where toByteCode b = if b "\x01" "\x00"
123 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
124 instance toByteCode Long where toByteCode (L n) = toByteCode n
125 instance toByteCode Char where toByteCode s = toString s
126 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
127 instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s}
128 instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s}
129 instance toByteCode MTaskInterval where
130 toByteCode OneShot = toByteCode 0
131 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
132 toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
133 //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
134 toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
136 instance fromByteCode Bool where fromByteCode s = s == "\x01"
137 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
138 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
139 instance fromByteCode Char where fromByteCode s = toChar s.[0]
140 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
141 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[0]
142 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[0]
143 instance fromByteCode MTaskInterval
147 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
150 = OnInterrupt $ fromByteCode s bitand 127
152 instance toChar Pin where
153 toChar (Digital p) = toChar $ consIndex{|*|} p
154 toChar (Analog p) = toChar $ consIndex{|*|} p
157 derive class gCons BC
159 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
160 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
162 op :: (ByteCode a p) BC -> ByteCode a Expr
163 op (BC x) bc = BC $ x >>| tell [bc]
165 tell` x = BC $ tell x
167 instance zero Bool where zero = False
169 instance arith ByteCode where
170 lit x = tell` [BCPush $ toByteCode x]
171 (+.) x y = op2 x y BCAdd
172 (-.) x y = op2 x y BCSub
173 (*.) x y = op2 x y BCMul
174 (/.) x y = op2 x y BCDiv
176 instance boolExpr ByteCode where
177 (&.) x y = op2 x y BCAnd
178 (|.) x y = op2 x y BCOr
180 (==.) x y = op2 x y BCEq
181 (!=.) x y = op2 x y BCNeq
182 (<.) x y = op2 x y BCLes
183 (>.) x y = op2 x y BCGre
184 (<=.) x y = op2 x y BCLeq
185 (>=.) x y = op2 x y BCGeq
187 instance analogIO ByteCode where
188 analogRead p = tell` [BCAnalogRead $ pin p]
189 analogWrite p b = op b (BCAnalogWrite $ pin p)
191 instance digitalIO ByteCode where
192 digitalRead p = tell` [BCDigitalRead $ pin p]
193 digitalWrite p b = op b (BCDigitalWrite $ pin p)
195 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
196 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
197 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
198 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
199 instance IF ByteCode where
200 IF b t e = BCIfStmt b t e
201 (?) b t = BCIfStmt b t $ tell` mempty
202 BCIfStmt (BC b) (BC t) (BC e) = BC $
203 freshl >>= \else->freshl >>= \endif->
204 b >>| tell [BCJmpF else] >>|
205 t >>| tell [BCJmp endif, BCLab else] >>|
206 e >>| tell [BCLab endif]
208 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
209 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
211 instance noOp ByteCode where noOp = tell` [BCNop]
215 instance sds ByteCode where
216 sds f = {main = BC $ freshs
217 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
218 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
219 // >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
221 addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(dynamic v),sdsbc=toByteCode v}:s.sdss]}
224 pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
225 (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
227 publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
229 instance assign ByteCode where
230 (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
232 //This is going to include pins as well, as variables
233 makeStore [BCSdsFetch i] = [BCSdsStore i]
235 instance seq ByteCode where
236 (>>=.) _ _ = abort "undef on >>=."
237 (:.) (BC x) (BC y) = BC $ x >>| y
239 instance serial ByteCode where
240 serialAvailable = tell` [BCSerialAvail]
241 serialPrint s = tell` [BCSerialPrint]
242 serialPrintln s = tell` [BCSerialPrintln]
243 serialRead = tell` [BCSerialRead]
244 serialParseInt = tell` [BCSerialParseInt]
246 instance userLed ByteCode where
247 ledOn (BC l) = BC $ l >>| tell [BCLedOn]
248 ledOff (BC l) = BC $ l >>| tell [BCLedOff]
250 func :: (a -> BC) [BC] -> [BC] | mTaskType a
251 func f b = abort ('Text'.join "\n" (map printToString b))
253 instance zero BCState where
254 zero = {freshl=[1..], freshs=[1..], sdss=[]}
256 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
258 # (s, bc) = runBC x s
259 # (bc, gtmap) = computeGotos bc 1
260 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
262 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
263 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
264 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
267 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
268 computeGotos [] _ = ([], 'DM'.newMap)
269 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
270 computeGotos [x:xs] i = appFst (\bc->[x:bc])
271 (computeGotos xs $ i + 1 + consNum{|*|} x)
273 readable :: BC -> String
274 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
276 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
277 readable b = printToString b
279 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
280 runBC (BC x) = execRWS x ()
282 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
283 toReadableByteCode x s
284 # (s, bc) = runBC x s
285 # (bc, gtmap) = computeGotos bc 0
286 = ('Text'.join "\n" $ map readable (map (implGotos gtmap) bc), s)
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 = let (bcs, st) = toReadableByteCode (unMain bc) zero
300 // bc = {main = ledOn (lit LED1)}
303 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
305 to16bit :: Int -> String
306 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
308 from16bit :: String -> Int
309 from16bit s = toInt s.[0] * 256 + toInt s.[1]