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 decode :: String -> MTaskMSGRecv
  55 decode x
  56 | size x == 0 = MTEmpty
  57 = case x.[0] of
  58         't' = MTTaskAck (from16bit (x % (1,3)))
  59         'd' = MTTaskDelAck (from16bit (x % (1,3)))
  60         'm' = MTMessage x
  61         's' = MTSDSAck (from16bit (x % (1,3)))
  62         'a' = MTSDSDelAck (from16bit (x % (1,3)))
  63         'p' = MTPub (from16bit (x % (1,3))) (x % (3,size x))
  64         '\0' = MTEmpty
  65         '\n' = MTEmpty
  66         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  67
  68 safePrint :== toString o toJSON
  69
  70 instance toString MTaskInterval where
  71         toString OneShot = "One shot"
  72         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  73         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  74
  75 instance toString MTaskMSGSend where
  76         toString (MTSds i v) = "Sds id: " +++ toString i
  77                 +++ " value " +++ safePrint v
  78         toString (MTTask to data) = "Task timeout: " +++ toString to
  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) = "Task added with id: " +++ toString i
  86         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  87         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  88         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  89         toString (MTPub i v) = "Publish id: " +++ toString i
  90                 +++ " value " +++ safePrint v
  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 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
 156 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC
 157 derive class gCons BC
 158
 159 consIndex{|BCValue|} _ = 0
 160 consName{|BCValue|} _ = "BCValue"
 161 conses{|BCValue|} = [BCValue 0]
 162 consNum{|BCValue|} _ = 1
 163 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
 164
 165 gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`}
 166         where
 167                 genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst
 168                 onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst
 169                 onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst
 170
 171                 castEditor :: a -> (Editor a) | mTaskType a
 172                 castEditor _ = gEditor{|*|}
 173
 174 gText{|BCValue|} fm Nothing = []
 175 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
 176 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
 177 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
 178         where
 179                 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
 180                 JSS = JSONDecode{|*|}
 181 gDefault{|BCValue|} = BCValue 0
 182 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
 183
 184 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
 185 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
 186
 187 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
 188 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 189
 190 op :: (ByteCode a p) BC -> ByteCode a Expr
 191 op (BC x) bc = BC $ x >>| tell [bc]
 192
 193 tell` x = BC $ tell x
 194
 195 instance arith ByteCode where
 196         lit x = tell` [BCPush $ BCValue x]
 197         (+.) x y = op2 x y BCAdd
 198         (-.) x y = op2 x y BCSub
 199         (*.) x y = op2 x y BCMul
 200         (/.) x y = op2 x y BCDiv
 201
 202 instance boolExpr ByteCode where
 203         (&.) x y =  op2 x y BCAnd
 204         (|.) x y =  op2 x y BCOr
 205         Not x = op x BCNot
 206         (==.) x y = op2 x y BCEq
 207         (!=.) x y = op2 x y BCNeq
 208         (<.)  x y = op2 x y  BCLes
 209         (>.)  x y = op2 x y BCGre
 210         (<=.) x y = op2 x y BCLeq
 211         (>=.) x y = op2 x y BCGeq
 212
 213 instance analogIO ByteCode where
 214         analogRead p = tell` [BCAnalogRead $ pin p]
 215         analogWrite p b = op b (BCAnalogWrite $ pin p)
 216
 217 instance digitalIO ByteCode where
 218         digitalRead p = tell` [BCDigitalRead $ pin p]
 219         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 220
 221 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 222 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 223 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 224 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 225 instance IF ByteCode where
 226         IF b t e = BCIfStmt b t e
 227         (?) b t = BCIfStmt b t $ tell` mempty
 228 BCIfStmt (BC b) (BC t) (BC e) = BC $
 229         freshl >>= \else->freshl >>= \endif->
 230         b >>| tell [BCJmpF else] >>|
 231         t >>| tell [BCJmp endif, BCLab else] >>|
 232         e >>| tell [BCLab endif]
 233
 234 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
 235 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
 236
 237 instance noOp ByteCode where noOp = tell` [BCNop]
 238
 239 unBC (BC x) = x
 240
 241 instance sds ByteCode where
 242         sds f = {main = BC $ freshs
 243                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 244                                 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
 245 //                              >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
 246                 where
 247                         addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
 248
 249         con f = undef
 250         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 251                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 252                 where
 253                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 254
 255 instance assign ByteCode where
 256         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 257                 where
 258                         //This is going to include pins as well, as variables
 259                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 260
 261 instance seq ByteCode where
 262         (>>=.) _ _ = abort "undef on >>=."
 263         (:.) (BC x) (BC y) = BC $ x >>| y
 264
 265 instance serial ByteCode where
 266         serialAvailable = tell` [BCSerialAvail]
 267         serialPrint s = tell` [BCSerialPrint]
 268         serialPrintln s = tell` [BCSerialPrintln]
 269         serialRead = tell` [BCSerialRead]
 270         serialParseInt = tell` [BCSerialParseInt]
 271
 272 instance userLed ByteCode where
 273         ledOn  (BC l) = BC $ l >>| tell [BCLedOn]
 274         ledOff (BC l) = BC $ l >>| tell [BCLedOff]
 275
 276 instance zero BCState where
 277         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 278
 279 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 280 toRealByteCode x s
 281 # (s, bc) = runBC x s
 282 # (bc, gtmap) = computeGotos bc 1
 283 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 284
 285 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 286 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 287 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 288 implGotos _ i = i
 289
 290 bclength :: BC -> Int
 291 bclength (BCPush s) = 1 + size (toByteCode s)
 292 bclength (BCSdsStore _) = 3
 293 bclength (BCSdsFetch _) = 3
 294 bclength (BCSdsPublish _) = 3
 295 bclength x = 1 + consNum{|*|} x
 296
 297 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 298 computeGotos [] _ = ([], 'DM'.newMap)
 299 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 300 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 301
 302 readable :: BC -> String
 303 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
 304         where
 305                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 306 readable b = printToString b
 307
 308 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 309 runBC (BC x) = execRWS x ()
 310
 311 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 312 toReadableByteCode x s
 313 # (s, bc) = runBC x s
 314 # (bc, gtmap) = computeGotos bc 0
 315 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 316         where
 317                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 318                 lineNumbers ls [] = []
 319                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 320                         where
 321                                 (ex, newls) = splitAt (bclength b - 1) ls
 322
 323 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 324 toMessages interval (bytes, st=:{sdss}) = (
 325         [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
 326         [MTTask interval bytes], st)
 327
 328 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 329 toSDSUpdate i v = [MTUpd i (to16bit v)]
 330
 331 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 332 Start = fst $ toReadableByteCode (unMain $ countAndLed) zero
 333 //Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 334 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 335 //              in (bcs, st.sdss)
 336         where
 337 //              bc = {main = ledOn (lit LED1)}
 338                 bc = sds \x=5 In
 339                         sds \y=4 In
 340                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 341
 342 to16bit :: Int -> String
 343 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 344
 345 from16bit :: String -> Int
 346 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 347
 348 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode