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