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                 ,maxTask=from16bit $ s % (1,3)
 162                 ,maxSDS=from16bit $ s % (3,5)
 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 zero BCState where
 286         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 287
 288 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 289 toRealByteCode x s
 290 # (s, bc) = runBC x s
 291 # (bc, gtmap) = computeGotos bc 1
 292 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 293
 294 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 295 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 296 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 297 implGotos _ i = i
 298
 299 bclength :: BC -> Int
 300 bclength (BCPush s) = 1 + size (toByteCode s)
 301 bclength (BCSdsStore _) = 3
 302 bclength (BCSdsFetch _) = 3
 303 bclength (BCSdsPublish _) = 3
 304 bclength x = 1 + consNum{|*|} x
 305
 306 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 307 computeGotos [] _ = ([], 'DM'.newMap)
 308 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 309 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 310
 311 readable :: BC -> String
 312 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
 313         where
 314                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 315 readable b = printToString b
 316
 317 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 318 runBC (BC x) = execRWS x ()
 319
 320 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 321 toReadableByteCode x s
 322 # (s, bc) = runBC x s
 323 # (bc, gtmap) = computeGotos bc 0
 324 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 325         where
 326                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 327                 lineNumbers ls [] = []
 328                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 329                         where
 330                                 (ex, newls) = splitAt (bclength b - 1) ls
 331
 332 derive gPrint BCShare
 333
 334 toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState)
 335 toMessages interval x s
 336 # (bc, newstate) = toRealByteCode (unMain x) s
 337 # newsdss = 'DL'.difference newstate.sdss s.sdss
 338 | not (trace_tn $ printToString s.sdss) = undef
 339 | not (trace_tn $ printToString newstate.sdss) = undef
 340 | not (trace_tn $ printToString newsdss) = undef
 341 = ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++
 342         [MTTask interval bc], newstate)
 343
 344 instance == BCShare where (==) a b = a.sdsi == b.sdsi
 345
 346 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 347 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
 348 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 349 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 350 //              in (bcs, st.sdss)
 351         where
 352 //              bc = {main = ledOn (lit LED1)}
 353                 bc = sds \x=5 In
 354                         sds \y=4 In
 355                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 356
 357 to16bit :: Int -> String
 358 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 359
 360 from16bit :: String -> Int
 361 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 362
 363 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode