implementation module mTask

/*
    Pieter Koopman pieter@cs.ru.nl
    Final version for TFP2016
    
    -2: assignment =. suited for digital and analog input and output
    -3: ad hoc tasks
    
todo:
	move task-loop ti setup()
	adhoc tasks
	task combinators
	imporove setp: >>*.
*/

import iTasks
import gdynamic, gCons, GenEq, StdMisc, StdArray
import mTaskSerial, mTaskLCD

instance toCode Pin where
    toCode (Digital p) = toCode p
    toCode (Analog  p) = toCode p

instance pin DigitalPin where
	pin p = Digital p

instance pin AnalogPin  where
  pin p = Analog  p

instance isExpr Upd  where isExpr _ = 0
instance isExpr Expr where isExpr _ = 1

instance isStmt Upd where isStmt _ = 10
instance isStmt Expr   where isStmt _ = 11
instance isStmt Stmt   where isStmt _ = 12

instance == MTask where (==) (MTask x) (MTask y) = x == y
instance toCode MTask where toCode (MTask x) = "Task " + toCode x 

unMain :: (Main x) -> x
unMain m = m.main //{main=x} = x

instance pio AnalogPin Int where pio p = aIO p
instance pio AnalogPin Bool where pio p = dIO p
instance pio DigitalPin Bool where pio p = dIO p

int :: (v Int p) -> (v Int p)
int x = x
bool :: (v Bool p) -> (v Bool p)
bool x = x
char :: (v Char p) -> (v Char p)
char x = x

instance type2string Int        where type2string _ = "int"
instance type2string Long       where type2string _ = "long"
instance type2string Real       where type2string _ = "float"
instance type2string Bool       where type2string _ = "bool" //"boolean"
instance type2string Char       where type2string _ = "char"
instance type2string MTask      where type2string _ = "task"
instance type2string DigitalPin where type2string _ = "int"
instance type2string AnalogPin  where type2string _ = "int"
instance type2string String     where type2string _ = "Char []"
instance type2string ()         where type2string _ = ""

instance varName Int    where varName _ = "vInt"
instance varName Long   where varName _ = "vLong"
instance varName Bool   where varName _ = "vBool"
instance varName Char   where varName _ = "vChar"
instance varName Real   where varName _ = "vFloat"
instance varName x      where varName _ = ""

argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
argType f = undef

instance argTypes (Code a p) | showType a where argTypes f = showType
instance argTypes (Code a p, Code b q) | showType a & showType b where argTypes f = (showType, showType)
instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c where argTypes f = (showType, showType, showType)

resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
resType f = showType

var2Type :: (Code t p) -> Code t p | showType t
var2Type x = showType

resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
resType2 f = showType2

instance toCode (SV t) where toCode (SV s) = s

instance showType2 ()   where showType2 = SV "void "
instance showType2 Int  where showType2 = SV "int "
instance showType2 Char where showType2 = SV "char "
instance showType2 Bool where showType2 = SV "bool "
instance showType2 a    where showType2 = SV "word /* default */"

instance showType ()   where showType = c "void "
instance showType Int  where showType = c "int "
instance showType Long where showType = c "long "
instance showType Char where showType = c "char "
instance showType Bool where showType = c "bool "
instance showType a    where showType = c "word /* default */ "

instance typeSelector Int  where typeSelector = c ".i"
instance typeSelector Char where typeSelector = c ".c"
instance typeSelector Bool where typeSelector = c ".b"
instance typeSelector a    where typeSelector = c ".w"

read` :: Int (ReadWrite a) State -> (a,State) | dyn a
read` n Rd       s = (fromJust (fromDyn (s.store !! n)), s)
read` n (Wrt a)  s = (a,{s&store=updateAt n (toDyn a) s.store})
read` n (Updt f) s=:{store}
  # obj = f (fromJust (fromDyn (store !! n)))
  = (obj, {s & store = updateAt n (toDyn obj) store})

// ----- code generation ----- //

instance arith Code where
  lit a = embed (c a)
  (+.) x y = codeOp2 x " + " y 
  (-.) x y = codeOp2 x " - " y 
  (*.) x y = codeOp2 x " * " y
  (/.) x y = codeOp2 x " / " y
instance boolExpr Code where
  (&.) x y  = codeOp2 x " && " y
  (|.) x y  = codeOp2 x " || " y
  Not x     = embed (brac (c "! " +.+ brac x))
  (==.) x y = codeOp2 x " == " y
  (!=.) x y = codeOp2 x " != " y
  (<.)  x y = codeOp2 x " < "  y
  (<=.) x y = codeOp2 x " <= " y
  (>.)  x y = codeOp2 x " > "  y
  (>=.) x y = codeOp2 x " >= " y
