mTaskInterpret.icl

   1 implementation module mTaskInterpret
   2
   3 import Generics.gCons
   4
   5 from iTasks.UI.Editor.Common import emptyEditor
   6
   7 import GenEq, StdMisc, StdArray, GenBimap
   8 import GenPrint
   9 import StdEnum
  10 import mTask
  11
  12 import StdInt
  13 import StdFile
  14 import StdString
  15
  16 from StdFunc import o, const
  17 import StdBool
  18 import StdTuple
  19 import Data.Tuple
  20 import Data.Monoid
  21 import Data.Functor
  22 import StdList
  23 from Data.Func import $
  24 from Text import class Text(subString,lpad,concat,toUpperCase), instance Text String
  25 import qualified Text
  26 import Text.JSON
  27
  28 import Control.Monad.RWST
  29 import Control.Monad.Identity
  30 import Control.Monad
  31 import Control.Applicative
  32 import Data.Functor
  33 import Data.Either
  34
  35 import Data.Array
  36 import qualified Data.Map as DM
  37 import qualified Data.List as DL
  38 import Text.Encodings.Base64
  39
  40 import Tasks.Examples
  41
  42 encode :: MTaskMSGSend -> String
  43 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
  44         where
  45                 tob = case to of
  46                         OneShot = to16bit 0
  47                         OnInterval i = to16bit i
  48                         OnInterrupt _ = abort "Interrupts not implemented yet"
  49 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
  50 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
  51 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
  52
  53 decode :: String -> MTaskMSGRecv
  54 decode x
  55 | size x == 0 = MTEmpty
  56 = case x.[0] of
  57         't' = MTTaskAck (from16bit (x % (1,3)))
  58         'd' = MTTaskDelAck (from16bit (x % (1,3)))
  59         'm' = MTMessage x
  60         's' = MTSDSAck (from16bit (x % (1,3)))
  61         'a' = MTSDSDelAck (from16bit (x % (1,3)))
  62         'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
  63         '\0' = MTEmpty
  64         '\n' = MTEmpty
  65         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  66
  67 safePrint :== toString o toJSON
  68
  69 instance toString MTaskInterval where
  70         toString OneShot = "One shot"
  71         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  72         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  73
  74 instance toString MTaskMSGSend where
  75         toString (MTSds i v) = "Sds id: " +++ toString i
  76                 +++ " value " +++ safePrint v
  77         toString (MTTask to data) = "Task timeout: " +++ toString to
  78                 +++ " data " +++ safePrint data
  79         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  80         toString (MTUpd i v) = "Update id: " +++ toString i
  81                 +++ " value " +++ safePrint v
  82
  83 instance toString MTaskMSGRecv where
  84         toString (MTTaskAck i) = "Task added with id: " +++ toString i
  85         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  86         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  87         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  88         toString (MTPub i v) = "Publish id: " +++ toString i
  89                 +++ " value " +++ safePrint v
  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','\0',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','\0',c}
 126 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 127 instance toByteCode Button where toByteCode s = {'B','\0',toChar $ consIndex{|*|} s}
 128 instance toByteCode UserLED where toByteCode s = {'L','\0',toChar $ consIndex{|*|} s}
 129 instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
 130
 131 instance fromByteCode Bool where fromByteCode s = fromByteCode s == 1
 132 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 133 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 134 instance fromByteCode Char where fromByteCode s = fromInt $ fromByteCode s
 135 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 136 instance fromByteCode Button where fromByteCode s = conses{|*|} !! fromByteCode s
 137 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! fromByteCode s
 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
 155 derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC
 156 derive class gCons BC
 157
 158 consIndex{|BCValue|} _ = 0
 159 consName{|BCValue|} _ = "BCValue"
 160 conses{|BCValue|} = [BCValue 0]
 161 consNum{|BCValue|} _ = 1
 162 gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
 163
 164 gEditor{|BCValue|} = emptyEditor
 165 gText{|BCValue|} fm Nothing = []
 166 gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
 167 JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
 168 JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
 169         where
 170                 JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
 171                 JSS = JSONDecode{|*|}
 172 gDefault{|BCValue|} = BCValue 0
 173 gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f
 174
 175 derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
 176 derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
 177
 178 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
 179 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 180
 181 op :: (ByteCode a p) BC -> ByteCode a Expr
 182 op (BC x) bc = BC $ x >>| tell [bc]
 183
 184 tell` x = BC $ tell x
 185
 186 instance arith ByteCode where
 187         lit x = tell` [BCPush $ BCValue x]
 188         (+.) x y = op2 x y BCAdd
 189         (-.) x y = op2 x y BCSub
 190         (*.) x y = op2 x y BCMul
 191         (/.) x y = op2 x y BCDiv
 192
 193 instance boolExpr ByteCode where
 194         (&.) x y =  op2 x y BCAnd
 195         (|.) x y =  op2 x y BCOr
 196         Not x = op x BCNot
 197         (==.) x y = op2 x y BCEq
 198         (!=.) x y = op2 x y BCNeq
 199         (<.)  x y = op2 x y  BCLes
 200         (>.)  x y = op2 x y BCGre
 201         (<=.) x y = op2 x y BCLeq
 202         (>=.) x y = op2 x y BCGeq
 203
 204 instance analogIO ByteCode where
 205         analogRead p = tell` [BCAnalogRead $ pin p]
 206         analogWrite p b = op b (BCAnalogWrite $ pin p)
 207
 208 instance digitalIO ByteCode where
 209         digitalRead p = tell` [BCDigitalRead $ pin p]
 210         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 211
 212 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 213 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 214 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 215 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 216 instance IF ByteCode where
 217         IF b t e = BCIfStmt b t e
 218         (?) b t = BCIfStmt b t $ tell` mempty
 219 BCIfStmt (BC b) (BC t) (BC e) = BC $
 220         freshl >>= \else->freshl >>= \endif->
 221         b >>| tell [BCJmpF else] >>|
 222         t >>| tell [BCJmp endif, BCLab else] >>|
 223         e >>| tell [BCLab endif]
 224
 225 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
 226 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
 227
 228 instance noOp ByteCode where noOp = tell` [BCNop]
 229
 230 unBC (BC x) = x
 231
 232 instance sds ByteCode where
 233         sds f = {main = BC $ freshs
 234                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 235                                 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
 236 //                              >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
 237                 where
 238                         addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(BCValue v)}:s.sdss]}
 239
 240         con f = undef
 241         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 242                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 243                 where
 244                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 245
 246 instance assign ByteCode where
 247         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 248                 where
 249                         //This is going to include pins as well, as variables
 250                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 251
 252 instance seq ByteCode where
 253         (>>=.) _ _ = abort "undef on >>=."
 254         (:.) (BC x) (BC y) = BC $ x >>| y
 255
 256 instance serial ByteCode where
 257         serialAvailable = tell` [BCSerialAvail]
 258         serialPrint s = tell` [BCSerialPrint]
 259         serialPrintln s = tell` [BCSerialPrintln]
 260         serialRead = tell` [BCSerialRead]
 261         serialParseInt = tell` [BCSerialParseInt]
 262
 263 instance userLed ByteCode where
 264         ledOn  (BC l) = BC $ l >>| tell [BCLedOn]
 265         ledOff (BC l) = BC $ l >>| tell [BCLedOff]
 266
 267 instance zero BCState where
 268         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 269
 270 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 271 toRealByteCode x s
 272 # (s, bc) = runBC x s
 273 # (bc, gtmap) = computeGotos bc 1
 274 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 275
 276 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 277 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 278 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 279 implGotos _ i = i
 280
 281 bclength :: BC -> Int
 282 bclength (BCPush s) = 1 + size (toByteCode s)
 283 bclength (BCSdsStore _) = 3
 284 bclength (BCSdsFetch _) = 3
 285 bclength (BCSdsPublish _) = 3
 286 bclength x = 1 + consNum{|*|} x
 287
 288 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 289 computeGotos [] _ = ([], 'DM'.newMap)
 290 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 291 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 292
 293 readable :: BC -> String
 294 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
 295         where
 296                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 297 readable b = printToString b
 298
 299 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 300 runBC (BC x) = execRWS x ()
 301
 302 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 303 toReadableByteCode x s
 304 # (s, bc) = runBC x s
 305 # (bc, gtmap) = computeGotos bc 0
 306 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 307         where
 308                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 309                 lineNumbers ls [] = []
 310                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 311                         where
 312                                 (ex, newls) = splitAt (bclength b - 1) ls
 313
 314 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 315 toMessages interval (bytes, st=:{sdss}) = (
 316         [MTSds sdsi $ toByteCode e\\{sdsi,sdsval=(BCValue e)}<-sdss] ++
 317         [MTTask interval bytes], st)
 318
 319 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 320 toSDSUpdate i v = [MTUpd i (to16bit v)]
 321
 322 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 323 Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 324 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 325 //              in (bcs, st.sdss)
 326         where
 327 //              bc = {main = ledOn (lit LED1)}
 328                 bc = sds \x=5 In
 329                         sds \y=4 In
 330                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 331
 332 to16bit :: Int -> String
 333 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 334
 335 from16bit :: String -> Int
 336 from16bit s = toInt s.[0] * 256 + toInt s.[1]
 337
 338 //derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode