add clean-platform
[mTask.git] / mTaskInterpret.icl
1 implementation module mTaskInterpret
2
3 //import iTasks
4 import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
5 import GenPrint
6 import StdEnum
7 import mTask
8
9 import StdFile
10 import StdString
11
12 from StdFunc import o, const
13 import StdBool
14 import StdTuple
15 import Data.Tuple
16 import Data.Monoid
17 import Data.Functor
18 import StdList
19 from Data.Func import $
20 from Text import class Text(concat,join,toUpperCase), instance Text String
21
22 import qualified Data.Map as DM
23 import Text.Encodings.Base64
24
25 encode :: MTaskMSGSend -> String
26 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
27 encode (MTTask to data) = "t" +++ to16bit to +++ to16bit (size data) +++ data +++ "\n"
28 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
29
30
31 decode :: String -> MTaskMSGRecv
32 decode x
33 | size x == 0 = MTEmpty
34 = case x.[0] of
35 '\0' = MTEmpty
36 'u' = MTPub (from16bit (x % (1,3))) (x % (3,5))
37 _ = abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
38
39 safePrint :== toString o toJSON
40
41 instance toString MTaskMSGSend where
42 toString (MTSds i v) = "Sds id: " +++ toString i
43 +++ " value " +++ safePrint v
44 toString (MTTask to data) = "Task timeout: " +++ toString to
45 +++ " data " +++ safePrint data
46 toString (MTUpd i v) = "Update id: " +++ toString i
47 +++ " value " +++ safePrint v
48
49 instance toString MTaskMSGRecv where
50 toString (MTPub i v) = "Publish id: " +++ toString i
51 +++ " value " +++ safePrint v
52 toString MTEmpty = "Empty message"
53
54 bclength :: BC -> Int
55 bclength (BCPush _) = 3
56 bclength (BCLab _) = 2
57 bclength (BCSdsStore _) = 2
58 bclength (BCSdsFetch _) = 2
59 bclength (BCSdsPublish _) = 2
60 bclength (BCAnalogRead _) = 2
61 bclength (BCAnalogWrite _) = 2
62 bclength (BCDigitalRead _) = 2
63 bclength (BCDigitalWrite _) = 2
64 bclength (BCJmp i) = 2
65 bclength (BCJmpT i) = 2
66 bclength (BCJmpF i) = 2
67 bclength _ = 1
68
69 toByteVal :: BC -> [Char]
70 toByteVal b
71 # bt = toChar $ consIndex{|*|} b + 1
72 = [bt:case b of
73 (BCPush i) = i
74 (BCLab i) = [toChar i]
75 (BCSdsStore i) = [toChar i]
76 (BCSdsFetch i) = [toChar i]
77 (BCSdsPublish i) = [toChar i]
78 (BCAnalogRead i) = [toChar i]
79 (BCAnalogWrite i) = [toChar i]
80 (BCDigitalRead i) = [toChar i]
81 (BCDigitalWrite i) = [toChar i]
82 (BCJmp i) = [toChar i]
83 (BCJmpT i) = [toChar i]
84 (BCJmpF i) = [toChar i]
85 _ = []]
86
87 instance Semigroup (ByteCode a p) where
88 mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
89
90 instance Monoid (ByteCode a p) where
91 mempty = retrn []
92
93 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
94 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
95
96 (<+->) infixr 1
97 (<+->) m n :== m <++> retrn n
98
99 runBC (BC m) = m
100
101 retrn :: ([BC] -> ByteCode a p)
102 retrn = BC o tuple
103 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a q
104 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
105
106 instance toByteCode Bool where
107 toByteCode True = [toChar 1]
108 toByteCode False = [toChar 0]
109 instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256]
110 instance toByteCode Long where toByteCode (L n) = toByteCode n
111 instance toByteCode Char where toByteCode c = [c]
112 instance toByteCode String where toByteCode s = undef
113 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
114
115 instance toChar Pin where
116 toChar (Digital p) = toChar $ consIndex{|*|} p + 1
117 toChar (Analog p) = toChar $ consIndex{|*|} p + 1
118
119 derive gPrint BC, AnalogPin, Pin, DigitalPin
120 derive consIndex BC, Pin, Button
121 derive consName BC, Pin, Button
122
123 instance arith ByteCode where
124 lit x = retrn [BCPush $ toByteCode x]
125 (+.) x y = x <++> y <+-> [BCAdd]
126 (-.) x y = x <++> y <+-> [BCSub]
127 (*.) x y = x <++> y <+-> [BCMul]
128 (/.) x y = x <++> y <+-> [BCDiv]
129
130 instance boolExpr ByteCode where
131 (&.) x y = x <++> y <+-> [BCAnd]
132 (|.) x y = x <++> y <+-> [BCOr]
133 Not x = x <+-> [BCNot]
134 (==.) x y = x <++> y <+-> [BCEq]
135 (!=.) x y = x <++> y <+-> [BCNeq]
136 (<.) x y = x <++> y <+-> [ BCLes]
137 (>.) x y = x <++> y <+-> [BCGre]
138 (<=.) x y = x <++> y <+-> [BCLeq]
139 (>=.) x y = x <++> y <+-> [BCGeq]
140
141 instance analogIO ByteCode where
142 analogRead p = retrn [BCAnalogRead $ pin p]
143 analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
144
145 instance digitalIO ByteCode where
146 digitalRead p = retrn [BCDigitalRead $ pin p]
147 digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
148
149 //instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
150 //instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
151 //instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
152 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
153 instance IF ByteCode where
154 IF b t e = BCIfStmt b t e
155 (?) b t = BCIfStmt b t $ retrn []
156 BCIfStmt b t e =
157 withLabel \else->withLabel \endif->
158 b <++> retrn [BCJmpF else] <++> t
159 <++> retrn [BCJmp endif,BCLab else] <++> e <++> retrn [BCLab endif]
160
161 instance noOp ByteCode where noOp = mempty
162
163 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
164 withLabel f = BC \s->let [fresh:fs] = s.freshl
165 in runBC (f fresh) {s & freshl=fs}
166
167 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
168 withSDS f = BC \s->let [fresh:fs] = s.freshs
169 in runBC (f fresh) {s & freshs=fs}
170
171 setSDS :: Int v -> ByteCode b q | toByteCode v
172 setSDS ident val = BC \s->([], {s & sdss = [(ident, toByteCode val):s.sdss]})
173
174 instance sds ByteCode where
175 sds f = {main = withSDS \sds->
176 let (v In body) = f $ retrn [BCSdsFetch sds]
177 in setSDS sds v <++> unMain body
178 }
179 con f = undef
180 pub x = fmp makePub x
181 // pub _ = undef
182
183 instance assign ByteCode where
184 (=.) v e = e <++> fmp makeStore v
185
186 makePub [] = []
187 makePub [x:xs] = case x of
188 BCSdsFetch i = [BCSdsPublish i:xs]
189 y = [y:xs]
190
191 makeStore [] = []
192 makeStore [x:xs] = case x of
193 BCSdsFetch i = [BCSdsStore i:xs]
194 y = [y:xs]
195
196 instance seq ByteCode where
197 (>>=.) _ _ = abort "undef on >>=."
198 (:.) x y = x <++> y
199
200 instance serial ByteCode where
201 serialAvailable = retrn [BCSerialAvail]
202 serialPrint s = retrn [BCSerialPrint]
203 serialPrintln s = retrn [BCSerialPrintln]
204 serialRead = retrn [BCSerialRead]
205 serialParseInt = retrn [BCSerialParseInt]
206
207 instance zero BCState where
208 zero = {freshl=[1..], freshs=[1..], sdss=[]}
209
210
211 toRealByteCode :: (ByteCode a b) -> (String, BCState)
212 toRealByteCode x
213 # (bc, st) = runBC x zero
214 # (bc, gtmap) = computeGotos bc 1
215 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st)
216
217 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
218 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
219 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
220 implGotos _ i = i
221
222 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
223 computeGotos [] _ = ([], 'DM'.newMap)
224 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
225 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs (i+(bclength x)))
226
227 readable :: BC -> String
228 readable (BCPush d) = "BCPush " +++ concat (map safe d)
229 where
230 safe c
231 | isControl c = "\\d" +++ toString (toInt c)
232 = toString c
233 readable b = printToString b
234
235 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
236 toReadableByteCode x
237 # (bc, st) = runBC x zero
238 # (bc, gtmap) = computeGotos bc 0
239 = (join "\n" $ map readable (map (implGotos gtmap) bc), st)
240
241 //Start :: String
242 //Start = toReadableByteCode bc
243 // where
244 // bc :: ByteCode Int Expr
245 // bc = (lit 36 +. lit 42) +. lit 44
246 toMessages :: Int (String, BCState) -> ([MTaskMSGSend], BCState)
247 toMessages interval (bytes, st=:{sdss}) = ([MTSds i (toString b)\\(i,b)<-sdss] ++ [MTTask interval bytes], st)
248
249 toSDSUpdate :: Int Int -> [MTaskMSGSend]
250 toSDSUpdate i v = [MTUpd i (to16bit v)]
251
252 Start = toMessages 500 $ toRealByteCode (unMain bc)
253 //Start = fst $ toReadableByteCode $ unMain bc
254 where
255 bc = sds \x=5 In
256 sds \y=4 In
257 {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
258
259 //pub :: (ByteCode a b) -> ByteCode a b
260 //pub x = fmp makePub x
261
262 to16bit :: Int -> String
263 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
264
265 from16bit :: String -> Int
266 from16bit s = toInt s.[0] * 256 + toInt s.[1]