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