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