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 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
 116 withSDS f = BC \s->let [fresh:fs] = s.freshs
 117         in runBC (f fresh) {s & freshs=fs}
 118
 119 instance sds ByteCode where
 120 //      sds f = {main = withSDS \sds->
 121 //                      let (v In body) = f sds
 122 //                      in retrn [BCSdsStore sds]
 123 //              }
 124         sds f = abort "undef on sds"
 125         con f = undef
 126
 127 instance assign ByteCode where
 128         (=.) v e = e <++> v
 129
 130 instance serial ByteCode where
 131         serialAvailable = retrn [BCSerialAvail]
 132         serialPrint s = retrn [BCSerialPrint]
 133         serialPrintln s = retrn [BCSerialPrintln]
 134         serialRead = retrn [BCSerialRead]
 135         serialParseInt = retrn [BCSerialParseInt]
 136
 137 instance zero BCState where
 138         zero = {freshl=[1..], freshs=[1..]}
 139
 140 toRealByteCode :: (ByteCode a Expr) -> String
 141 toRealByteCode x
 142 # (bc, st) = runBC x zero
 143 = concat $ map (toString o toByteVal) bc
 144
 145 toReadableByteCode :: (ByteCode a Expr) -> String
 146 toReadableByteCode x
 147 # (bc, st) = runBC x zero
 148 = join "\n" $ map printToString bc
 149
 150 toReadableByteVal :: BC -> String
 151 toReadableByteVal a = printToString a
 152
 153
 154 //Start :: String
 155 //Start = toReadableByteCode bc
 156 //      where
 157 //              bc :: ByteCode Int Expr
 158 //              bc = (lit 36 +. lit 42) +. lit 44
 159
 160 Start :: String
 161 Start = toReadableByteCode $ unMain bc
 162         where
 163                 bc :: Main (ByteCode Int Expr)
 164                 bc = sds \x=46 In {main = x =. x +. lit 31}
 165
 166 //to16bit :: Int -> String
 167 //to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
 168 //
 169 ////Run test programma en pretty print
 170 ////Start :: String
 171 ////Start = "t" +++ to16bit (size b) +++ b
 172 //Start :: Main (ByteCode Int Expr)
 173 //Start = bc
 174 //      where
 175 //              bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
 176 //              b = toRealByteCode bc
 177 //Start :: ByteCode Int Expr
 178 //Start = If (lit True) (analogRead A1) (analogRead A0)
 179 //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)