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