mTask.dcl

   1 definition module mTask
   2
   3 /*
   4     Pieter Koopman pieter@cs.ru.nl
   5     Final version for TFP2016
   6
   7     -2: assignment =. suited for digital and analog input and output
   8     -3: ad hoc tasks
   9
  10 todo:
  11         move task-loop ti setup()
  12         adhoc tasks
  13         task combinators
  14         imporove setp: >>*.
  15 */
  16
  17 //import iTasks
  18 import iTasks._Framework.Generic
  19 import iTasks._Framework.Task
  20 import StdClass
  21 from iTasks.API.Core.Types import :: Display
  22 import gdynamic, gCons, GenEq, StdMisc, StdArray
  23
  24 import mTaskSerial, mTaskLCD
  25
  26 // =================== mTask ===================
  27
  28
  29 // ----- dsl definition ----- //
  30
  31 :: DigitalPin
  32    = D0 | D1 | D2 | D3 | D4 | D5 |D6 | D7 | D8 | D9 | D10 | D11 | D12 | D13
  33 :: AnalogPin = A0 | A1 | A2 | A3 | A4 | A5
  34 :: PinMode   = INPUT | OUTPUT | INPUT_PULLUP
  35 :: Pin     = Digital DigitalPin | Analog AnalogPin
  36 instance toCode Pin
  37
  38 class pin p | type, == p where
  39   pin :: p -> Pin
  40 instance pin DigitalPin
  41 instance pin AnalogPin
  42
  43 :: Upd   = Upd
  44 :: Expr  = Expr
  45 :: Stmt  = Stmt
  46 :: MTask = MTask Int // String
  47
  48 class isExpr a :: a -> Int
  49 instance isExpr Upd
  50 instance isExpr Expr
  51
  52 class isStmt a :: a -> Int
  53 instance isStmt Upd
  54 instance isStmt Expr
  55 instance isStmt Stmt
  56
  57 instance == MTask
  58 instance toCode MTask
  59
  60 :: Main a = {main :: a}
  61
  62 unMain :: (Main x) -> x
  63
  64 class arith v where
  65   lit :: t -> v t Expr | toCode t
  66   (+.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, +, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  67   (-.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, -, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  68   (*.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, *, zero, one t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  69   (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, / t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  70 class boolExpr v where
  71   (&.) infixr 3 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  72   (|.) infixr 2 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  73   Not           :: (v Bool p) -> v Bool Expr | isExpr p //& toExpr2 p
  74   (==.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  75   (!=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | ==, toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  76   (<.)  infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord,  toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  77   (>.)  infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord,  toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  78   (<=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord,  toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  79   (>=.) infix 4 :: (v a p) (v a q) -> v Bool Expr | <, Ord,  toCode a & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
  80 // using functional dependencies
  81 class If v q r ~s where
  82   If :: (v Bool p) (v t q) (v t r) -> v t s | isExpr p & type t
  83 class IF v where
  84   IF :: (v Bool p) (v t q) (v s r) -> v () Stmt | isExpr p
  85   (?) infix 1 :: (v Bool p) (v t q) -> v () Stmt | isExpr p
  86 class var2 v where
  87   var2 :: t ((v t Upd)->(Main (v c s))) -> (Main (v c s)) | type, toCode t
  88   con2 :: t ((v t Expr)  ->(Main (v c s))) -> (Main (v c s)) | type t
  89 class sds v where
  90   sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, toCode t
  91   con :: ((v t Expr)  ->In t (Main (v c s))) -> (Main (v c s)) | type t
  92 class seq v where
  93   (>>=.) infixr 0 :: (v t p) ((v t Expr) -> (v u q)) -> (v u Stmt) | type t & type u
  94   (:.) infixr 0 :: (v t p) (v u q) -> v u Stmt | type t & type u
  95 class step` v where
  96     (>>*.) infixl 1 :: (v t p) ((v t Expr) -> [Step v u]) -> v u Stmt | type t & type u
  97 :: Step v t = E.p.q: Cond (v Bool q) (v t p) | E.p: Ever (v t p)
  98 class assign v where
  99   (=.) infixr 2 :: (v t Upd) (v t p) -> v t Expr | type t & isExpr p
 100 class fun v t where
 101   fun :: ((t->v s Expr)->In (t->v s p) (Main (v u q))) -> Main (v u q) | type s
 102 class mtask v a where
 103   task :: (((v delay r) a->v MTask Expr)->In (a->v u p) (Main (v t q))) -> Main (v t q) | type t & type u & isExpr r & long v delay
 104 class lag v where
 105   lag :: (v delay r) (v t p) -> v MTask Expr | type t & long v delay
 106 class setDelay v where
 107   setDelay :: (v Long p) (v MTask Expr) -> (v MTask Expr) | isExpr p
 108 class mtasks v a b where
 109   tasks :: (((v delay r1) a->v MTask Expr, (v delay r2) b->v MTask Expr)->In (a->v t p, b->v u p) (Main (v s q))) -> Main (v s q) | type s & isExpr r1 & isExpr r2 & long v delay
 110 class output v where
 111   output :: (v t p) -> v () Expr | type t & isExpr p
 112 class noOp v where noOp :: v t p
 113
 114 class pinMode v where
 115   pinmode :: p PinMode -> v () Expr | pin p
 116 class digitalIO v where
 117   digitalRead  :: p -> v Bool Expr | pin, readPinD p
 118   digitalWrite :: p (v Bool q) -> v Bool Expr | pin, writePinD  p
 119 class analogIO v where
 120   analogRead  :: AnalogPin -> v Int Expr
 121   analogWrite :: AnalogPin (v Int p) -> v Int Expr
 122 class dIO v where
 123     dIO :: p -> v Bool Upd | pin, readPinD p
 124 class aIO v where
 125     aIO :: AnalogPin -> v Int Upd
 126 class time v where
 127   delay  :: (v Long p) -> (v Long Expr)
 128   millis ::         (v Long Expr)
 129
 130 class pio p t where pio :: p -> v t Upd | aIO v & dIO v
 131 instance pio AnalogPin Int
 132 instance pio AnalogPin Bool
 133 instance pio DigitalPin Bool
 134
 135 int :: (v Int p) -> (v Int p)
 136 bool :: (v Bool p) -> (v Bool p)
 137 char :: (v Char p) -> (v Char p)
 138
 139 class type t | showType, dyn, toCode, ==, type2string, varName t
 140 class type2string t :: t -> String
 141 instance type2string Int
 142 instance type2string Long
 143 instance type2string Real
 144 instance type2string Bool
 145 instance type2string Char
 146 instance type2string MTask
 147 instance type2string DigitalPin
 148 instance type2string AnalogPin
 149 instance type2string String
 150 instance type2string ()
 151 class varName a :: a -> String
 152 instance varName Int
 153 instance varName Long
 154 instance varName Bool
 155 instance varName Char
 156 instance varName Real
 157 instance varName x
 158
 159 class dsl t | arith, boolExpr, sds, assign, seq t
 160
 161 argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a
 162
 163 class argTypes t :: ((t->Code b Expr)->In (t->Code b2 q) (Main (Code c s))) -> t
 164 instance argTypes (Code a p) | showType a
 165 instance argTypes (Code a p, Code b q) | showType a & showType b
 166 instance argTypes (Code a p, Code b q, Code c r) | showType a & showType b & showType c
 167
 168 resType :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> Code b q | showType b
 169
 170 var2Type :: (Code t p) -> Code t p | showType t
 171
 172 resType2 :: ((t->Code b Expr)->In (t->Code b q) (Main (Code c s))) -> SV b | showType2 b
 173
 174 :: SV t = SV String
 175 instance toCode (SV t)
 176
 177 class showType2 t :: SV t
 178 instance showType2 ()
 179 instance showType2 Int
 180 instance showType2 Char
 181 instance showType2 Bool
 182 instance showType2 a
 183
 184 class showType t | showType2 /*, type*/ t :: (Code t p)
 185 instance showType ()
 186 instance showType Int
 187 instance showType Long
 188 instance showType Char
 189 instance showType Bool
 190 instance showType a
 191
 192 class typeSelector t | showType2, type t :: (Code t p)
 193 instance typeSelector Int
 194 instance typeSelector Char
 195 instance typeSelector Bool
 196 instance typeSelector a
 197
 198 :: In a b = In infix 0 a b
 199
 200 read` :: Int (ReadWrite a) State -> (a,State) | dyn a
 201
 202 // ----- code generation ----- //
 203
 204 instance arith Code
 205 instance boolExpr Code
 206 instance If Code Stmt Stmt Stmt
 207 instance If Code e    Stmt Stmt
 208 instance If Code Stmt e    Stmt
 209 instance If Code x    y    Expr
 210 instance IF Code
 211 instance sds Code
 212
 213 defCode :: ((Code t p) -> In t (Main (Code u q))) -> Main (Code u r) | type t
 214
 215 var :: String (ReadWrite (Code v q)) CODE -> CODE
 216
 217 instance assign Code
 218 instance seq Code
 219 instance step` Code
 220 codeSteps :: [Step Code t] -> Code u p
 221 optBreak :: Mode -> Code u p
 222
 223 instance setDelay Code
 224 instance mtask Code a | taskImp2 a & types a
 225 instance mtasks Code a b | taskImp2 a & types a  & taskImp2 b & types b
 226
 227 loopCode :: Int (Code a b) -> Code c d
 228
 229 class taskImp2 a :: Int a -> ((Code Long p) a->Code MTask Expr, a) | /*long Code delay &*/ isExpr p
 230 instance taskImp2 ()
 231 instance taskImp2 (Code t p)
 232 instance taskImp2 (Code a p, Code b q)
 233 instance taskImp2 (Code a p, Code b q, Code c r)
 234 instance taskImp2 (Code a p, Code b q, Code c r, Code d s)
 235
 236 class taskImp a :: Int a -> (Int a->Code MTask Expr, a)
 237 instance taskImp ()
 238 instance taskImp (Code t p)
 239 instance taskImp (Code a p, Code b q)
 240 instance taskImp (Code a p, Code b q, Code c r)
 241 instance taskImp (Code a p, Code b q, Code c r, Code d s)
 242
 243 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
 244 class types a :: a
 245 instance types ()
 246 instance types (Code a p) | typeSelector a & isExpr p
 247 instance types (Code a p, Code b q) | typeSelector a & isExpr p & typeSelector b & isExpr q
 248 instance types (Code a p, Code b q, Code c r) | typeSelector a & isExpr p & typeSelector b & isExpr q & typeSelector c & isExpr r
 249 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
 250
 251 codeMTaskBody :: (Code v w) (Code c d) -> Code e f
 252 instance fun Code ()
 253 instance fun Code (Code t p) | type, showType t & isExpr p
 254 instance fun Code (Code a p, Code b q) | showType a & showType b
 255 instance fun Code (Code a p, Code b q, Code c r) | showType a & showType b & showType c
 256 instance output Code
 257 instance pinMode Code
 258 instance digitalIO Code
 259 instance dIO Code
 260 instance aIO Code
 261 instance analogIO Code
 262 instance noOp Code
 263
 264 :: Code a p = C ((ReadWrite (Code a Expr)) CODE -> CODE)
 265 :: CODE =
 266   { fresh       :: Int
 267   , freshMTask :: Int
 268   , funs        :: [String]
 269   , ifuns                       :: Int
 270   , vars          :: [String]
 271   , ivars                       :: Int
 272   , setup                       :: [String]
 273   , isetup        :: Int
 274   , loop          :: [String]
 275   , iloop                       :: Int
 276   , includes  :: [String]
 277   , def           :: Def
 278   , mode          :: Mode
 279   , binds                       :: [String]
 280   }
 281
 282 unC :: (Code a p) -> ((ReadWrite (Code a Expr)) CODE -> CODE)
 283
 284 :: Def = Var | Fun | Setup | Loop
 285 :: Mode = /*MainMode |*/ NoReturn | Return String | SubExp | Assign String
 286
 287 setMode :: Mode -> Code a p
 288 getMode :: (Mode -> Code a p) -> Code a p
 289 embed :: (Code a p) -> Code a p
 290 (+.+) infixl 5 :: (Code a p) (Code b q) -> Code c r
 291 fresh :: (Int -> (Code a p)) -> (Code a p)
 292 freshMTask :: (Int -> (Code a p)) -> (Code a p)
 293 setCode :: Def -> (Code a p)
 294 getCode :: (Def -> Code a p) -> (Code a p)
 295 brac :: (Code a p) -> Code b q
 296 funBody :: (Code a p) -> Code b q
 297 codeOp2 :: (Code a p) String (Code b q) -> Code c r
 298 include :: String -> Code a b
 299 argList :: [a] -> String | toCode a
 300 c :: a -> Code b p | toCode a
 301 indent :: Code a p
 302 unindent :: Code a p
 303 nl :: Code a p
 304 setBinds :: [String] -> Code a p
 305 addBinds :: String -> Code a p
 306 getBinds :: ([String] -> Code a p) -> (Code a p)
 307
 308 // ----- driver ----- //
 309
 310 compile :: (Main (Code a p)) -> [String]
 311 mkset :: [a] -> [a] | Eq a
 312 newCode :: CODE
 313
 314 // ----- simulation ----- //
 315
 316 eval :: (Main (Eval t p)) -> [String] | toString t
 317 :: State =
 318   { tasks :: [(Int, State->State)]
 319   , store :: [Dyn]
 320   , dpins :: [(DigitalPin, Bool)]
 321   , apins :: [(AnalogPin, Int)]
 322   , serial:: [String]
 323   , millis:: Int
 324   }
 325
 326 state0 :: State
 327
 328 //:: TaskSim :== (Int, State->State)
 329 :: Eval t p = E ((ReadWrite t) State -> (t, State))
 330 toS2S :: (Eval t p) -> (State->State)
 331
 332 unEval :: (Eval t p) -> ((ReadWrite t) State -> (t, State))
 333
 334 :: ReadWrite t = Rd | Wrt t | Updt (t->t)
 335
 336 (>>==) infixl 1 :: (Eval a p) (a -> Eval b q) -> Eval b r
 337 //(>>== ) (E f) g = E \r s. let (a, s2) = f Rd s; (E h) = g a in h Rd s2
 338
 339 rtrn :: t -> Eval t p
 340
 341 yield :: t (Eval s p) -> Eval t Expr
 342 //yield a (E f) = E (\r s.(\(_,t).(a,t)) (f r s))
 343
 344 instance arith Eval
 345 instance boolExpr Eval
 346 instance If Eval p q Expr
 347 instance IF Eval
 348 instance var2 Eval
 349
 350 defEval2 :: t ((Eval t p)->Main (Eval u q)) -> (Main (Eval u q)) | dyn t
 351 instance sds Eval
 352
 353 defEval :: ((Eval t p)->In t (Main (Eval u q))) -> (Main (Eval u q)) | dyn t
 354 instance fun Eval x | arg x
 355 instance mtask Eval x | arg x
 356 instance mtasks Eval x y | arg x & arg y
 357 instance setDelay Eval
 358
 359 class toExpr v where toExpr :: (v t p) -> v t Expr
 360 instance toExpr Eval
 361 instance toExpr Code
 362 instance seq Eval
 363 instance assign Eval
 364 instance output Eval
 365 instance pinMode Eval
 366 instance digitalIO Eval
 367 instance analogIO Eval
 368 instance noOp Eval
 369
 370 class arg x :: x -> Int
 371 instance arg ()
 372 instance arg (Eval t p) | type t
 373 instance arg (Eval t p, Eval u q) | type t & type u
 374 instance arg (Eval t p, Eval u q, Eval v r) | type t & type u & type v
 375 instance arg (Eval t p, Eval u q, Eval v r, Eval w s) | type t & type u & type v
 376
 377 instance + String
 378
 379 readPinA :: AnalogPin [(AnalogPin, Int)] -> Int
 380 writePinA :: AnalogPin Int State -> State
 381
 382 class readPinD p :: p [(DigitalPin,Bool)] [(AnalogPin,Int)] -> Bool
 383 instance readPinD DigitalPin
 384 instance readPinD AnalogPin
 385
 386 class writePinD p :: p Bool State -> State
 387 instance writePinD DigitalPin
 388 instance writePinD AnalogPin
 389
 390 // ----- Interactive Simulation ----- //
 391
 392 derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
 393
 394 simulate :: (Main (Eval a p)) -> Task ()
 395 toView :: State -> StateInterface
 396 mergeView :: State StateInterface -> State
 397 :: StateInterface =
 398   { serialOut   :: Display [String]
 399   , analogPins  :: [(AnalogPin, Int)]
 400   , digitalPins :: [(DigitalPin, Bool)]
 401   , var2iables   :: [DisplayVar]
 402   , timer     :: Int
 403   , taskCount   :: Display Int
 404   }
 405
 406 toDisplayVar :: Dyn -> DisplayVar
 407 fromDisplayVar :: DisplayVar Dyn -> Dyn
 408 :: DisplayVar
 409     = Variable String
 410     | INT Int
 411     | LONG Int
 412     | Servo Pin Int
 413     | LCD16x2 String String
 414     | DisplayVar [String]
 415
 416 step` :: State -> State
 417
 418 class stringQuotes t | type t :: (Code t p) -> Code t p
 419 instance stringQuotes String
 420 instance stringQuotes t
 421
 422 derive   toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
 423 derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo
 424 instance toCode ()
 425 instance ==   ()
 426
 427 // ----- long ----- //
 428
 429 :: Long = L Int // 32 bit on Arduino
 430 instance toCode Long
 431 instance + Long
 432 instance - Long
 433 instance * Long
 434 instance / Long
 435 instance == Long
 436 instance one Long
 437 instance zero Long
 438
 439 class long v t :: (v t p) -> v Long Expr | isExpr p
 440 instance long Code Int
 441 instance long Code Long
 442 instance long Eval Int
 443 instance long Eval Long
 444
 445 // ----- tools ----- //
 446
 447 class toCode a :: a -> String
 448 instance toCode Bool
 449 instance toCode Int
 450 instance toCode Real
 451 instance toCode Char
 452 instance toCode String
 453 instance toCode DigitalPin
 454 instance toCode AnalogPin
 455 derive consName DigitalPin, AnalogPin, PinMode
 456
 457 instance == DigitalPin
 458 instance == AnalogPin
 459
 460 derive consIndex DigitalPin, AnalogPin
 461
 462 tab =: toString (repeatn tabSize ' ')
 463 tabSize :== 2
 464
 465 instance toString ()
 466
 467 a0 :== pio A0
 468 a1 :== pio A1
 469 a2 :== pio A2
 470 a3 :== pio A3
 471 a4 :== pio A4
 472 a5 :== pio A5
 473
 474 d0 :== pio D0
 475 d1 :== pio D1
 476 d2 :== pio D2
 477 d3 :== pio D3
 478 d4 :== pio D4
 479 d5 :== pio D5
 480 d6 :== pio D6
 481 d7 :== pio D7
 482 d8 :== pio D8
 483 d9 :== pio D9
 484 d10 :== pio D10
 485 d11 :== pio D11
 486 d12 :== pio D12
 487 d13 :== pio D13