mTaskInterpret.icl

   1 implementation module mTaskInterpret
   2
   3 import Generics.gCons
   4
   5 import iTasks.UI.Editor.Common
   6 import iTasks.UI.Editor
   7
   8 import GenEq, StdMisc, StdArray, GenBimap
   9 import GenPrint
  10 import StdEnum
  11 import mTask
  12
  13 import StdInt
  14 import StdFile
  15 import StdString
  16
  17 from StdFunc import o, const
  18 import StdBool
  19 import StdTuple
  20 import Data.Tuple
  21 import Data.Monoid
  22 import Data.Functor
  23 import StdList
  24 from Data.Func import $
  25 from Text import class Text(subString,lpad,concat,toUpperCase), instance Text String
  26 import qualified Text
  27 import Text.JSON
  28
  29 import Control.Monad.RWST
  30 import Control.Monad.Identity
  31 import Control.Monad
  32 import Control.Applicative
  33 import Data.Functor
  34 import Data.Either
  35
  36 import Data.Array
  37 import qualified Data.Map as DM
  38 import qualified Data.List as DL
  39 import Text.Encodings.Base64
  40
  41 import Tasks.Examples
  42
  43 instance == BCValue where (==) a b = toByteCode a == toByteCode b
  44
  45 encode :: MTaskMSGSend -> String
  46 encode (MTTask to data) = "t" +++ toByteCode to +++ to16bit (size data) +++ data +++ "\n"
  47 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
  48 encode (MTSds i v) = "s" +++ to16bit i +++ toByteCode v +++ "\n"
  49 encode (MTUpd i v) = "u" +++ to16bit i +++ toByteCode v +++ "\n"
  50 encode (MTSpec) = "c\n"
  51 encode (MTShutdown) = "h\n"
  52
  53 import StdDebug
  54 decode :: String -> MTaskMSGRecv
  55 decode x
  56 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
  57 | size x == 0 = MTEmpty
  58 = case x.[0] of
  59         't' = MTTaskAck (fromByteCode x) (fromByteCode (x % (2, size x)))
  60         'd' = MTTaskDelAck $ fromByteCode x
  61         'm' = MTMessage x
  62         's' = MTSDSAck $ fromByteCode x
  63         'a' = MTSDSDelAck $ fromByteCode x
  64         'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
  65         'c'     = MTDevSpec $ fromByteCode (x % (1, size x))
  66         '\0' = MTEmpty
  67         '\n' = MTEmpty
  68         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  69
  70 safePrint :== toString o toJSON
  71
  72 instance toString MTaskInterval where
  73         toString OneShot = "One shot"
  74         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  75         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  76
  77 instance toString MTaskMSGSend where
  78         toString (MTSds i v) = "Sds id: " +++ toString i
  79                 +++ " value " +++ safePrint v
  80         toString (MTTask to data) = "Task timeout: " +++ toString to
  81                 +++ " data " +++ safePrint data
  82         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  83         toString (MTUpd i v) = "Update id: " +++ toString i
  84                 +++ " value " +++ safePrint v
  85         toString (MTSpec) = "Spec request"
  86         toString (MTShutdown) = "Shutdown request"
  87
  88 instance toString MTaskMSGRecv where
  89         toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
  90                 +++ " free memory: " +++ toString mem
  91         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  92         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  93         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  94         toString (MTPub i v) = "Publish id: " +++ toString i
  95                 +++ " value " +++ safePrint v
  96         toString (MTDevSpec mt) = "Specification: " +++ printToString mt
  97         toString (MTMessage m) = m
  98         toString MTEmpty = "Empty message"
  99
 100 toByteVal :: BC -> String
 101 toByteVal b = {toChar $ consIndex{|*|} b} +++
 102         case b of
 103                 (BCPush (BCValue i)) = toByteCode i
 104                 (BCLab i) = {toChar i}
 105                 (BCSdsStore i) = to16bit i.sdsi
 106                 (BCSdsFetch i) = to16bit i.sdsi
 107                 (BCSdsPublish i) = to16bit i.sdsi
 108                 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
 109                 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
 110                 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
 111                 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
 112                 (BCJmp i) = {toChar i}
 113                 (BCJmpT i) = {toChar i}
 114                 (BCJmpF i) = {toChar i}
 115                 _ = ""
 116
 117 parseBCValue :: Char String -> BCValue
 118 parseBCValue c s = case c of
 119         'b' = BCValue $ castfbc True s
 120         'i' = BCValue $ castfbc 0 s
 121         'l' = BCValue $ castfbc (L 0) s
 122         'c' = BCValue $ castfbc ('0') s
 123         'B' = BCValue $ castfbc (NoButton) s
 124         'L' = BCValue $ castfbc (LED1) s
 125
 126 castfbc :: a -> (String -> a) | mTaskType a
 127 castfbc _ = fromByteCode
 128
 129 instance toByteCode Bool where toByteCode b = {'b',if b '\x01' '\0'}
 130 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
 131 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
 132 instance toByteCode Char where toByteCode c = {'c',c}
 133 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 134 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
 135 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
 136 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
 137
 138 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
 139 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
 140 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 141 instance fromByteCode Char where fromByteCode s = s.[1]
 142 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 143 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
 144 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
 145 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
 146
 147 instance toByteCode MTaskInterval where
 148         toByteCode OneShot = toByteCode (OnInterval 0)
 149         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 150         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 151         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 152         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 153 instance fromByteCode MTaskInterval
 154         where
 155                 fromByteCode s
 156                 //Interval
 157                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 158                         0 = OneShot
 159                         i = OnInterval i
 160                 = OnInterrupt $ fromByteCode s bitand 127
 161 instance fromByteCode MTaskDeviceSpec where
 162         fromByteCode s = let c = toInt s.[0] in
 163                 { MTaskDeviceSpec
 164                 | haveLed     = (c bitand 1) > 0
 165                 , haveAio     = (c bitand 2) > 0
 166                 , haveDio     = (c bitand 4) > 0
 167                 , bytesMemory = from16bit $ s % (1,3)
 168                 , stackSize  = from16bit $ s % (3,5)
 169                 , aPins       = toInt s.[5]
 170                 , dPins       = toInt s.[6]
 171                 }
 172
 173 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
 174 derive class gCons BC, BCShare
 175
 176 consIndex{|BCValue|} _ = 0
 177 consName{|BCValue|} _ = "BCValue"
 178 conses{|BCValue|} = [BCValue 0]
 179 consNum{|BCValue|} _ = 1
 180 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
 181
 182 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
 183         where
 184                 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
 185                 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
 186                 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
 187
 188                 castEditor :: a -> (Editor a) | mTaskType a
 189                 castEditor _ = gEditor{|*|}
 190
 191 gText{|BCValue|} fm Nothing = []
 192 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
 193 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
 194 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
 195         where
 196                 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
 197                 JSS = JSONDecode{|*|}
 198 gDefault{|BCValue|} = BCValue 0
 199 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
 200
 201 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
 202 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
 203
 204 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b p3
 205 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 206
 207 op :: (ByteCode a p) BC -> ByteCode b c
 208 op (BC x) bc = BC $ x >>| tell [bc]
 209
 210 tell` :: [BC] -> (ByteCode a p)
 211 tell` x = BC $ tell x
 212
 213 instance arith ByteCode where
 214         lit x = tell` [BCPush $ BCValue x]
 215         (+.) x y = op2 x y BCAdd
 216         (-.) x y = op2 x y BCSub
 217         (*.) x y = op2 x y BCMul
 218         (/.) x y = op2 x y BCDiv
 219
 220 instance boolExpr ByteCode where
 221         (&.) x y =  op2 x y BCAnd
 222         (|.) x y =  op2 x y BCOr
 223         Not x = op x BCNot
 224         (==.) x y = op2 x y BCEq
 225         (!=.) x y = op2 x y BCNeq
 226         (<.)  x y = op2 x y  BCLes
 227         (>.)  x y = op2 x y BCGre
 228         (<=.) x y = op2 x y BCLeq
 229         (>=.) x y = op2 x y BCGeq
 230
 231 instance analogIO ByteCode where
 232         analogRead p = tell` [BCAnalogRead $ pin p]
 233         analogWrite p b = op b (BCAnalogWrite $ pin p)
 234
 235 instance digitalIO ByteCode where
 236         digitalRead p = tell` [BCDigitalRead $ pin p]
 237         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 238
 239 instance aIO ByteCode where
 240         aIO p = tell` [BCAnalogRead $ pin p]
 241
 242 instance dIO ByteCode where
 243         dIO p = tell` [BCDigitalRead $ pin p]
 244
 245 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 246 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 247 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 248 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 249 instance IF ByteCode where
 250         IF b t e = BCIfStmt b t e
 251         (?) b t = BCIfStmt b t $ tell` mempty
 252 BCIfStmt (BC b) (BC t) (BC e) = BC $
 253         freshl >>= \else->freshl >>= \endif->
 254         b >>| tell [BCJmpF else] >>|
 255         t >>| tell [BCJmp endif, BCLab else] >>|
 256         e >>| tell [BCLab endif]
 257
 258 freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl
 259 freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs
 260
 261 instance noOp ByteCode where noOp = tell` [BCNop]
 262
 263 unBC :: (ByteCode a p) -> RWS () [BC] BCState ()
 264 unBC (BC x) = x
 265
 266 instance sds ByteCode where
 267         sds f = {main = BC $ freshs
 268                 >>= \sdsi->pure {BCShare | sdsname="", sdsi=sdsi, sdsval=BCValue 0}
 269                 >>= \sds ->pure (f $ tell` [BCSdsFetch sds])
 270                 >>= \(v In bdy)->modify (addSDS sds v)
 271                 >>| unBC (unMain bdy)}
 272         where
 273                 addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
 274         con f = undef
 275
 276 instance namedsds ByteCode where
 277         namedsds f = {main = BC $ freshs
 278                 >>= \sdsi->pure {BCShare | sdsname="", sdsi=sdsi, sdsval=BCValue 0}
 279                 >>= \sds ->pure (f $ tell` [BCSdsFetch sds])
 280                 >>= \(v Named n In bdy)->modify (addSDS sds n v)
 281                 >>| unBC (unMain bdy)}
 282         where
 283                 addSDS sds n v s = {s & sdss=[{sds & sdsname=n, sdsval=BCValue v}:s.sdss]}
 284
 285 instance sdspub ByteCode where
 286         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
 287
 288 instance assign ByteCode where
 289         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 290                 where
 291                         //This is going to include pins as well, as variables
 292                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 293                         makeStore [BCDigitalRead i] = [BCDigitalWrite i]
 294                         makeStore [BCAnalogRead i] = [BCAnalogWrite i]
 295
 296 instance seq ByteCode where
 297         (>>=.) _ _ = abort "undef on >>=."
 298         (:.) (BC x) (BC y) = BC $ x >>| y
 299
 300 instance serial ByteCode where
 301         serialAvailable = tell` [BCSerialAvail]
 302         serialPrint s = tell` [BCSerialPrint]
 303         serialPrintln s = tell` [BCSerialPrintln]
 304         serialRead = tell` [BCSerialRead]
 305         serialParseInt = tell` [BCSerialParseInt]
 306
 307 instance userLed ByteCode where
 308         ledOn  l = op l BCLedOn
 309         ledOff l = op l BCLedOff
 310
 311 instance retrn ByteCode where
 312   retrn = tell` [BCReturn]
 313
 314 instance zero BCState where
 315         zero = {freshl=1, freshs=1, sdss=[]}
 316
 317 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 318 toRealByteCode x s
 319 # (s, bc) = runBC x s
 320 # (bc, gtmap) = computeGotos bc 1
 321 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 322
 323 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 324 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 325 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 326 implGotos _ i = i
 327
 328 bclength :: BC -> Int
 329 bclength (BCPush s) = 1 + size (toByteCode s)
 330 bclength (BCSdsStore _) = 3
 331 bclength (BCSdsFetch _) = 3
 332 bclength (BCSdsPublish _) = 3
 333 bclength x = 1 + consNum{|*|} x
 334
 335 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 336 computeGotos [] _ = ([], 'DM'.newMap)
 337 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 338 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 339
 340 readable :: BC -> String
 341 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
 342         where
 343                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 344 readable b = printToString b
 345
 346 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 347 runBC (BC x) = execRWS x ()
 348
 349 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 350 toReadableByteCode x s
 351 # (s, bc) = runBC x s
 352 # (bc, gtmap) = computeGotos bc 0
 353 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 354         where
 355                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 356                 lineNumbers ls [] = []
 357                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 358                         where
 359                                 (ex, newls) = splitAt (bclength b - 1) ls
 360
 361 derive gPrint BCShare
 362
 363 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
 364 toMessages interval x s
 365 # (bc, newstate) = toRealByteCode (unMain x) s
 366 # newsdss = 'DL'.difference newstate.sdss s.sdss
 367 | not (trace_tn $ printToString s.sdss) = undef
 368 | not (trace_tn $ printToString newstate.sdss) = undef
 369 | not (trace_tn $ printToString newsdss) = undef
 370 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
 371         [MTTask interval bc], newstate)
 372
 373 instance == BCShare where (==) a b = a.sdsi == b.sdsi
 374
 375 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 376 //Start = [fst $ toReadableByteCode (unMain $ p0) zero
 377 //              ,'Text'.concat $ compile p0
 378 //              ]
 379 Start = toReadableByteCode (unMain $ p0) zero
 380         where
 381                 p0 :: (Main (a Int Expr)) | assign, namedsds, sds, arith a
 382 //              p0 = sds \x = 6 In {main = x =. x *. lit 7}
 383                 p0 = namedsds \x = 6 Named "x" In {main = x =. x *. lit 7}
 384
 385                 bc  = {main =
 386                         IF (analogRead A0 >. lit 50)
 387                           ( digitalWrite D0 (lit True)  )
 388                           ( digitalWrite D0 (lit False) )
 389                         }
 390
 391
 392 to16bit :: Int -> String
 393 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 394
 395 from16bit :: String -> Int
 396 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 397
 398 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode