mTaskInterpret.icl

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