instance If Code Stmt Stmt Stmt where If c t e = IfStmt c t e
instance If Code e    Stmt Stmt where If c t e = IfStmt c t e
instance If Code Stmt e    Stmt where If c t e = IfStmt c t e
instance If Code x    y    Expr where If c t e = IfExpr c t e
IfExpr b t e = embed (brac (b +.+ indent +.+ nl +.+ c " ? " +.+ t +.+ nl +.+ c " : " +.+ e +.+ unindent))
IfStmt b t e =
  getMode \mode.
  let
    v = varName t
    newMode = 
      case mode of
        Return s = Return s
        Assign v = Assign v
        _    = if (v == "") NoReturn (Assign v)
  in
    setMode SubExp +.+
    c "if " +.+ brac b +.+ c " {" +.+ 
      indent +.+ nl +.+ setMode newMode +.+ t +.+ unindent +.+ nl +.+ c "} else {" +.+
      indent +.+ nl +.+ setMode newMode +.+ e +.+ unindent +.+ nl +.+ c "}" 
instance IF Code where
  IF b t e  = IfStmt b t e
  (?) b t = 
    getMode \mode.
    c "if " +.+ setMode SubExp +.+ brac b +.+ c " {" +.+ 
    indent +.+ nl +.+ setMode mode +.+ t +.+ c ";" +.+ unindent +.+ nl +.+ c "}" 

instance sds Code where
  sds f = // defCode f
   {main = fresh \n.
    let name = "sds"+toCode n
        (v In body) = f (C (var name))
    in setCode Var +.+ c (type2string v + " " + name + " = " + toCode v + 
       ";\n") +.+ setCode Setup +.+ unMain body}
  con f = defCode f

defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
defCode f =
  {main = fresh \n.
    let name = "sds"+toCode n
        (v In body) = f (C (var name))
    in  setCode Var +.+ c (type2string v + " " + name + " = " + toCode v + 
        ";\n") +.+ setCode Setup +.+ unMain body}

var :: String (ReadWrite (Code v q)) CODE -> CODE
var sds Rd      s = unC (embed (c sds)) Rd s
var sds (Wrt v) s = unC (embed (c ("(" + sds + " = ") +.+ v +.+ c ")")) Rd s

instance assign Code where
  (=.) (C v) e = embed (setMode SubExp +.+ C \rw c.v (Wrt (toExpr e)) c)
instance seq Code where
  (>>=.) x f = 
    getMode \mode. fresh \n. let v = "b" + toCode n in
    addBinds v +.+ var2Type x +.+ c (v + ";") +.+ nl +.+
    setMode (Assign v) +.+ x +.+ nl +.+ setMode mode +.+ f (embed (c v))
  (:.) x y = getMode \mode. setMode NoReturn +.+ embed x +.+ nl +.+ setMode mode +.+ y
