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