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