instance step` Code where
    (>>*.) x f =
        getMode \mode. fresh \n.
            let v = "s" + toCode n in
            c "while(true) {" +.+ indent +.+ nl +.+
            var2Type x +.+ c (v + ";") +.+ nl +.+
            setMode (Assign v) +.+ x +.+ nl +.+
            setMode mode +.+ codeSteps (f (c v)) +.+
            unindent +.+ nl +.+ c "}" 
codeSteps :: [Step Code t] -> Code u p
codeSteps [] = C \rw c.c
codeSteps [Cond b e:x] =
    getMode \mode. setMode SubExp +.+
    c "if (" +.+ b +.+ c ") {" +.+ indent +.+ nl +.+ 
    setMode mode +.+ e +.+ 
    optBreak mode +.+ unindent +.+ nl +.+ c "}" +.+ nl +.+ setMode mode +.+ codeSteps x
codeSteps [Ever e:x] =
    getMode \mode. e +.+ optBreak mode

optBreak :: Mode -> Code u p
optBreak mode =
    case mode of
        Return s    = C \rw c.c
        _           = nl +.+ c "break;" 

instance setDelay Code where
  setDelay d t = embed (c "setDelay" +.+ brac (t +.+ c ", " +.+ d))
instance mtask Code a | taskImp2 a & types a where
  task f =
   {main = freshMTask \n.
   let (app, a)  = taskImp2 n types
       (b In main) = f (\d a.app (long d) a)
   in codeMTaskBody (loopCode n (b a)) (unMain main)}
instance mtasks Code a b | taskImp2 a & types a  & taskImp2 b & types b  where
  tasks f = 
    {main = 
	    freshMTask \t1. 
	    freshMTask \t2.
	    let (app1, a1) = taskImp2 t1 types
	        (app2, a2) = taskImp2 t2 types
	        ((b1, b2) In main) = f ((\d a.app1 (long d) a),(\d a.app2 (long d) a))
	    in codeMTaskBody (loopCode t2 (b2 a2)) (codeMTaskBody (loopCode t1 (b1 a1)) (unMain main))}
loopCode :: Int (Code a b) -> Code c d
loopCode n b =
  nl +.+ c "case " +.+ c n +.+ c ": {" +.+ indent +.+ nl +.+
  setMode NoReturn +.+ b +.+ nl +.+ c "break;" +.+ 
  unindent +.+ nl +.+ c "} "

class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
instance taskImp2 () where
  taskImp2 n () = (app, ())
  where app d a = setBinds [] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ d +.+ c ")")
instance taskImp2 (Code t p) where
  taskImp2 n type1 = (app, ta)
    where
      n0 = "t0p->a[0]"
      ta = c n0 +.+ type1
      app d a = 
        setBinds [n0] +.+ embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          d +.+ c ", " +.+
          a +.+ c ")")
instance taskImp2 (Code a p, Code b q) where 
  taskImp2 n (type1, type2) = (app, (ta1, ta2)) where
    n0 = "t0p->a[0]"
    n1 = "t0p->a[1]"
    ta1 = c n0 +.+ type1
    ta2 = c n1 +.+ type2
    app d (a1, a2) = 
	    setBinds [n0,n1] +.+ embed (c "newTask(" +.+ c n +.+ c ", " +.+ long d +.+ 
	    c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
instance taskImp2 (Code a p, Code b q, Code c r) where 
  taskImp2 n (type1, type2, type3) = (app, (ta1, ta2, ta3))
    where
      n0 = "t0p->a[0]"
      n1 = "t0p->a[1]"
      n2 = "t0p->a[2]"
      ta1 = c n0 +.+ type1
      ta2 = c n1 +.+ type2
      ta3 = c n2 +.+ type3
      app d (a1, a2, a3) = 
        setBinds [n0,n1,n2] +.+ embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          d  +.+ c ", " +.+
          a1 +.+ c ", " +.+ 
          a2 +.+ c ", " +.+ 
          a3 +.+ c ", 0)")
instance taskImp2 (Code a p, Code b q, Code c r, Code d s) where 
  taskImp2 n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
    where
      n0 = "t0p->a[0]"
      n1 = "t0p->a[1]"
      n2 = "t0p->a[2]"
      n3 = "t0p->a[3]"
      ta1 = c n0 +.+ type1
      ta2 = c n1 +.+ type2
      ta3 = c n2 +.+ type3
      ta4 = c n3 +.+ type4
      app d (a1, a2, a3, a4) = 
        setBinds [n0,n1,n2,n3] +.+ embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          d  +.+ c ", " +.+
          a1 +.+ c ", " +.+ 
          a2 +.+ c ", " +.+ 
          a3 +.+ c ", " +.+ 
          a4 +.+ c ")")

class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
instance taskImp () where
  taskImp n () = (app, ())
    where app i a = embed (c "newTask(" +.+ c n +.+ c ", " +.+ c i +.+ c ")")
instance taskImp (Code t p) where
  taskImp n type1 = (app, ta)
    where
      ta = c "t0p->a[0]" +.+ type1
      app i a = 
        embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          c i +.+ c ", " +.+
          a +.+ c ")")
instance taskImp (Code a p, Code b q) where 
  taskImp n (type1, type2) = (app, (ta1, ta2)) where
	  ta1 = c "t0p->a[0]" +.+ type1
	  ta2 = c "t0p->a[1]" +.+ type2
	  app i (a1, a2) = 
	    embed (c "newTask(" +.+ c n +.+ c ", " +.+  c i +.+ 
	    c ", " +.+ a1 +.+ c ", " +.+ a2 +.+ c ")")
instance taskImp (Code a p, Code b q, Code c r) where 
  taskImp n (type1, type2, type3) = (app, (ta1, ta2, ta3))
    where
      ta1 = c "t0p->a[0]" +.+ type1
      ta2 = c "t0p->a[1]" +.+ type2
      ta3 = c "t0p->a[2]" +.+ type3
      app i (a1, a2, a3) = 
        embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          c i +.+ c ", " +.+
          a1 +.+ c ", " +.+ 
          a2 +.+ c ", " +.+ 
          a3 +.+ c ")")
instance taskImp (Code a p, Code b q, Code c r, Code d s) where 
  taskImp n (type1, type2, type3, type4) = (app, (ta1, ta2, ta3, ta4))
    where
      ta1 = c "t0p->a[0]" +.+ type1
      ta2 = c "t0p->a[1]" +.+ type2
      ta3 = c "t0p->a[2]" +.+ type3
      ta4 = c "t0p->a[3]" +.+ type4
      app i (a1, a2, a3, a4) = 
        embed (c "newTask(" +.+ 
          c n +.+ c ", " +.+ 
          c i +.+ c ", " +.+
          a1 +.+ c ", " +.+ 
          a2 +.+ c ", " +.+ 
          a3 +.+ c ", " +.+ 
          a4 +.+ c ")")

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
tasksMain i j f =
    { main =
      freshMTask \n. freshMTask \m.
        let
          (app1, a1) = taskImp n types
          (app2, a2) = taskImp m types
          ((b1, b2) In {main = e}) = f (app1 i, app2 j)
        in
          codeMTaskBody (loopCode n (b1 a1) +.+ setMode NoReturn +.+ loopCode m (b2 a2)) e
    }
class types a :: a
instance types () where types = ()
instance types (Code a p) | typeSelector a & isExpr p
  where types = typeSelector
instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q 
  where types = (typeSelector, typeSelector)
instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r 
  where types = (typeSelector, typeSelector, typeSelector)
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 
  where types = (typeSelector, typeSelector, typeSelector, typeSelector)

codeMTaskBody :: (Code v w) (Code c d) -> Code e f
codeMTaskBody loop e =
  getMode \mode. 
    setMode NoReturn +.+
    setCode Loop +.+ loop +.+
    setMode mode +.+ setCode Setup +.+ embed e
instance fun Code () where
  fun f  =
   {main = getMode \mode. fresh \n.
  	let fname = c ("f" + toCode n)
        (g In {main=e}) = f (\x.embed (fname +.+ c " ()"))
    in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " () " +.+ 
       funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [] +.+ g ()) +.+ setCode Setup +.+ setMode mode +.+ e
   }
instance fun Code (Code t p) | type, showType t & isExpr p  where
  fun f  =
    {main =
      getMode \mode. fresh \n.
        let fname = c ("f" + toCode n)
            aname = "a" + toCode n
            (g In {main=e}) = f (\x.embed (fname +.+ c " " +.+ brac x))
        in  setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
          brac (argTypes f +.+ c (" " + aname)) +.+ 
          funBody (setMode (Return (toCode (resType2 f))) +.+ setBinds [aname] +.+ g (embed (c aname))) +.+ setCode Setup +.+ setMode mode +.+ e
    }
instance fun Code (Code a p, Code b q) | showType a & showType b where
  fun f =
	 {main =
	  getMode \mode. fresh \n.
	  let fname = c ("f" + toCode n + " ")
	      aname = "a" + toCode n //+ " "
	      bname = "b" + toCode n //+ " "
	      (atype, btype) = argTypes f
	      (g In main)
	       = f (\(x,y).embed (fname +.+ codeOp2 x ", " y))
	  in setCode Fun +.+ nl +.+ resType f +.+ fname +.+ 
	     codeOp2 (atype +.+ c aname) ", " (btype +.+ c bname) +.+ 
	     funBody (setMode (Return (toCode (resType2 f))) +.+ 
	     setBinds [aname,bname] +.+ g (embed (c aname), embed (c bname))) +.+ 
	     setCode Setup +.+ setMode mode +.+ unMain main
	 }
instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c where
  fun f  =
    {main =
      getMode \mode. fresh \n.
        let fname = c ("f" + toCode n)
            aname = "a" + toCode n
            bname = "b" + toCode n
            cname = "c" + toCode n
            (atype,btype,ctype) = argTypes f
            (g In {main=e}) = f (\(x,y,z).embed (fname +.+ c " " +.+ brac (x +.+ c ", " +.+ y +.+ c ", " +.+ z)))
        in setCode Fun +.+ c "\n" +.+ resType f +.+ c " " +.+ fname +.+ c " " +.+
           brac (atype +.+ c (" " + aname + ", ") +.+ btype +.+ c (" " + bname + ", ") +.+ ctype +.+ c (" " + cname)) +.+ 
           funBody (setMode (Return (toCode (resType2 f))) +.+ 
           setBinds [aname,bname,cname] +.+ g (embed (c aname), embed (c bname), embed (c cname))) +.+ setCode Setup +.+ setMode mode +.+ e
    }
instance output Code where
  output x = embed (c "Serial.println(" +.+ x +.+ c ")")
instance pinMode Code where
  pinmode p m = embed (c ("pinMode(" + toCode p + ", " + consName{|*|} m + ")"))
instance digitalIO Code where
  digitalRead p = embed (c ("digitalRead(" + toCode p + ")"))
  digitalWrite p b = embed (c ("digitalWrite(" + toCode p + ", ") +.+ b +.+ c ")")
instance dIO Code where
  dIO p = C (ioc p) where
    ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin, readPinD p
    ioc p Rd   s = f Rd s where (C f) = embed (c ("digitalRead(" + toCode p + ")"))
    ioc p (Wrt v) s = f Rd s where (C f) = embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")
instance aIO Code where
  aIO p = C (ioc p)  where
    ioc :: p (ReadWrite (Code t q)) CODE -> CODE | pin p
    ioc p Rd      s = unC (embed (c ("analogRead(" + toCode p + ")"))) Rd s
    ioc p (Wrt v) s = unC (embed (c ("pWrite(" + toCode p + ", ") +.+ v +.+ c ")")) Rd s
instance analogIO Code where
  analogRead p = embed (c ("analogRead(" + toCode p + ")"))
  analogWrite p b = embed (c ("analogWrite(" + toCode p + ", ") +.+ b +.+ c ")")
instance noOp Code where noOp = C \rw c.c

:: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
:: CODE =
  { fresh   	:: Int
  , freshMTask :: Int
  , funs    	:: [String]
  , ifuns			:: Int
  , vars  	  :: [String]
  , ivars			:: Int
  , setup			:: [String]
  , isetup	  :: Int
  , loop  	  :: [String]
  , iloop			:: Int
  , includes  :: [String]
  , def   	  :: Def
  , mode  	  :: Mode
  , binds			:: [String]
  }

unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
unC (C f) = f

:: Def = Var | Fun | Setup | Loop
:: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String

setMode :: Mode -> Code a p
setMode m = C \rw c.{c & mode = m}

getMode :: (Mode -> Code a p) -> Code a p
getMode f = C \rw c.unC (f c.mode) rw c

embed :: (Code a p) -> Code a p
embed e =
  getMode \m. case m of
    NoReturn  = setMode SubExp +.+ e +.+ c ";"
    Return "void" = setMode SubExp +.+ e +.+ c ";"
    Return t  = c "return " +.+ setMode SubExp +.+ e +.+ c ";"
    Assign s  = c (s + " = ") +.+ setMode SubExp +.+ e +.+ c ";"
    SubExp    = e
    _       = abort "\n\nembed: unknown mode.\n"

(+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
(+.+) (C f) (C g) = C \rw c.g Rd (f Rd c)

fresh :: (Int -> (Code a p)) -> (Code a p)
fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1}

freshMTask :: (Int -> (Code a p)) -> (Code a p)
freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1}

setCode :: Def -> (Code a p)
setCode d = C \rw c.{c & def = d}

getCode :: (Def -> Code a p) -> (Code a p)
getCode f = C \rw c.unC (f c.def) rw c

brac :: (Code a p) -> Code b q
brac e = c "(" +.+ e +.+ c ")"

funBody :: (Code a p) -> Code b q
funBody e = c "{" +.+ indent +.+ nl +.+ e +.+ unindent +.+ nl +.+ c "}" +.+ nl

codeOp2 :: (Code a p) String (Code b q) -> Code c r
codeOp2 x n y = embed (brac (x +.+ c n +.+ y))

include :: String -> Code a b
include lib = C \rw c.{c & includes = [lib:c.includes]}

argList :: [a] -> String | toCode a
argList [a] = toCode a
argList [a:x] = toCode a + "," + argList x
argList [] = ""

c :: a -> Code b p | toCode a
c a = C \rw c.case c.def of
    Fun   = {c & funs = [toCode a: c.funs]}
    Var   = {c & vars = [toCode a: c.vars]}
    Setup   = {c & setup = [toCode a: c.setup]}
    Loop  = {c & loop = [toCode a: c.loop]}

indent :: Code a p
indent = 
  C \rw c.case c.def of
    Fun   = {c & ifuns = inc c.ifuns}
    Var   = {c & ivars = inc c.ivars}
    Setup   = {c & isetup = inc c.isetup}
    Loop  = {c & iloop = inc c.iloop}

unindent :: Code a p
unindent =
  C \rw c.case c.def of
    Fun   = {c & ifuns = dec c.ifuns}
    Var   = {c & ivars = dec c.ivars}
    Setup   = {c & isetup = dec c.isetup}
    Loop  = {c & iloop = dec c.iloop}
where
  dec n | n > 1
    = n - 1
    = 0

nl :: Code a p
nl = 
  C \rw c.case c.def of
    Fun   = {c & funs = [str c.ifuns: c.funs]}
    Var   = {c & vars = [str c.ivars: c.vars]}
    Setup   = {c & setup = [str c.isetup: c.setup]}
    Loop  = {c & loop = [str c.iloop: c.loop]}
where
  str n = toString ['\n':repeatn (tabSize * n) ' ']

setBinds :: [String] -> Code a p
setBinds list = C \rw c.{c & binds = list}

addBinds :: String -> Code a p
addBinds name = C \rw c.{c & binds = [name:c.binds]}

getBinds :: ([String] -> Code a p) -> (Code a p)
getBinds f = C \rw c.unC (f c.binds) rw c

// ----- driver ----- //

compile :: (Main (Code a p)) -> [String]
compile {main=(C f)} = 
  ["/*\n"
  ,"  Generated code for Arduino\n"
  ,"  Pieter Koopman, pieter@cs.ru.nl\n"
  ,"*/\n"
  ,"\n"
  ,"#define MAX_ARGS 4\n"
  ,"#define MAX_TASKS 20\n"
  ,"#define MAX_TASK_NO MAX_TASKS - 1\n"
  ,"#define NEXT_TASK(n) ((n) == MAX_TASK_NO ? 0 : (n) + 1)\n"
  ,"\n"
  ,"typedef union Arg {\n"
  ,"  int i;\n"
  ,"  bool b;\n"
  ,"  char c;\n"
//  ,"  float f;\n" // requires 4 bytes
  ,"  word w;\n"
  ,"} ARG;\n"
  ,"\n"
  ,"typedef struct Task {\n"
  ,"  byte id;\n"
  ,"  long wait;\n"
  ,"  ARG a[MAX_ARGS];\n"
  ,"} TASK;\n"
  ,"\n"
  ] ++
  foldr (\lib c.["#include <":lib:".h>\n":c]) [] (mkset c.includes) ++
  ["\n// --- variables ---\n"
  ,"TASK tasks[MAX_TASKS];\n"
  ,"byte t0 = 0, tc = 0, tn = 0;\n"
  ,"long delta;\n"
  ,"\n"
  ,"int vInt;\n"
  ,"bool vBool;\n"
  ,"char vChar;\n"
  ,"float vFloat;\n"
  ,"unsigned long time = 0;\n"
  :reverse c.vars
  ] ++
  ["\n// --- functions ---\n"
  ,"byte newTask(byte id, long wait, word a0 = 0, word a1 = 0, word a2 = 0, word a3 = 0) {\n"
  ,"  TASK *tnp = &tasks[tn];\n"
  ,"  tnp->id = id;\n"
  ,"  tnp->wait = wait;\n"
  ,"  tnp->a[0].w = a0;\n"
  ,"  tnp->a[1].w = a1;\n"
  ,"  tnp->a[2].w = a2;\n"
  ,"  tnp->a[3].w = a3;\n"
  ,"  byte r = tn;\n"
  ,"  tn = NEXT_TASK(tn);\n"
  ,"  return r;\n"
  ,"}\n"
  ,"\n"
  ,"byte setDelay(byte t, long d) {\n"
  ,"  tasks[t].wait = d;\n"
  ,"  return t;\n"
  ,"}\n"
  ,"boolean pressed(int b) {\n"
  ,"  pinMode(A0, INPUT);\n"
  ,"  int a0 = analogRead(A0);\n"
  ,"  switch (b) {\n"
  ,"  case 0: return a0 < ",toString RightBound,";       // right\n"
  ,"  case 1: return ",toString RightBound," < a0 && a0 < ",toString UpBound,"; // up\n"
  ,"  case 2: return ",toString UpBound," < a0 && a0 < ",toString DownBound,";// down\n"
  ,"  case 3: return ",toString DownBound," < a0 && a0 < ",toString LeftBound,";//left\n"
  ,"  case 4: return ",toString LeftBound," < a0 && a0 < ",toString SelectBound,";//select\n"
  ,"  default: return ",toString SelectBound," < a0;       //no button\n"
  ,"  }\n"
  ,"}\n"
  ,"boolean pWrite (int pin, boolean b) {\n"
  ,"  pinMode(pin, OUTPUT);\n"
  ,"  digitalWrite(pin, b);\n"
  ,"  return b;\n"
  ,"}\n"
  ,"int pWrite (int pin, int i) {\n"
  ,"  pinMode(pin, OUTPUT);\n"
  ,"  analogWrite(pin, i);\n"
  ,"  return i;\n"
  ,"}\n"
  :reverse c.funs
  ] ++
  ["\n// --- setup --- \n"
  ,"void setup () {\n" 
  ,"  Serial.begin(9600);\n"
  ,"  "
  :reverse c.setup
  ] ++
  ["\n}\n"
  ,"\n// --- loop --- \n"
  ,"void loop () {\n"
  ,"  if (t0 != tn) {\n"
  ,"  if (t0 == tc) {\n"
  ,"    unsigned long time2 = millis();\n"
  ,"    delta = time2 - time;\n"
  ,"    time = time2;\n"
  ,"    tc = tn;\n"
  ,"  };\n"
  ,"  TASK* t0p = &tasks[t0];\n"
  ,"  t0p->wait -= delta;\n"
  ,"  if (t0p->wait > 0L) {\n"
  ,"    newTask(t0p->id, t0p->wait, t0p->a[0].w, t0p->a[1].w, t0p->a[2].w, t0p->a[3].w);\n"
  ,"  } else {\n"
  ,"    switch (t0p->id) {"
  :reverse c.loop
  ] ++
  ["\n"
  ,"    default:\n"
  ,"    Serial.println(\"stopped\");\n"
  ,"    t0 = tn; // no known task: force termination of tasks\n"
  ,"    return;\n"
  ,"    };\n"
  ,"  }\n"
  ,"  t0 = NEXT_TASK(t0);\n"
  ,"  }\n"
  ,"}\n"
  ]
where c = f Rd newCode

mkset :: [a] -> [a] | Eq a
mkset [a:x] = [a:mkset (filter ((<>) a) x)]
mkset [] = []

newCode :: CODE
newCode =
  { fresh   = 0
  , freshMTask = 0
  , funs    = []
  , ifuns   = 0
  , vars    = []
  , ivars   = 0
  , setup   = []
  , isetup  = 1
  , loop    = []
  , iloop   = 4
  , includes  = []
  , def     = Setup
  , mode    = NoReturn
  , binds		= []
  }

// ----- simulation ----- //

eval :: (Main (Eval t p)) -> [String] | toString t
eval {main=(E f)} = [toString (fst (f Rd state0))]

:: State = 
  { tasks :: [(Int, State->State)]
  , store :: [Dyn]
  , dpins :: [(DigitalPin, Bool)]
  , apins :: [(AnalogPin, Int)]
  , serial:: [String]
  , millis:: Int
  }

state0 :: State
state0 = {store = [], tasks = [], serial = [], millis = 0, dpins = [] , apins = []}

//:: TaskSim :== (Int, State->State)
:: Eval t p = E ((ReadWrite t) State -> (t, State))
toS2S :: (Eval t p) -> (State->State)
toS2S (E f) = \state.snd (f Rd state)

unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
unEval (E f) = f

:: ReadWrite t = Rd | Wrt t | Updt (t->t)

(>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
//(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
(>>==) (E f) g = E\r s.let (a,t) = f Rd s in unEval (g a) Rd t

rtrn :: t -> Eval t p
rtrn a = E \r s -> (a, s)

yield :: t (Eval s p) -> Eval t Expr
//yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
yield a (E f) = E \r s.(a,snd (f Rd s))

instance arith Eval where
  lit a = rtrn a
  (+.) x y = x >>==  \a. y >>==  \b. rtrn (a + b)
  (-.) x y = x >>==  \a. y >>==  \b. rtrn (a - b)
  (*.) x y = x >>==  \a. y >>==  \b. rtrn (a * b)
  (/.) x y = x >>==  \a. y >>==  \b. rtrn (a / b)
instance boolExpr Eval where
  (&.) x y = x >>==  \a. if a y (rtrn False) // lazy AND
  (|.) x y = x >>==  \a. if a (rtrn True) (y >>==  rtrn)
  Not x   = x >>==  \a. rtrn (not a)
  (==.) x y = x >>==  \a. y >>==  \b. rtrn (a == b)
  (!=.) x y = x >>==  \a. y >>==  \b. rtrn (a <> b)
  (<.)  x y = x >>==  \a. y >>==  \b. rtrn (a < b)
  (>.)  x y = x >>==  \a. y >>==  \b. rtrn (a > b)
  (<=.)  x y = x >>==  \a. y >>==  \b. rtrn (a <= b)
  (>=.)  x y = x >>==  \a. y >>==  \b. rtrn (a >= b)
instance If Eval p q Expr where
  If  c t e = c >>==  \b.if b (toExpr t) (toExpr e)
instance IF Eval where
  IF  c t e = c >>==  \b.if b (yield () t) (yield () e)
  (?) c t   = c >>==  \b.if b (yield () t) (rtrn ())
instance var2 Eval where
  var2 v f = defEval2 v f
  con2 v f = defEval2 v f

defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
defEval2 v f = 
  {main = E (\r s.(length s.store
          , {s & store = s.store ++ [toDyn v]}))
  >>==  \n.unMain (f (E (read` n)))}
instance sds Eval where
  sds f = defEval f
  con f = defEval f

defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
defEval f = 
  {main = E \r s.let (v In g) = f (E (read` (length s.store))) in
          unEval (unMain g) r {s & store = s.store ++ [toDyn v]}}
instance fun Eval x | arg x where
  fun f = e where (g In e) = f (\a.toExpr (g a))
instance mtask Eval x | arg x where
 task f = e where
  (t In e) = f (\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
instance mtasks Eval x y | arg x & arg y where
 tasks f = e where
  ((t,u) In e) = 
   f ((\d a.long d >>== \(L i).E\r s.(MTask (length s.tasks),{s&tasks=[(i,toS2S (t a)):s.tasks]}))
   ,(\d b.long d >>== \(L j).E\r s.(MTask (length s.tasks),{s&tasks=[(j,toS2S (u b)):s.tasks]}))
   )
instance setDelay Eval where
  setDelay d t = d >>==  \(L x). t >>==  \(MTask n).E \r s.(MTask n,{s & tasks = updateAt n (x,snd (s.tasks !! n)) s.tasks})
class toExpr v where toExpr :: (v t p) -> v t Expr
instance toExpr Eval where toExpr (E f) = E f
instance toExpr Code where toExpr (C f) = C f
instance seq Eval where
  (>>=.) x f = x >>==   f o rtrn
  (:.) x y = x >>==  \_. y
instance assign Eval where
  (=.) (E v) e = e >>==  \a. E \r s.v (Wrt a) s
instance output Eval where
  output x = x >>==  \a.E \r s.((),{s & serial = s.serial ++ [toCode a]})
instance pinMode Eval where
  pinmode p m = rtrn ()
instance digitalIO Eval where
  digitalRead  p   = E \rw s=:{dpins, apins}.(readPinD p dpins apins, s)
  digitalWrite p b = b >>== \a. E \rw s.(a, writePinD p a s)
instance analogIO Eval where
  analogRead  p   = E \rw s=:{apins}. (readPinA p apins, s)
  analogWrite p b = b >>== \a. E \rw s.(a, writePinA p a s)
instance noOp Eval where noOp = E \r s.(undef,s)

class arg x :: x -> Int
instance arg () where arg _ = 0
instance arg (Eval t p) | type t where arg _ = 1
instance arg (Eval t p, Eval u q) | type t & type u where arg _ = 2
instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v where arg _ = 3
instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v where arg _ = 4

instance + String where (+) x y = x +++ y

readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
readPinA p lista
  = case [b \\ (q, b) <- lista | p == q] of
  []  = 0
  [a:x] = a

writePinA :: AnalogPin Int State -> State
writePinA p x s
  = {s & apins = [(p, x):[(q, y) \\ (q, y) <- s.apins | p <> q]]}

class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
instance readPinD DigitalPin where
  readPinD p listd lista
  = case [b \\ (q,b) <- listd | p == q] of
    [] = False
    [a:x] = a
instance readPinD AnalogPin where
  readPinD p listd lista
  = case [b \\ (q,b) <- lista | p == q] of
    [] = False
    [a:x] = a <> 0
class writePinD p :: p Bool State -> State
instance writePinD DigitalPin where
  writePinD p b s=:{dpins} = {s & dpins = [(p, b):[(q, c) \\ (q, c) <- dpins | p <> q]]}
instance writePinD AnalogPin where
  writePinD p b s=:{apins} = {s & apins = [(p, if b 1 0):[(q, c) \\ (q, c) <- apins | p <> q]]}


// ----- Interactive Simulation ----- //

derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin

simulate :: (Main (Eval a p)) -> Task ()
simulate {main=(E f)} = setup state0 where
  setup s =
	  updateInformation "State" [] (toView s)
	  >>* [ OnAction ActionFinish (always shutDown)
	    , OnAction (Action "setup" []) (hasValue 
	      (\si.simloop (snd (f Rd (mergeView s si)))))
	    ]
  simloop s =
	  updateInformation "State" [] (toView s)
	  >>* [ OnAction ActionFinish (always shutDown)
	    , OnAction (Action "clear serial" []) (always (simloop {s & serial = []}))
	    , OnAction ActionNew (always (setup state0))
	    : if (isEmpty s.tasks)
	        []
	        [OnAction (Action "loop" []) (hasValue
	      \si.simloop (step` (mergeView s si)))
	      ]
	    ]

toView :: State -> StateInterface
toView s = 
  { serialOut = Display s.serial
  , analogPins = s.apins
  , digitalPins = s.dpins
  , var2iables = map toDisplayVar s.store
  , timer = s.millis
  , taskCount = Display (length s.tasks)
  }

mergeView :: State StateInterface -> State
mergeView s si = 
  { s
  & store = [fromDisplayVar new old \\ new <- si.var2iables & old <- s.store]
  , dpins = si.digitalPins
  , apins = si.analogPins
//  , serial = si.serialOut
  , millis = si.timer
  }

:: StateInterface =
  { serialOut   :: Display [String]
  , analogPins  :: [(AnalogPin, Int)]
  , digitalPins :: [(DigitalPin, Bool)]
  , var2iables   :: [DisplayVar]
  , timer     :: Int
  , taskCount   :: Display Int
  }

toDisplayVar :: Dyn -> DisplayVar
toDisplayVar (Dyn [v])
    # i = toInt v
    | toString i == v
        = INT i
        = Variable v
toDisplayVar (Dyn ["L",v]) = LONG (toInt v)
toDisplayVar (Dyn ["Servo",pinKind,pin,pos]) = Servo (fromJust (fromDyn (Dyn [pinKind,pin]))) (toInt pos)
toDisplayVar (Dyn ["LCD",_,_,_,_,_,l1,_,l2,_]) = LCD16x2 l1 l2
toDisplayVar (Dyn l) = DisplayVar l

