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                 }
 169
 170 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
 171 derive class gCons BC, BCShare
 172
 173 consIndex{|BCValue|} _ = 0
 174 consName{|BCValue|} _ = "BCValue"
 175 conses{|BCValue|} = [BCValue 0]
 176 consNum{|BCValue|} _ = 1
 177 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
 178
 179 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
 180         where
 181                 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
 182                 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
 183                 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
 184
 185                 castEditor :: a -> (Editor a) | mTaskType a
 186                 castEditor _ = gEditor{|*|}
 187
 188 gText{|BCValue|} fm Nothing = []
 189 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
 190 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
 191 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
 192         where
 193                 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
 194                 JSS = JSONDecode{|*|}
 195 gDefault{|BCValue|} = BCValue 0
 196 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
 197
 198 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
 199 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec
 200
 201 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b p3
 202 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 203
 204 op :: (ByteCode a p) BC -> ByteCode b c
 205 op (BC x) bc = BC $ x >>| tell [bc]
 206
 207 tell` :: [BC] -> (ByteCode a p)
 208 tell` x = BC $ tell x
 209
 210 instance arith ByteCode where
 211         lit x = tell` [BCPush $ BCValue x]
 212         (+.) x y = op2 x y BCAdd
 213         (-.) x y = op2 x y BCSub
 214         (*.) x y = op2 x y BCMul
 215         (/.) x y = op2 x y BCDiv
 216
 217 instance boolExpr ByteCode where
 218         (&.) x y =  op2 x y BCAnd
 219         (|.) x y =  op2 x y BCOr
 220         Not x = op x BCNot
 221         (==.) x y = op2 x y BCEq
 222         (!=.) x y = op2 x y BCNeq
 223         (<.)  x y = op2 x y  BCLes
 224         (>.)  x y = op2 x y BCGre
 225         (<=.) x y = op2 x y BCLeq
 226         (>=.) x y = op2 x y BCGeq
 227
 228 instance analogIO ByteCode where
 229         analogRead p = tell` [BCAnalogRead $ pin p]
 230         analogWrite p b = op b (BCAnalogWrite $ pin p)
 231
 232 instance digitalIO ByteCode where
 233         digitalRead p = tell` [BCDigitalRead $ pin p]
 234         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 235
 236 instance aIO ByteCode where
 237         aIO p = tell` [BCAnalogRead $ pin p]
 238
 239 instance dIO ByteCode where
 240         dIO p = tell` [BCDigitalRead $ pin p]
 241
 242 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 243 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 244 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 245 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 246 instance IF ByteCode where
 247         IF b t e = BCIfStmt b t e
 248         (?) b t = BCIfStmt b t $ tell` mempty
 249 BCIfStmt (BC b) (BC t) (BC e) = BC $
 250         freshl >>= \else->freshl >>= \endif->
 251         b >>| tell [BCJmpF else] >>|
 252         t >>| tell [BCJmp endif, BCLab else] >>|
 253         e >>| tell [BCLab endif]
 254
 255 freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl
 256 freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs
 257
 258 instance noOp ByteCode where noOp = tell` [BCNop]
 259
 260 unBC :: (ByteCode a p) -> RWS () [BC] BCState ()
 261 unBC (BC x) = x
 262
 263 instance sds ByteCode where
 264         sds f = {main = BC $ freshs
 265                                 >>= \sdsi->pure {BCShare | sdsi=sdsi,sdsval=BCValue 0}
 266                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 267                                 >>= \(v In bdy)->modify (addSDS sds v)
 268                                 >>| unBC (unMain bdy)}
 269                 where
 270                         addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
 271
 272         con f = undef
 273
 274 instance sdspub ByteCode where
 275         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x
 276
 277 instance assign ByteCode where
 278         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 279                 where
 280                         //This is going to include pins as well, as variables
 281                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 282                         makeStore [BCDigitalRead i] = [BCDigitalWrite i]
 283                         makeStore [BCAnalogRead i] = [BCAnalogWrite i]
 284
 285 instance seq ByteCode where
 286         (>>=.) _ _ = abort "undef on >>=."
 287         (:.) (BC x) (BC y) = BC $ x >>| y
 288
 289 instance serial ByteCode where
 290         serialAvailable = tell` [BCSerialAvail]
 291         serialPrint s = tell` [BCSerialPrint]
 292         serialPrintln s = tell` [BCSerialPrintln]
 293         serialRead = tell` [BCSerialRead]
 294         serialParseInt = tell` [BCSerialParseInt]
 295
 296 instance userLed ByteCode where
 297         ledOn  l = op l BCLedOn
 298         ledOff l = op l BCLedOff
 299
 300 instance retrn ByteCode where
 301   retrn = tell` [BCReturn]
 302
 303 instance zero BCState where
 304         zero = {freshl=1, freshs=1, sdss=[]}
 305
 306 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 307 toRealByteCode x s
 308 # (s, bc) = runBC x s
 309 # (bc, gtmap) = computeGotos bc 1
 310 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 311
 312 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 313 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 314 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 315 implGotos _ i = i
 316
 317 bclength :: BC -> Int
 318 bclength (BCPush s) = 1 + size (toByteCode s)
 319 bclength (BCSdsStore _) = 3
 320 bclength (BCSdsFetch _) = 3
 321 bclength (BCSdsPublish _) = 3
 322 bclength x = 1 + consNum{|*|} x
 323
 324 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 325 computeGotos [] _ = ([], 'DM'.newMap)
 326 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 327 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 328
 329 readable :: BC -> String
 330 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
 331         where
 332                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 333 readable b = printToString b
 334
 335 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 336 runBC (BC x) = execRWS x ()
 337
 338 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 339 toReadableByteCode x s
 340 # (s, bc) = runBC x s
 341 # (bc, gtmap) = computeGotos bc 0
 342 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 343         where
 344                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 345                 lineNumbers ls [] = []
 346                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 347                         where
 348                                 (ex, newls) = splitAt (bclength b - 1) ls
 349
 350 derive gPrint BCShare
 351
 352 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
 353 toMessages interval x s
 354 # (bc, newstate) = toRealByteCode (unMain x) s
 355 # newsdss = 'DL'.difference newstate.sdss s.sdss
 356 | not (trace_tn $ printToString s.sdss) = undef
 357 | not (trace_tn $ printToString newstate.sdss) = undef
 358 | not (trace_tn $ printToString newsdss) = undef
 359 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
 360         [MTTask interval bc], newstate)
 361
 362 instance == BCShare where (==) a b = a.sdsi == b.sdsi
 363
 364 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 365 Start = fst $ toReadableByteCode (unMain $ bc) zero
 366 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 367 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 368 //              in (bcs, st.sdss)
 369         where
 370 //              bc = {main = ledOn (lit LED1)}
 371 //              bc = sds \x=5 In
 372 //                      sds \y=4 In
 373 //                      {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 374                 bc  = {main =
 375                         IF (analogRead A0 >. lit 50)
 376                           ( digitalWrite D0 (lit True)  )
 377                           ( digitalWrite D0 (lit False) )
 378                         }
 379
 380
 381 to16bit :: Int -> String
 382 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 383
 384 from16bit :: String -> Int
 385 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 386
 387 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode