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 import Text.Encodings.Base64
  23
  24 toByteVal :: BC -> [Char]
  25 toByteVal b
  26 # bt = toChar $ consIndex{|*|} b + 1
  27 = [bt:case b of
  28                 (BCPush i) = i
  29                 (BCSdsStore i) = [toChar i]
  30                 (BCSdsFetch i) = [toChar i]
  31                 (BCSdsPublish i) = [toChar i]
  32                 (BCAnalogRead i) = [toChar i]
  33                 (BCAnalogWrite i) = [toChar i]
  34                 (BCDigitalRead i) = [toChar i]
  35                 (BCDigitalWrite i) = [toChar i]
  36                 (BCJmp i) = [toChar i]
  37                 (BCJmpT i) = [toChar i]
  38                 (BCJmpF i) = [toChar i]
  39                 _ = []]
  40
  41 instance Semigroup (ByteCode a p) where
  42         mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
  43
  44 instance Monoid (ByteCode a p) where
  45         mempty = retrn []
  46
  47 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
  48 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
  49
  50 (<+->) infixr 1
  51 (<+->) m n :== m <++> retrn n
  52
  53 runBC (BC m) = m
  54
  55 retrn :: ([BC] -> ByteCode a p)
  56 retrn = BC o tuple
  57 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a p
  58 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
  59
  60 instance toByteCode Bool where
  61         toByteCode True = [toChar 1]
  62         toByteCode False = [toChar 0]
  63 instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256]
  64 instance toByteCode Long where toByteCode (L n) = toByteCode n
  65 instance toByteCode Char where toByteCode c = [c]
  66 instance toByteCode String where toByteCode s = undef
  67 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
  68
  69 instance toChar Pin where
  70         toChar (Digital p) = toChar $ consIndex{|*|} p + 1
  71         toChar (Analog p) = toChar $ consIndex{|*|} p + 1
  72
  73 derive gPrint BC, AnalogPin, Pin, DigitalPin
  74 derive consIndex BC, Pin, Button
  75 derive consName BC, Pin, Button
  76
  77 instance arith ByteCode where
  78         lit x = retrn [BCPush $ toByteCode x]
  79         (+.) x y = x <++> y <+-> [BCAdd]
  80         (-.) x y = x <++> y <+-> [BCSub]
  81         (*.) x y = x <++> y <+-> [BCMul]
  82         (/.) x y = x <++> y <+-> [BCDiv]
  83
  84 instance boolExpr ByteCode where
  85         (&.) x y = x <++> y <+-> [BCAnd]
  86         (|.) x y = x <++> y <+-> [BCOr]
  87         Not x = x <+-> [BCNot]
  88         (==.) x y = x <++> y <+-> [BCEq]
  89         (!=.) x y = x <++> y <+-> [BCNeq]
  90         (<.) x y = x <++> y <+-> [ BCLes]
  91         (>.)  x y = x <++> y <+-> [BCGre]
  92         (<=.) x y = x <++> y <+-> [BCLeq]
  93         (>=.) x y = x <++> y <+-> [BCGeq]
  94
  95 instance analogIO ByteCode where
  96         analogRead p = retrn [BCAnalogRead $ pin p]
  97         analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
  98
  99 instance digitalIO ByteCode where
 100         digitalRead p = retrn [BCDigitalRead $ pin p]
 101         digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
 102
 103 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 104 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 105 instance If ByteCode Stmt Stmt e where If b t e = BCIfStmt b t e
 106 instance If ByteCode x y Expr where If b t e = BCIfStmt b t e
 107 instance IF ByteCode where
 108         IF b t e = BCIfStmt b t e
 109         (?) b t = BCIfStmt b t $ retrn []
 110 BCIfStmt b t e = withLabel \else->withLabel \endif->retrn [BCJmpF else] <++> t
 111         <++> retrn [BCJmp endif] <++> e <++> retrn [BCLab endif]
 112
 113 instance noOp ByteCode where noOp = mempty
 114
 115 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
 116 withLabel f = BC \s->let [fresh:fs] = s.freshl
 117         in runBC (f fresh) {s & freshl=fs}
 118
 119 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
 120 withSDS f = BC \s->let [fresh:fs] = s.freshs
 121         in runBC (f fresh) {s & freshs=fs}
 122
 123 setSDS :: Int v -> ByteCode b q | toByteCode v
 124 setSDS ident val = BC \s->([], {s & sdss = [(ident, toByteCode val):s.sdss]})
 125
 126 instance sds ByteCode where
 127         sds f = {main = withSDS \sds->
 128                         let (v In body) = f $ retrn [BCSdsFetch sds]
 129                         in setSDS sds v <++> unMain body
 130                 }
 131         con f = undef
 132 //      pub _ = undef
 133
 134 instance assign ByteCode where
 135         (=.) v e = e <++> fmp makeStore v
 136
 137 makePub [] = []
 138 makePub [x:xs] = case x of
 139         BCSdsFetch i = [BCSdsPublish i:xs]
 140         y = [y:xs]
 141
 142 makeStore [] = []
 143 makeStore [x:xs] = case x of
 144         BCSdsFetch i = [BCSdsStore i:xs]
 145         y = [y:xs]
 146
 147 instance seq ByteCode where
 148         (>>=.) _ _ = abort "undef on >>=."
 149         (:.) x y = x <++> y
 150
 151 instance serial ByteCode where
 152         serialAvailable = retrn [BCSerialAvail]
 153         serialPrint s = retrn [BCSerialPrint]
 154         serialPrintln s = retrn [BCSerialPrintln]
 155         serialRead = retrn [BCSerialRead]
 156         serialParseInt = retrn [BCSerialParseInt]
 157
 158 instance zero BCState where
 159         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 160
 161 makeSafe :: Char -> Char
 162 makeSafe c = c//toChar $ toInt c + 31
 163
 164 toRealByteCode :: (ByteCode a b) -> (String, BCState)
 165 toRealByteCode x
 166 # (bc, st) = runBC x zero
 167 = (concat $ map (toString o map makeSafe o toByteVal) bc, st)
 168
 169 readable :: BC -> String
 170 readable (BCPush d) = "BCPush " +++ concat (map safe d)
 171         where
 172                 safe c
 173                 | isControl c = "\\d" +++ toString (toInt c)
 174                 = toString c
 175 readable b = printToString b
 176
 177 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
 178 toReadableByteCode x
 179 # (bc, st) = runBC x zero
 180 = (join "\n" $ map readable bc, st)
 181
 182 //Start :: String
 183 //Start = toReadableByteCode bc
 184 //      where
 185 //              bc :: ByteCode Int Expr
 186 //              bc = (lit 36 +. lit 42) +. lit 44
 187 getSDSBytes :: BCState -> String
 188 getSDSBytes {sdss} = concat $ map sd sdss
 189         where sd (i, v) = "s" +++ toString (toChar i) +++ toString v +++ "\n"
 190
 191 getTaskBytes :: Int String -> String
 192 getTaskBytes i b = "t" +++ to16bit i +++ to16bit (size b) +++ b
 193 //
 194 Start = getSDSBytes (snd bc`) +++ getTaskBytes 400 (fst bc`)
 195 //Start = fst $ toReadableByteCode $ unMain bc
 196         where
 197                 bc` = toRealByteCode (unMain bc)
 198 //              bc :: Main (ByteCode Int Stmt)
 199                 bc = sds \x=5 In
 200                         sds \y=4 In
 201                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 202
 203 pub :: (ByteCode a b) -> ByteCode a b
 204 pub x = fmp makePub x
 205
 206 to16bit :: Int -> String
 207 to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
 208 //
 209 ////Run test programma en pretty print
 210 ////Start :: String
 211 ////Start = "t" +++ to16bit (size b) +++ b
 212 //Start :: Main (ByteCode Int Expr)
 213 //Start = bc
 214 //      where
 215 //              bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
 216 //              b = toRealByteCode bc
 217 //Start :: ByteCode Int Expr
 218 //Start = If (lit True) (analogRead A1) (analogRead A0)
 219 //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)