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