fromDisplayVar :: DisplayVar Dyn -> Dyn
fromDisplayVar (Variable v)  dyn = Dyn [v]
fromDisplayVar (INT v)     dyn = Dyn [toString v]
fromDisplayVar (LONG v)    dyn = Dyn ["L",toString v]
fromDisplayVar (Servo pin pos) dyn = Dyn (["Servo":let (Dyn p) = toDyn pin in p] ++ [toString pos])
fromDisplayVar (LCD16x2 l1 l2) (Dyn list) = Dyn (updateAt 6 l1 (updateAt 8 l2 list))
fromDisplayVar (DisplayVar l)  dyn = Dyn l

:: DisplayVar
    = Variable String
    | INT Int
    | LONG Int
    | Servo Pin Int
    | LCD16x2 String String
    | DisplayVar [String]


step` :: State -> State
step` s = 
  foldr appTask {s & millis = s.millis + delta, tasks = []}
    [(w - delta, f) \\ (w, f) <- s.tasks]
where delta = foldl1 min (map fst s.tasks) // smallest wait

appTask t=:(w,f) s | w <= 0
  = f s
  = {s & tasks = [t:s.tasks]}

foldl1 op [a:x] = foldl op a x
foldr1 op l :== foldr l
  where
    foldr [a]     = a
    foldr [a:x] = op a (foldr x)

