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