mTaskInterpret.icl

   1 implementation module mTaskInterpret
   2
   3 //import iTasks
   4 import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
   5 import GenPrint
   6 import StdEnum
   7 import mTask
   8
   9 import StdFile
  10 import StdString
  11
  12 from StdFunc import o, const
  13 import StdBool
  14 import StdTuple
  15 import Data.Tuple
  16 import Data.Monoid
  17 import Data.Functor
  18 import StdList
  19 from Data.Func import $
  20 from Text import class Text(concat,join,toUpperCase), instance Text String
  21
  22 toByteVal :: BC -> [Char]
  23 toByteVal b
  24 # bt = toBC b
  25 = [bt:case b of
  26                 (BCPush i) = i
  27                 (BCAnalogRead i) = [toChar i]
  28                 (BCAnalogWrite i) = [toChar i]
  29                 (BCDigitalRead i) = [toChar i]
  30                 (BCDigitalWrite i) = [toChar i]
  31                 (BCJmp i) = [toChar i]
  32                 (BCJmpT i) = [toChar i]
  33                 (BCJmpF i) = [toChar i]
  34                 _ = []]
  35         where
  36                 toBC b = toChar $ consIndex{|*|} b + 1
  37
  38 instance Semigroup (ByteCode a p) where
  39         mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
  40
  41 instance Monoid (ByteCode a p) where
  42         mempty = retrn []
  43
  44 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
  45 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
  46
  47 (<+->) infixr 1
  48 (<+->) m n :== m <++> retrn n
  49
  50 runBC (BC m) = m
  51
  52 retrn :: ([BC] -> ByteCode a p)
  53 retrn = BC o tuple
  54
  55 instance toByteCode Bool where
  56         toByteCode True = [toChar 1]
  57         toByteCode False = [toChar 0]
  58 instance toByteCode Int where toByteCode n = map toChar [n/(2<<7),n rem 265]
  59 instance toByteCode Long where toByteCode (L n) = toByteCode n
  60 instance toByteCode Char where toByteCode c = [c]
  61 instance toByteCode String where toByteCode s = undef
  62 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
  63
  64 instance toChar Pin where
  65         toChar (Digital p) = toChar $ consIndex{|*|} p + 1
  66         toChar (Analog p) = toChar $ consIndex{|*|} p + 1
  67
  68 derive gPrint BC, AnalogPin, Pin, DigitalPin
  69 derive consIndex BC, Pin, Button
  70 derive consName BC, Pin, Button
  71
  72 instance arith ByteCode where
  73         lit x = retrn [BCPush $ toByteCode x]
  74         (+.) x y = x <++> y <+-> [BCAdd]
  75         (-.) x y = x <++> y <+-> [BCSub]
  76         (*.) x y = x <++> y <+-> [BCMul]
  77         (/.) x y = x <++> y <+-> [BCDiv]
  78
  79 instance boolExpr ByteCode where
  80         (&.) x y = x <++> y <+-> [BCAnd]
  81         (|.) x y = x <++> y <+-> [BCOr]
  82         Not x = x <+-> [BCNot]
  83         (==.) x y = x <++> y <+-> [BCEq]
  84         (!=.) x y = x <++> y <+-> [BCNeq]
  85         (<.) x y = x <++> y <+-> [ BCLes]
  86         (>.)  x y = x <++> y <+-> [BCGre]
  87         (<=.) x y = x <++> y <+-> [BCLeq]
  88         (>=.) x y = x <++> y <+-> [BCGeq]
  89
  90 instance analogIO ByteCode where
  91         analogRead p = retrn [BCAnalogRead $ pin p]
  92         analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
  93
  94 instance digitalIO ByteCode where
  95         digitalRead p = retrn [BCDigitalRead $ pin p]
  96         digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
  97
  98 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
  99 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 100 instance If ByteCode Stmt Stmt e where If b t e = BCIfStmt b t e
 101 instance If ByteCode x y Expr where If b t e = BCIfStmt b t e
 102 instance IF ByteCode where
 103         IF b t e = BCIfStmt b t e
 104         (?) b t = BCIfStmt b t $ retrn []
 105 BCIfStmt b t e = withLabel \else->withLabel \endif->retrn [BCJmpF else] <++> t
 106         <++> retrn [BCJmp endif] <++> e <++> retrn [BCLab endif]
 107
 108 instance noOp ByteCode where noOp = mempty
 109
 110
 111 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
 112 withLabel f = BC \s->let [fresh:fs] = s.freshl
 113         in runBC (f fresh) {s & freshl=fs}
 114
 115 /*
 116 instance sds ByteCode where
 117         sds f = undef/*{main =
 118                         let var = 42
 119                             (v In body) = f var
 120                         in unMain body
 121                 }*/
 122         con f = undef
 123 */
 124
 125 instance serial ByteCode where
 126         serialAvailable = retrn [BCSerialAvail]
 127         serialPrint s = retrn [BCSerialPrint]
 128         serialPrintln s = retrn [BCSerialPrintln]
 129         serialRead = retrn [BCSerialRead]
 130         serialParseInt = retrn [BCSerialParseInt]
 131
 132 instance zero BCState where
 133         zero = {freshl=[1..]}
 134
 135 toRealByteCode :: (ByteCode a Expr) -> String
 136 toRealByteCode x
 137 # (bc, st) = runBC x zero
 138 = concat $ map (toString o toByteVal) bc
 139
 140 toReadableByteCode :: (ByteCode a Expr) -> String
 141 toReadableByteCode x
 142 # (bc, st) = runBC x zero
 143 = join "\n" $ map printToString bc
 144
 145 toReadableByteVal :: BC -> String
 146 toReadableByteVal a = printToString a
 147
 148
 149 Start :: String
 150 Start = toReadableByteCode bc
 151         where
 152                 bc :: ByteCode Int Expr
 153                 bc = (lit 36 +. lit 42) +. lit 44
 154
 155 //to16bit :: Int -> String
 156 //to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
 157 //
 158 ////Run test programma en pretty print
 159 ////Start :: String
 160 ////Start = "t" +++ to16bit (size b) +++ b
 161 //Start :: Main (ByteCode Int Expr)
 162 //Start = bc
 163 //      where
 164 //              bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
 165 //              b = toRealByteCode bc
 166 //Start :: ByteCode Int Expr
 167 //Start = If (lit True) (analogRead A1) (analogRead A0)
 168 //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)