class stringQuotes t | type t :: (Code t p) -> Code t p
instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\""
instance stringQuotes t    where stringQuotes x = x


derive   toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo
instance toCode () where toCode _ = ""
instance ==   () where (==) _ _ = True

// ----- long ----- //

:: Long = L Int // 32 bit on Arduino
instance toCode Long where toCode (L i) = toCode i + "L"
instance + Long where (+) (L x) (L y) = L (x + y)
instance - Long where (-) (L x) (L y) = L (x + y)
instance * Long where (*) (L x) (L y) = L (x + y)
instance / Long where (/) (L x) (L y) = L (x + y)
instance == Long where (==) (L x) (L y) = x == y
instance one Long where one = L one
instance zero Long where zero = L zero
now = lit (L 0)

class long v t :: (v t p) -> v Long Expr | isExpr p
instance long Code Int where
  long x = embed (c "long" +.+ brac x)
instance long Code Long where
  long x = embed (c "long" +.+ brac x)
instance long Eval Int where
  long x = x >>== rtrn o L
instance long Eval Long where
  long (E x) = E x

// ----- tools ----- //

class toCode a :: a -> String
instance toCode Bool where toCode b = if b "true" "false"
instance toCode Int where toCode a = toString a
instance toCode Real where toCode a = toString a
instance toCode Char where
  toCode '\0' = "'\\0'"
  toCode '\n' = "'\\n'"
  toCode '\\' = "\\"
  toCode a = "'" + toString a + "'"
instance toCode String where toCode s = s
instance toCode DigitalPin where toCode x = s%(1, size s - 1) where s = consName{|*|} x
instance toCode AnalogPin  where toCode x = consName{|*|} x
derive consName DigitalPin, AnalogPin, PinMode

instance == DigitalPin where (==) x y = x === y
instance == AnalogPin   where (==) x y = x === y

derive consIndex DigitalPin, AnalogPin

tab =: toString (repeatn tabSize ' ')
tabSize :== 2

instance toString () where toString _ = "()"