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 = toChar $ consIndex{|*|} b + 1
  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
  36 instance Semigroup (ByteCode a p) where
  37         mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
  38
  39 instance Monoid (ByteCode a p) where
  40         mempty = retrn []
  41
  42 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
  43 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
  44
  45 (<+->) infixr 1
  46 (<+->) m n :== m <++> retrn n
  47
  48 runBC (BC m) = m
  49
  50 retrn :: ([BC] -> ByteCode a p)
  51 retrn = BC o tuple
  52 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a p
  53 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
  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/256,n rem 256]
  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, BCState
  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 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
 111 withLabel f = BC \s->let [fresh:fs] = s.freshl
 112         in runBC (f fresh) {s & freshl=fs}
 113
 114 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
 115 withSDS f = BC \s->let [fresh:fs] = s.freshs
 116         in runBC (f fresh) {s & freshs=fs}
 117
 118 instance sds ByteCode where
 119         sds f = {main = withSDS \sds->
 120                         let (v In body) = f $ retrn [BCSdsFetch sds]
 121                         in retrn [BCPush $ toByteCode v,BCSdsStore sds] <++> unMain body
 122                 }
 123         con f = undef
 124
 125 instance assign ByteCode where
 126         (=.) v e = e <++> fmp makeStore v
 127
 128 makeStore [] = []
 129 makeStore [x:xs] = case x of
 130         BCSdsFetch i = [BCSdsStore i:xs]
 131         y = [y:xs]
 132
 133 instance seq ByteCode where
 134         (>>=.) _ _ = abort "undef on >>=."
 135         (:.) x y = x <++> y
 136
 137 instance serial ByteCode where
 138         serialAvailable = retrn [BCSerialAvail]
 139         serialPrint s = retrn [BCSerialPrint]
 140         serialPrintln s = retrn [BCSerialPrintln]
 141         serialRead = retrn [BCSerialRead]
 142         serialParseInt = retrn [BCSerialParseInt]
 143
 144 instance zero BCState where
 145         zero = {freshl=[1..], freshs=[1..]}
 146
 147 toRealByteCode :: (ByteCode a Expr) -> String
 148 toRealByteCode x
 149 # (bc, st) = runBC x zero
 150 = concat $ map (toString o toByteVal) bc
 151
 152 toReadableByteCode :: (ByteCode a Expr) -> String
 153 toReadableByteCode x
 154 # (bc, st) = runBC x zero
 155 = join "\n" $ map printToString bc
 156
 157 //Start :: String
 158 //Start = toReadableByteCode bc
 159 //      where
 160 //              bc :: ByteCode Int Expr
 161 //              bc = (lit 36 +. lit 42) +. lit 44
 162
 163 Start :: String
 164 Start = toReadableByteCode $ unMain bc
 165 //Start = toRealByteCode $ unMain bc
 166         where
 167                 bc :: Main (ByteCode Int Expr)
 168                 bc = sds \x=41 In
 169                         sds \y=1 In
 170                         {main = x =. x +. y}
 171
 172 //to16bit :: Int -> String
 173 //to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
 174 //
 175 ////Run test programma en pretty print
 176 ////Start :: String
 177 ////Start = "t" +++ to16bit (size b) +++ b
 178 //Start :: Main (ByteCode Int Expr)
 179 //Start = bc
 180 //      where
 181 //              bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
 182 //              b = toRealByteCode bc
 183 //Start :: ByteCode Int Expr
 184 //Start = If (lit True) (analogRead A1) (analogRead A0)
 185 //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)