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 +++ v +++ "\n"
  47 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
  48
  49 import StdDebug
  50 decode :: String -> MTaskMSGRecv
  51 decode x
  52 | not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef
  53 | size x == 0 = MTEmpty
  54 = case x.[0] of
  55         't' = MTTaskAck $ fromByteCode x
  56         'd' = MTTaskDelAck $ fromByteCode x
  57         'm' = MTMessage x
  58         's' = MTSDSAck $ fromByteCode x
  59         'a' = MTSDSDelAck $ fromByteCode x
  60         'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x)
  61         'c'     = MTDevSpec $ fromByteCode (x % (1, size x))
  62         '\0' = MTEmpty
  63         '\n' = MTEmpty
  64         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  65
  66 safePrint :== toString o toJSON
  67
  68 instance toString MTaskInterval where
  69         toString OneShot = "One shot"
  70         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  71         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  72
  73 instance toString MTaskMSGSend where
  74         toString (MTSds i v) = "Sds id: " +++ toString i
  75                 +++ " value " +++ safePrint v
  76         toString (MTTask to data) = "Task timeout: " +++ toString to
  77                 +++ " data " +++ safePrint data
  78         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  79         toString (MTUpd i v) = "Update id: " +++ toString i
  80                 +++ " value " +++ safePrint v
  81
  82 instance toString MTaskMSGRecv where
  83         toString (MTTaskAck i) = "Task added with id: " +++ toString i
  84         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  85         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  86         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  87         toString (MTPub i v) = "Publish id: " +++ toString i
  88                 +++ " value " +++ safePrint v
  89         toString (MTDevSpec mt) = "Specification: " +++ printToString mt
  90         toString (MTMessage m) = m
  91         toString MTEmpty = "Empty message"
  92
  93 toByteVal :: BC -> String
  94 toByteVal b = {toChar $ consIndex{|*|} b} +++
  95         case b of
  96                 (BCPush (BCValue i)) = toByteCode i
  97                 (BCLab i) = {toChar i}
  98                 (BCSdsStore i) = to16bit i
  99                 (BCSdsFetch i) = to16bit i
 100                 (BCSdsPublish i) = to16bit i
 101                 (BCAnalogRead i) = {toChar $ consIndex{|*|} i}
 102                 (BCAnalogWrite i) = {toChar $ consIndex{|*|} i}
 103                 (BCDigitalRead i) = {toChar $ consIndex{|*|} i}
 104                 (BCDigitalWrite i) = {toChar $ consIndex{|*|} i}
 105                 (BCJmp i) = {toChar i}
 106                 (BCJmpT i) = {toChar i}
 107                 (BCJmpF i) = {toChar i}
 108                 _ = ""
 109
 110 parseBCValue :: Char String -> BCValue
 111 parseBCValue c s = case c of
 112         'b' = BCValue $ castfbc True s
 113         'i' = BCValue $ castfbc 0 s
 114         'l' = BCValue $ castfbc (L 0) s
 115         'c' = BCValue $ castfbc ('0') s
 116         'B' = BCValue $ castfbc (NoButton) s
 117         'L' = BCValue $ castfbc (LED1) s
 118
 119 castfbc :: a -> (String -> a) | mTaskType a
 120 castfbc _ = fromByteCode
 121
 122 instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'}
 123 instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256}
 124 instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256}
 125 instance toByteCode Char where toByteCode c = {'c',c}
 126 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 127 instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s}
 128 instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s}
 129 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
 130
 131 instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01'
 132 instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2]
 133 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 134 instance fromByteCode Char where fromByteCode s = s.[1]
 135 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 136 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1]
 137 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1]
 138 instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s
 139
 140 instance toByteCode MTaskInterval where
 141         toByteCode OneShot = toByteCode 0
 142         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 143         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 144         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 145         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 146 instance fromByteCode MTaskInterval
 147         where
 148                 fromByteCode s
 149                 //Interval
 150                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 151                         0 = OneShot
 152                         i = OnInterval i
 153                 = OnInterrupt $ fromByteCode s bitand 127
 154 instance fromByteCode MTaskDeviceSpec where
 155         fromByteCode s = let c = toInt s.[0] in
 156                 {MTaskDeviceSpec
 157                 |haveLed=(c bitand 1) > 0
 158                 ,haveAio=(c bitand 2) > 0
 159                 ,haveDio=(c bitand 4) > 0
 160                 ,maxTask=from16bit $ s % (1,3)
 161                 ,maxSDS=from16bit $ s % (3,5)
 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 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 332 toMessages interval (bytes, st=:{sdss}) = (
 333         [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
 334         [MTTask interval bytes], st)
 335
 336 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 337 toSDSUpdate i v = [MTUpd i (to16bit v)]
 338
 339 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 340 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
 341 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 342 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 343 //              in (bcs, st.sdss)
 344         where
 345 //              bc = {main = ledOn (lit LED1)}
 346                 bc = sds \x=5 In
 347                         sds \y=4 In
 348                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 349
 350 to16bit :: Int -> String
 351 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 352
 353 from16bit :: String -> Int
 354 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 355
 356 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode