mTaskCode.icl

   1 implementation module mTaskCode
   2
   3 import iTasks
   4 import gdynamic, gCons, GenEq, StdMisc, StdArray
   5 import mTask
   6
   7 instance toCode MTask where toCode (MTask x) = "Task " + toCode x
   8
   9 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
  10 argType f = undef
  11
  12 instance argTypes (Code a p) | showType a where argTypes f = showType
  13 instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
  14 instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)
  15
  16 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
  17 resType f = showType
  18
  19 var2Type :: (Code t p) -> Code t p | showType t
  20 var2Type x = showType
  21
  22 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
  23 resType2 f = showType2
  24
  25 instance toCode (SV t) where toCode (SV s) = s
  26
  27 instance arith Code where
  28   lit a = embed (c a)
  29   (+.) x y = codeOp2 x " + " y
  30   (-.) x y = codeOp2 x " - " y
  31   (*.) x y = codeOp2 x " * " y
  32   (/.) x y = codeOp2 x " / " y
  33 instance boolExpr Code where
  34   (&.) x y  = codeOp2 x " && " y
  35   (|.) x y  = codeOp2 x " || " y
  36   Not x     = embed (brac (c "! " +.+ brac x))
  37   (==.) x y = codeOp2 x " == " y
  38   (!=.) x y = codeOp2 x " != " y
  39   (<.)  x y = codeOp2 x " < "  y
  40   (<=.) x y = codeOp2 x " <= " y
  41   (>.)  x y = codeOp2 x " > "  y
  42   (>=.) x y = codeOp2 x " >= " y
  43 instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
  44 instance If Code e    Stmt Stmt where If c t e = IfStmt c t e
  45 instance If Code Stmt e    Stmt where If c t e = IfStmt c t e
  46 instance If Code x    y    Expr where If c t e = IfExpr c t e
  47 IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
  48 IfStmt b t e =
  49   getMode \mode.
  50   let
  51     v = varName t
  52     newMode =
  53       case mode of
  54         Return s = Return s
  55         Assign v = Assign v
  56         _    = if (v == "") NoReturn (Assign v)
  57   in
  58     setMode SubExp +.+
  59     c "if " +.+ brac b +.+ c " {" +.+
  60       indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
  61       indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}"
  62 instance IF Code where
  63   IF b t e  = IfStmt b t e
  64   (?) b t =
  65     getMode \mode.
  66     c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+
  67     indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}"
  68
  69 instance sds Code where
  70   sds f = // defCode f
  71    {main = fresh \n.
  72     let name = "sds"+toCode n
  73         (v In body) = f (C (var name))
  74     in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
  75        ";\n") +.+ setCode Setup +.+ unMain body}
  76   con f = defCode f
  77
  78 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
  79 defCode f =
  80   {main = fresh \n.
  81     let name = "sds"+toCode n
  82         (v In body) = f (C (var name))
  83     in  setCode Var +.+ c (type2string v + " " + name + " = " + toCode v +
  84         ";\n") +.+ setCode Setup +.+ unMain body}
  85
  86 var :: String (ReadWrite (Code v q)) CODE -> CODE
  87 var sds Rd      s = unC (embed (c sds)) Rd s
  88 var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s
  89
  90 instance assign Code where
  91   (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
  92 instance seq Code where
  93   (>>=.) x f =
  94     getMode \mode. fresh \n. let v = "b" + toCode n in
  95     addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
  96     setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
  97   (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
  98 instance step` Code where
  99     (>>*.) x f =
 100         getMode \mode. fresh \n.
 101             let v = "s" + toCode n in
 102             c "while(true) {" +.+ indent +.+ nl +.+
 103             var2Type x +.+ c (v + ";") +.+ nl +.+
 104             setMode (Assign v) +.+ x +.+ nl +.+
 105             setMode mode +.+ codeSteps (f (c v)) +.+
 106             unindent +.+ nl +.+ c "}"
 107 codeSteps :: [Step Code t] -> Code u p
 108 codeSteps [] = C \rw c.c
 109 codeSteps [Cond b e:x] =
 110     getMode \mode. setMode SubExp +.+
 111     c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+
 112     setMode mode +.+ e +.+
 113     optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
 114 codeSteps [Ever e:x] =
 115     getMode \mode. e +.+ optBreak mode
 116
 117 optBreak :: Mode -> Code u p
 118 optBreak mode =
 119     case mode of
 120         Return s    = C \rw c.c
 121         _           = nl +.+ c "break;"
 122
 123 instance setDelay Code where
 124   setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
 125 instance mtask Code a | taskImp2 a & types a where
 126   task f =
 127    {main = freshMTask \n.
 128    let (app, a)  = taskImp2 n types
 129        (b In main) = f (\d a.app (long d) a)
 130    in codeMTaskBody (loopCode n (b a)) (unMain main)}
 131 instance mtasks Code a b | taskImp2 a & types a  & taskImp2 b & types b  where
 132   tasks f =
 133     {main =
 134             freshMTask \t1.
 135             freshMTask \t2.
 136             let (app1, a1) = taskImp2 t1 types
 137                 (app2, a2) = taskImp2 t2 types
 138                 ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
 139             in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
 140
 141 loopCode :: Int (Code a b) -> Code c d
 142 loopCode n b =
 143   nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
 144   setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+
 145   unindent +.+ nl +.+ c "} "
 146
 147 instance taskImp2 () where
 148   taskImp2 n () = (app, ())
 149   where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
 150 instance taskImp2 (Code t p) where
 151   taskImp2 n type1 = (app, ta)
 152     where
 153       n0 = "t0p->a[0]"
 154       ta = c n0 +.+ type1
 155       app d a =
 156         setBinds [n0] +.+ embed (c "newTask(" +.+
 157           c n +.+ c ", " +.+
 158           d +.+ c ", " +.+
 159           a +.+ c ")")
 160 instance taskImp2 (Code a p, Code b q) where
 161   taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
 162     n0 = "t0p->a[0]"
 163     n1 = "t0p->a[1]"
 164     ta1 = c n0 +.+ type1
 165     ta2 = c n1 +.+ type2
 166     app d (a1, a2) =
 167             setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+
 168             c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
 169 instance taskImp2 (Code a p, Code b q, Code c r) where
 170   taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
 171     where
 172       n0 = "t0p->a[0]"
 173       n1 = "t0p->a[1]"
 174       n2 = "t0p->a[2]"
 175       ta1 = c n0 +.+ type1
 176       ta2 = c n1 +.+ type2
 177       ta3 = c n2 +.+ type3
 178       app d (a1, a2, a3) =
 179         setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+
 180           c n +.+ c ", " +.+
 181           d  +.+ c ", " +.+
 182           a1 +.+ c ", " +.+
 183           a2 +.+ c ", " +.+
 184           a3 +.+ c ", 0)")
 185 instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where
 186   taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
 187     where
 188       n0 = "t0p->a[0]"
 189       n1 = "t0p->a[1]"
 190       n2 = "t0p->a[2]"
 191       n3 = "t0p->a[3]"
 192       ta1 = c n0 +.+ type1
 193       ta2 = c n1 +.+ type2
 194       ta3 = c n2 +.+ type3
 195       ta4 = c n3 +.+ type4
 196       app d (a1, a2, a3, a4) =
 197         setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+
 198           c n +.+ c ", " +.+
 199           d  +.+ c ", " +.+
 200           a1 +.+ c ", " +.+
 201           a2 +.+ c ", " +.+
 202           a3 +.+ c ", " +.+
 203           a4 +.+ c ")")
 204
 205 class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
 206 instance taskImp () where
 207   taskImp n () = (app, ())
 208     where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
 209 instance taskImp (Code t p) where
 210   taskImp n type1 = (app, ta)
 211     where
 212       ta = c "t0p->a[0]" +.+ type1
 213       app i a =
 214         embed (c "newTask(" +.+
 215           c n +.+ c ", " +.+
 216           c i +.+ c ", " +.+
 217           a +.+ c ")")
 218 instance taskImp (Code a p, Code b q) where
 219   taskImp n (type1, type2) = (app, (ta1, ta2)) where
 220           ta1 = c "t0p->a[0]" +.+ type1
 221           ta2 = c "t0p->a[1]" +.+ type2
 222           app i (a1, a2) =
 223             embed (c "newTask(" +.+ c n +.+ c ", " +.+  c i +.+
 224             c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
 225 instance taskImp (Code a p, Code b q, Code c r) where
 226   taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
 227     where
 228       ta1 = c "t0p->a[0]" +.+ type1
 229       ta2 = c "t0p->a[1]" +.+ type2
 230       ta3 = c "t0p->a[2]" +.+ type3
 231       app i (a1, a2, a3) =
 232         embed (c "newTask(" +.+
 233           c n +.+ c ", " +.+
 234           c i +.+ c ", " +.+
 235           a1 +.+ c ", " +.+
 236           a2 +.+ c ", " +.+
 237           a3 +.+ c ")")
 238 instance taskImp (Code a p, Code b q, Code c r, Code d s) where
 239   taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
 240     where
 241       ta1 = c "t0p->a[0]" +.+ type1
 242       ta2 = c "t0p->a[1]" +.+ type2
 243       ta3 = c "t0p->a[2]" +.+ type3
 244       ta4 = c "t0p->a[3]" +.+ type4
 245       app i (a1, a2, a3, a4) =
 246         embed (c "newTask(" +.+
 247           c n +.+ c ", " +.+
 248           c i +.+ c ", " +.+
 249           a1 +.+ c ", " +.+
 250           a2 +.+ c ", " +.+
 251           a3 +.+ c ", " +.+
 252           a4 +.+ c ")")
 253
 254 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
 255 tasksMain i j f =
 256     { main =
 257       freshMTask \n. freshMTask \m.
 258         let
 259           (app1, a1) = taskImp n types
 260           (app2, a2) = taskImp m types
 261           ((b1, b2) In {main = e}) = f (app1 i, app2 j)
 262         in
 263           codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
 264     }
 265 class types a :: a
 266 instance types () where types = ()
 267 instance types (Code a p) | typeSelector a & isExpr p
 268   where types = typeSelector
 269 instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
 270   where types = (typeSelector, typeSelector)
 271 instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
 272   where types = (typeSelector, typeSelector, typeSelector)
 273 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
 274   where types = (typeSelector, typeSelector, typeSelector, typeSelector)
 275
 276 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
 277 codeMTaskBody loop e =
 278   getMode \mode.
 279     setMode NoReturn +.+
 280     setCode Loop +.+ loop +.+
 281     setMode mode +.+ setCode Setup +.+ embed e
 282 instance fun Code () where
 283   fun f  =
 284    {main = getMode \mode. fresh \n.
 285         let fname = c ("f" + toCode n)
 286         (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
 287     in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+
 288        funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
 289    }
 290 instance fun Code (Code t p) | type, showType t & isExpr p  where
 291   fun f  =
 292     {main =
 293       getMode \mode. fresh \n.
 294         let fname = c ("f" + toCode n)
 295             aname = "a" + toCode n
 296             (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
 297         in  setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
 298           brac (argTypes f +.+ c (" " + aname)) +.+
 299           funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
 300     }
 301 instance fun Code (Code a p, Code b q) | showType a & showType b where
 302   fun f =
 303          {main =
 304           getMode \mode. fresh \n.
 305           let fname = c ("f" + toCode n + " ")
 306               aname = "a" + toCode n //+ " "
 307               bname = "b" + toCode n //+ " "
 308               (atype, btype) = argTypes f
 309               (g In main)
 310                = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
 311           in setCode Fun +.+ nl +.+ resType f +.+ fname +.+
 312              codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+
 313              funBody (setMode (Return (toCode (resType2 f))) +.+
 314              setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+
 315              setCode Setup +.+ setMode mode +.+ unMain main
 316          }
 317 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
 318   fun f  =
 319     {main =
 320       getMode \mode. fresh \n.
 321         let fname = c ("f" + toCode n)
 322             aname = "a" + toCode n
 323             bname = "b" + toCode n
 324             cname = "c" + toCode n
 325             (atype,btype,ctype) = argTypes f
 326             (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
 327         in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
 328            brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+
 329            funBody (setMode (Return (toCode (resType2 f))) +.+
 330            setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
 331     }
 332 instance output Code where
 333   output x = embed (c "Serial.println(" +.+ x +.+ c ")")
 334 instance pinMode Code where
 335   pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
 336 instance digitalIO Code where
 337   digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
 338   digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
 339 instance dIO Code where
 340   dIO p = C (ioc p) where
 341     ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
 342     ioc p Rd   s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
 343     ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
 344 instance aIO Code where
 345   aIO p = C (ioc p)  where
 346     ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
 347     ioc p Rd      s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
 348     ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
 349 instance analogIO Code where
 350   analogRead p = embed (c ("analogRead(" + toCode p + ")"))
 351   analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
 352 instance noOp Code where noOp = C \rw c.c
 353
 354 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
 355 :: CODE =
 356   { fresh       :: Int
 357   , freshMTask :: Int
 358   , funs        :: [String]
 359   , ifuns                       :: Int
 360   , vars          :: [String]
 361   , ivars                       :: Int
 362   , setup                       :: [String]
 363   , isetup        :: Int
 364   , loop          :: [String]
 365   , iloop                       :: Int
 366   , includes  :: [String]
 367   , def           :: Def
 368   , mode          :: Mode
 369   , binds                       :: [String]
 370   }
 371
 372 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
 373 unC (C f) = f
 374
 375 :: Def = Var | Fun | Setup | Loop
 376 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
 377
 378 setMode :: Mode -> Code a p
 379 setMode m = C \rw c.{c & mode = m}
 380
 381 getMode :: (Mode -> Code a p) -> Code a p
 382 getMode f = C \rw c.unC (f c.mode) rw c
 383
 384 embed :: (Code a p) -> Code a p
 385 embed e =
 386   getMode \m. case m of
 387     NoReturn  = setMode SubExp +.+ e +.+ c ";"
 388     Return "void" = setMode SubExp +.+ e +.+ c ";"
 389     Return t  = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
 390     Assign s  = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
 391     SubExp    = e
 392     _       = abort "\n\nembed: unknown mode.\n"
 393
 394 (+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
 395 (+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)
 396
 397 fresh :: (Int -> (Code a p)) -> (Code a p)
 398 fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}
 399
 400 freshMTask :: (Int -> (Code a p)) -> (Code a p)
 401 freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}
 402
 403 setCode :: Def -> (Code a p)
 404 setCode d = C \rw c.{c & def = d}
 405
 406 getCode :: (Def -> Code a p) -> (Code a p)
 407 getCode f = C \rw c.unC (f c.def) rw c
 408
 409 brac :: (Code a p) -> Code b q
 410 brac e = c "(" +.+ e +.+ c ")"
 411
 412 funBody :: (Code a p) -> Code b q
 413 funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl
 414
 415 codeOp2 :: (Code a p) String (Code b q) -> Code c r
 416 codeOp2 x n y = embed (brac (x +.+ c n +.+ y))
 417
 418 include :: String -> Code a b
 419 include lib = C \rw c.{c & includes = [lib:c.includes]}
 420
 421 argList :: [a] -> String | toCode a
 422 argList [a] = toCode a
 423 argList [a:x] = toCode a + "," + argList x
 424 argList [] = ""
 425
 426 c :: a -> Code b p | toCode a
 427 c a = C \rw c.case c.def of
 428     Fun   = {c & funs = [toCode a: c.funs]}
 429     Var   = {c & vars = [toCode a: c.vars]}
 430     Setup   = {c & setup = [toCode a: c.setup]}
 431     Loop  = {c & loop = [toCode a: c.loop]}
 432
 433 indent :: Code a p
 434 indent =
 435   C \rw c.case c.def of
 436     Fun   = {c & ifuns = inc c.ifuns}
 437     Var   = {c & ivars = inc c.ivars}
 438     Setup   = {c & isetup = inc c.isetup}
 439     Loop  = {c & iloop = inc c.iloop}
 440
 441 unindent :: Code a p
 442 unindent =
 443   C \rw c.case c.def of
 444     Fun   = {c & ifuns = dec c.ifuns}
 445     Var   = {c & ivars = dec c.ivars}
 446     Setup   = {c & isetup = dec c.isetup}
 447     Loop  = {c & iloop = dec c.iloop}
 448 where
 449   dec n | n > 1
 450     = n - 1
 451     = 0
 452
 453 nl :: Code a p
 454 nl =
 455   C \rw c.case c.def of
 456     Fun   = {c & funs = [str c.ifuns: c.funs]}
 457     Var   = {c & vars = [str c.ivars: c.vars]}
 458     Setup   = {c & setup = [str c.isetup: c.setup]}
 459     Loop  = {c & loop = [str c.iloop: c.loop]}
 460 where
 461   str n = toString ['\n':repeatn (tabSize * n) ' ']
 462
 463 setBinds :: [String] -> Code a p
 464 setBinds list = C \rw c.{c & binds = list}
 465
 466 addBinds :: String -> Code a p
 467 addBinds name = C \rw c.{c & binds = [name:c.binds]}
 468
 469 getBinds :: ([String] -> Code a p) -> (Code a p)
 470 getBinds f = C \rw c.unC (f c.binds) rw c
 471
 472 // ----- driver ----- //
 473
 474 compile :: (Main (Code a p)) -> [String]
 475 compile {main=(C f)} =
 476   ["/*\n"
 477   ,"  Generated code for Arduino\n"
 478   ,"  Pieter Koopman, pieter@cs.ru.nl\n"
 479   ,"*/\n"
 480   ,"\n"
 481   ,"#define MAX_ARGS 4\n"
 482   ,"#define MAX_TASKS 20\n"
 483   ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
 484   ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
 485   ,"\n"
 486   ,"typedef union Arg {\n"
 487   ,"  int i;\n"
 488   ,"  bool b;\n"
 489   ,"  char c;\n"
 490 //  ,"  float f;\n" // requires 4 bytes
 491   ,"  word w;\n"
 492   ,"} ARG;\n"
 493   ,"\n"
 494   ,"typedef struct Task {\n"
 495   ,"  byte id;\n"
 496   ,"  long wait;\n"
 497   ,"  ARG a[MAX_ARGS];\n"
 498   ,"} TASK;\n"
 499   ,"\n"
 500   ] ++
 501   foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
 502   ["\n// --- variables ---\n"
 503   ,"TASK tasks[MAX_TASKS];\n"
 504   ,"byte t0 = 0, tc = 0, tn = 0;\n"
 505   ,"long delta;\n"
 506   ,"\n"
 507   ,"int vInt;\n"
 508   ,"bool vBool;\n"
 509   ,"char vChar;\n"
 510   ,"float vFloat;\n"
 511   ,"unsigned long time = 0;\n"
 512   :reverse c.vars
 513   ] ++
 514   ["\n// --- functions ---\n"
 515   ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
 516   ,"  TASK *tnp = &tasks[tn];\n"
 517   ,"  tnp->id = id;\n"
 518   ,"  tnp->wait = wait;\n"
 519   ,"  tnp->a[0].w = a0;\n"
 520   ,"  tnp->a[1].w = a1;\n"
 521   ,"  tnp->a[2].w = a2;\n"
 522   ,"  tnp->a[3].w = a3;\n"
 523   ,"  byte r = tn;\n"
 524   ,"  tn = NEXT_TASK(tn);\n"
 525   ,"  return r;\n"
 526   ,"}\n"
 527   ,"\n"
 528   ,"byte setDelay(byte t, long d) {\n"
 529   ,"  tasks[t].wait = d;\n"
 530   ,"  return t;\n"
 531   ,"}\n"
 532   ,"boolean pressed(int b) {\n"
 533   ,"  pinMode(A0, INPUT);\n"
 534   ,"  int a0 = analogRead(A0);\n"
 535   ,"  switch (b) {\n"
 536   ,"  case 0: return a0 < ",toString RightBound,";       // right\n"
 537   ,"  case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
 538   ,"  case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
 539   ,"  case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
 540   ,"  case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
 541   ,"  default: return ",toString SelectBound," < a0;       //no button\n"
 542   ,"  }\n"
 543   ,"}\n"
 544   ,"boolean pWrite (int pin, boolean b) {\n"
 545   ,"  pinMode(pin, OUTPUT);\n"
 546   ,"  digitalWrite(pin, b);\n"
 547   ,"  return b;\n"
 548   ,"}\n"
 549   ,"int pWrite (int pin, int i) {\n"
 550   ,"  pinMode(pin, OUTPUT);\n"
 551   ,"  analogWrite(pin, i);\n"
 552   ,"  return i;\n"
 553   ,"}\n"
 554   :reverse c.funs
 555   ] ++
 556   ["\n// --- setup --- \n"
 557   ,"void setup () {\n"
 558   ,"  Serial.begin(9600);\n"
 559   ,"  "
 560   :reverse c.setup
 561   ] ++
 562   ["\n}\n"
 563   ,"\n// --- loop --- \n"
 564   ,"void loop () {\n"
 565   ,"  if (t0 != tn) {\n"
 566   ,"  if (t0 == tc) {\n"
 567   ,"    unsigned long time2 = millis();\n"
 568   ,"    delta = time2 - time;\n"
 569   ,"    time = time2;\n"
 570   ,"    tc = tn;\n"
 571   ,"  };\n"
 572   ,"  TASK* t0p = &tasks[t0];\n"
 573   ,"  t0p->wait -= delta;\n"
 574   ,"  if (t0p->wait > 0L) {\n"
 575   ,"    newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
 576   ,"  } else {\n"
 577   ,"    switch (t0p->id) {"
 578   :reverse c.loop
 579   ] ++
 580   ["\n"
 581   ,"    default:\n"
 582   ,"    Serial.println(\"stopped\");\n"
 583   ,"    t0 = tn; // no known task: force termination of tasks\n"
 584   ,"    return;\n"
 585   ,"    };\n"
 586   ,"  }\n"
 587   ,"  t0 = NEXT_TASK(t0);\n"
 588   ,"  }\n"
 589   ,"}\n"
 590   ]
 591 where c = f Rd newCode
 592
 593 mkset :: [a] -> [a] | Eq a
 594 mkset [a:x] = [a:mkset (filter ((<>) a) x)]
 595 mkset [] = []
 596
 597 newCode :: CODE
 598 newCode =
 599   { fresh   = 0
 600   , freshMTask = 0
 601   , funs    = []
 602   , ifuns   = 0
 603   , vars    = []
 604   , ivars   = 0
 605   , setup   = []
 606   , isetup  = 1
 607   , loop    = []
 608   , iloop   = 4
 609   , includes  = []
 610   , def     = Setup
 611   , mode    = NoReturn
 612   , binds               = []
 613   }
 614
 615
 616 //Tools
 617 instance toCode () where toCode _ = ""
 618
 619 class toCode a :: a -> String
 620
 621 instance toCode Long where toCode (L i) = toCode i + "L"
 622
 623 instance toCode Bool where toCode b = if b "true" "false"
 624 instance toCode Int where toCode a = toString a
 625 instance toCode Real where toCode a = toString a
 626 instance toCode Char where
 627   toCode '\0' = "'\\0'"
 628   toCode '\n' = "'\\n'"
 629   toCode '\\' = "\\"
 630   toCode a = "'" + toString a + "'"
 631 instance toCode String where toCode s = s
 632 instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
 633 instance toCode AnalogPin  where toCode x = consName{|*|} x
 634
 635 instance toCode Pin where
 636     toCode (Digital p) = toCode p
 637     toCode (Analog  p) = toCode p
 638