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