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