1 implementation module mTaskCode
3 import Generics.gdynamic
8 import GenEq, StdMisc, StdArray
11 instance toCode MTask where toCode (MTask x) = "Task " + toCode x
13 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
16 instance argTypes (Code a p) | showType a where argTypes f = showType
17 instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
18 instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
20 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
23 var2Type :: (Code t p) -> Code t p | showType t
26 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
27 resType2 f = showType2
29 instance toCode (SV t) where toCode (SV s) = s
31 instance arith Code where
33 (+.) x y = codeOp2 x " + " y
34 (-.) x y = codeOp2 x " - " y
35 (*.) x y = codeOp2 x " * " y
36 (/.) x y = codeOp2 x " / " y
37 instance boolExpr Code where
38 (&.) x y = codeOp2 x " && " y
39 (|.) x y = codeOp2 x " || " y
40 Not x = embed (brac (c "! " +.+ brac x))
41 (==.) x y = codeOp2 x " == " y
42 (!=.) x y = codeOp2 x " != " y
43 (<.) x y = codeOp2 x " < " y
44 (<=.) x y = codeOp2 x " <= " y
45 (>.) x y = codeOp2 x " > " y
46 (>=.) x y = codeOp2 x " >= " y
47 instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
48 instance If Code e Stmt Stmt where If c t e = IfStmt c t e
49 instance If Code Stmt e Stmt where If c t e = IfStmt c t e
50 instance If Code x y Expr where If c t e = IfExpr c t e
51 IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
60 _ = if (v == "") NoReturn (Assign v)
63 c "if " +.+ brac b +.+ c " {" +.+
64 indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
65 indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
66 instance IF Code where
67 IF b t e = IfStmt b t e
70 c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
71 indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
73 instance sds Code where
76 let name = "sds"+toCode n
77 (v In body) = f (C (var name))
78 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
79 ";\n") +.+ setCode Setup +.+ unMain body}
83 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
86 let name = "sds"+toCode n
87 (v In body) = f (C (var name))
88 in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
89 ";\n") +.+ setCode Setup +.+ unMain body}
91 var :: String (ReadWrite (Code v q)) CODE -> CODE
92 var sds Rd s = unC (embed (c sds)) Rd s
93 var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
95 instance assign Code where
96 (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
97 instance seq Code where
99 getMode \mode. fresh \n. let v = "b" + toCode n in
100 addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
101 setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
102 (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
103 instance step` Code where
105 getMode \mode. fresh \n.
106 let v = "s" + toCode n in
107 c "while(true) {" +.+ indent +.+ nl +.+
108 var2Type x +.+ c (v + ";") +.+ nl +.+
109 setMode (Assign v) +.+ x +.+ nl +.+
110 setMode mode +.+ codeSteps (f (c v)) +.+
111 unindent +.+ nl +.+ c "}"
112 codeSteps :: [Step Code t] -> Code u p
113 codeSteps [] = C \rw c.c
114 codeSteps [Cond b e:x] =
115 getMode \mode. setMode SubExp +.+
116 c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
117 setMode mode +.+ e +.+
118 optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
119 codeSteps [Ever e:x] =
120 getMode \mode. e +.+ optBreak mode
122 optBreak :: Mode -> Code u p
126 _ = nl +.+ c "break;"
128 instance setDelay Code where
129 setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
130 instance mtask Code a | taskImp2 a & types a where
132 {main = freshMTask \n.
133 let (app, a) = taskImp2 n types
134 (b In main) = f (\d a.app (long d) a)
135 in codeMTaskBody (loopCode n (b a)) (unMain main)}
136 instance mtasks Code a b | taskImp2 a & types a & taskImp2 b & types b where
141 let (app1, a1) = taskImp2 t1 types
142 (app2, a2) = taskImp2 t2 types
143 ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
144 in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
146 loopCode :: Int (Code a b) -> Code c d
148 nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
149 setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
150 unindent +.+ nl +.+ c "} "
152 instance taskImp2 () where
153 taskImp2 n () = (app, ())
154 where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
155 instance taskImp2 (Code t p) where
156 taskImp2 n type1 = (app, ta)
161 setBinds [n0] +.+ embed (c "newTask(" +.+
165 instance taskImp2 (Code a p, Code b q) where
166 taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
172 setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
173 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
174 instance taskImp2 (Code a p, Code b q, Code c r) where
175 taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
184 setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
190 instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
191 taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
201 app d (a1, a2, a3, a4) =
202 setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
210 class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
211 instance taskImp () where
212 taskImp n () = (app, ())
213 where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
214 instance taskImp (Code t p) where
215 taskImp n type1 = (app, ta)
217 ta = c "t0p->a[0]" +.+ type1
219 embed (c "newTask(" +.+
223 instance taskImp (Code a p, Code b q) where
224 taskImp n (type1, type2) = (app, (ta1, ta2)) where
225 ta1 = c "t0p->a[0]" +.+ type1
226 ta2 = c "t0p->a[1]" +.+ type2
228 embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+
229 c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
230 instance taskImp (Code a p, Code b q, Code c r) where
231 taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
233 ta1 = c "t0p->a[0]" +.+ type1
234 ta2 = c "t0p->a[1]" +.+ type2
235 ta3 = c "t0p->a[2]" +.+ type3
237 embed (c "newTask(" +.+
243 instance taskImp (Code a p, Code b q, Code c r, Code d s) where
244 taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
246 ta1 = c "t0p->a[0]" +.+ type1
247 ta2 = c "t0p->a[1]" +.+ type2
248 ta3 = c "t0p->a[2]" +.+ type3
249 ta4 = c "t0p->a[3]" +.+ type4
250 app i (a1, a2, a3, a4) =
251 embed (c "newTask(" +.+
259 tasksMain :: Int Int ((a->Code MTask Expr,b->Code MTask Expr) -> In (a->Code c d,b->Code e f) (Main (Code g h))) -> Main (Code i j) | taskImp a & types a & taskImp b & types b
262 freshMTask \n. freshMTask \m.
264 (app1, a1) = taskImp n types
265 (app2, a2) = taskImp m types
266 ((b1, b2) In {main = e}) = f (app1 i, app2 j)
268 codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
271 instance types () where types = ()
272 instance types (Code a p) | typeSelector a & isExpr p
273 where types = typeSelector
274 instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
275 where types = (typeSelector, typeSelector)
276 instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
277 where types = (typeSelector, typeSelector, typeSelector)
278 instance types (Code a p, Code b q, Code c r, Code d s) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r & typeSelector d & isExpr s
279 where types = (typeSelector, typeSelector, typeSelector, typeSelector)
281 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
282 codeMTaskBody loop e =
285 setCode Loop +.+ loop +.+
286 setMode mode +.+ setCode Setup +.+ embed e
287 instance fun Code () where
289 {main = getMode \mode. fresh \n.
290 let fname = c ("f" + toCode n)
291 (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
292 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
293 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
295 instance fun Code (Code t p) | type, showType t & isExpr p where
298 getMode \mode. fresh \n.
299 let fname = c ("f" + toCode n)
300 aname = "a" + toCode n
301 (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
302 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
303 brac (argTypes f +.+ c (" " + aname)) +.+
304 funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
306 instance fun Code (Code a p, Code b q) | showType a & showType b where
309 getMode \mode. fresh \n.
310 let fname = c ("f" + toCode n + " ")
311 aname = "a" + toCode n //+ " "
312 bname = "b" + toCode n //+ " "
313 (atype, btype) = argTypes f
315 = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
316 in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
317 codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
318 funBody (setMode (Return (toCode (resType2 f))) +.+
319 setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
320 setCode Setup +.+ setMode mode +.+ unMain main
322 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
325 getMode \mode. fresh \n.
326 let fname = c ("f" + toCode n)
327 aname = "a" + toCode n
328 bname = "b" + toCode n
329 cname = "c" + toCode n
330 (atype,btype,ctype) = argTypes f
331 (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
332 in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
333 brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
334 funBody (setMode (Return (toCode (resType2 f))) +.+
335 setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
337 instance output Code where
338 output x = embed (c "Serial.println(" +.+ x +.+ c ")")
339 instance pinMode Code where
340 pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
341 instance digitalIO Code where
342 digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
343 digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
344 instance dIO Code where
345 dIO p = C (ioc p) where
346 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
347 ioc p Rd s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
348 ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
349 instance aIO Code where
350 aIO p = C (ioc p) where
351 ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
352 ioc p Rd s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
353 ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
354 instance analogIO Code where
355 analogRead p = embed (c ("analogRead(" + toCode p + ")"))
356 analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
357 instance noOp Code where noOp = C \rw c.c
359 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
360 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
363 :: Def = Var | Fun | Setup | Loop
364 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
366 setMode :: Mode -> Code a p
367 setMode m = C \rw c.{CODE|c & mode` = m}
369 getMode :: (Mode -> Code a p) -> Code a p
370 getMode f = C \rw c.unC (f c.mode`) rw c
372 embed :: (Code a p) -> Code a p
374 getMode \m. case m of
375 NoReturn = setMode SubExp +.+ e +.+ c ";"
376 Return "void" = setMode SubExp +.+ e +.+ c ";"
377 Return t = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
378 Assign s = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
380 _ = abort "\n\nembed: unknown mode.\n"
382 (+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
383 (+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
385 fresh :: (Int -> (Code a p)) -> (Code a p)
386 fresh f = C \rw c.unC (f c.fresh) rw {CODE | c & fresh = c.fresh + 1}
388 freshMTask :: (Int -> (Code a p)) -> (Code a p)
389 freshMTask f = C \rw c.unC (f c.freshMTask) rw {CODE | c & freshMTask = c.freshMTask + 1}
391 setCode :: Def -> (Code a p)
392 setCode d = C \rw c.{c & def = d}
394 getCode :: (Def -> Code a p) -> (Code a p)
395 getCode f = C \rw c.unC (f c.def) rw c
397 brac :: (Code a p) -> Code b q
398 brac e = c "(" +.+ e +.+ c ")"
400 funBody :: (Code a p) -> Code b q
401 funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
403 codeOp2 :: (Code a p) String (Code b q) -> Code c r
404 codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
406 include :: String -> Code a b
407 include lib = C \rw c.{c & includes = [lib:c.includes]}
409 argList :: [a] -> String | toCode a
410 argList [a] = toCode a
411 argList [a:x] = toCode a + "," + argList x
414 c :: a -> Code b p | toCode a
415 c a = C \rw c.case c.def of
416 Fun = {c & funs = [toCode a: c.funs]}
417 Var = {c & vars = [toCode a: c.vars]}
418 Setup = {c & setup = [toCode a: c.setup]}
419 Loop = {c & loop = [toCode a: c.loop]}
423 C \rw c.case c.def of
424 Fun = {c & ifuns = inc c.ifuns}
425 Var = {c & ivars = inc c.ivars}
426 Setup = {c & isetup = inc c.isetup}
427 Loop = {c & iloop = inc c.iloop}
431 C \rw c.case c.def of
432 Fun = {c & ifuns = dec c.ifuns}
433 Var = {c & ivars = dec c.ivars}
434 Setup = {c & isetup = dec c.isetup}
435 Loop = {c & iloop = dec c.iloop}
443 C \rw c.case c.def of
444 Fun = {c & funs = [str c.ifuns: c.funs]}
445 Var = {c & vars = [str c.ivars: c.vars]}
446 Setup = {c & setup = [str c.isetup: c.setup]}
447 Loop = {c & loop = [str c.iloop: c.loop]}
449 str n = toString ['\n':repeatn (tabSize * n) ' ']
451 setBinds :: [String] -> Code a p
452 setBinds list = C \rw c.{c & binds = list}
454 addBinds :: String -> Code a p
455 addBinds name = C \rw c.{c & binds = [name:c.binds]}
457 getBinds :: ([String] -> Code a p) -> (Code a p)
458 getBinds f = C \rw c.unC (f c.binds) rw c
460 // ----- driver ----- //
462 compile :: (Main (Code a p)) -> [String]
463 compile {main=(C f)} =
465 ," Generated code for Arduino\n"
466 ," Pieter Koopman, pieter@cs.ru.nl\n"
469 ,"#define MAX_ARGS 4\n"
470 ,"#define MAX_TASKS 20\n"
471 ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
472 ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
474 ,"typedef union Arg {\n"
478 // ," float f;\n" // requires 4 bytes
482 ,"typedef struct Task {\n"
485 ," ARG a[MAX_ARGS];\n"
489 foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
490 ["\n// --- variables ---\n"
491 ,"TASK tasks[MAX_TASKS];\n"
492 ,"byte t0 = 0, tc = 0, tn = 0;\n"
499 ,"unsigned long time = 0;\n"
502 ["\n// --- functions ---\n"
503 ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
504 ," TASK *tnp = &tasks[tn];\n"
506 ," tnp->wait = wait;\n"
507 ," tnp->a[0].w = a0;\n"
508 ," tnp->a[1].w = a1;\n"
509 ," tnp->a[2].w = a2;\n"
510 ," tnp->a[3].w = a3;\n"
512 ," tn = NEXT_TASK(tn);\n"
516 ,"byte setDelay(byte t, long d) {\n"
517 ," tasks[t].wait = d;\n"
520 ,"boolean pressed(int b) {\n"
521 ," pinMode(A0, INPUT);\n"
522 ," int a0 = analogRead(A0);\n"
524 ," case 0: return a0 < ",toString RightBound,"; // right\n"
525 ," case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
526 ," case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
527 ," case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
528 ," case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
529 ," default: return ",toString SelectBound," < a0; //no button\n"
532 ,"boolean pWrite (int pin, boolean b) {\n"
533 ," pinMode(pin, OUTPUT);\n"
534 ," digitalWrite(pin, b);\n"
537 ,"int pWrite (int pin, int i) {\n"
538 ," pinMode(pin, OUTPUT);\n"
539 ," analogWrite(pin, i);\n"
544 ["\n// --- setup --- \n"
546 ," Serial.begin(9600);\n"
551 ,"\n// --- loop --- \n"
553 ," if (t0 != tn) {\n"
554 ," if (t0 == tc) {\n"
555 ," unsigned long time2 = millis();\n"
556 ," delta = time2 - time;\n"
560 ," TASK* t0p = &tasks[t0];\n"
561 ," t0p->wait -= delta;\n"
562 ," if (t0p->wait > 0L) {\n"
563 ," newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
565 ," switch (t0p->id) {"
570 ," Serial.println(\"stopped\");\n"
571 ," t0 = tn; // no known task: force termination of tasks\n"
575 ," t0 = NEXT_TASK(t0);\n"
579 where c = f Rd newCode
581 mkset :: [a] -> [a] | Eq a
582 mkset [a:x] = [a:mkset (filter ((<>) a) x)]
605 instance toCode () where toCode _ = ""
607 class toCode a :: a -> String
609 instance toCode Long where toCode (L i) = toCode i + "L"
611 instance toCode Bool where toCode b = if b "true" "false"
612 instance toCode Int where toCode a = toString a
613 instance toCode Real where toCode a = toString a
614 instance toCode Char where
615 toCode '\0' = "'\\0'"
616 toCode '\n' = "'\\n'"
618 toCode a = "'" + toString a + "'"
619 instance toCode String where toCode s = s
620 instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
621 instance toCode AnalogPin where toCode x = consName{|*|} x
623 instance toCode Pin where
624 toCode (Digital p) = toCode p
625 toCode (Analog p) = toCode p
626 instance toCode UserLED where
627 toCode LED1 = toCode 1
628 toCode LED2 = toCode 2
629 toCode LED3 = toCode 3