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(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) = 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 Bool where toByteCode b = toByteCode $ if b 1 0
 109 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
 110 instance toByteCode Long where toByteCode (L n) = toByteCode n
 111 instance toByteCode Char where toByteCode c = toByteCode $ toInt c
 112 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 113 instance toByteCode Button where toByteCode s = toByteCode $ consIndex{|*|} s
 114 instance toByteCode UserLED where toByteCode s = toByteCode $ consIndex{|*|} s
 115 instance toByteCode MTaskInterval where
 116         toByteCode OneShot = toByteCode 0
 117         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 118         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 119         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 120         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 121
 122 instance fromByteCode Bool where fromByteCode s = fromByteCode s == 1
 123 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 124 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 125 instance fromByteCode Char where fromByteCode s = fromInt $ fromByteCode s
 126 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 127 instance fromByteCode Button where fromByteCode s = conses{|*|} !! fromByteCode s
 128 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! fromByteCode s
 129 instance fromByteCode MTaskInterval
 130         where
 131                 fromByteCode s
 132                 //Interval
 133                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 134                         0 = OneShot
 135                         i = OnInterval i
 136                 = OnInterrupt $ fromByteCode s bitand 127
 137
 138 instance toChar Pin where
 139         toChar (Digital p) = toChar $ consIndex{|*|} p
 140         toChar (Analog p) = toChar $ consIndex{|*|} p
 141
 142 derive gPrint BC
 143 derive class gCons BC
 144
 145 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
 146 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 147
 148 op :: (ByteCode a p) BC -> ByteCode a Expr
 149 op (BC x) bc = BC $ x >>| tell [bc]
 150
 151 tell` x = BC $ tell x
 152
 153 instance zero Bool where zero = False
 154
 155 instance arith ByteCode where
 156         lit x = tell` [BCPush $ toByteCode x]
 157         (+.) x y = op2 x y BCAdd
 158         (-.) x y = op2 x y BCSub
 159         (*.) x y = op2 x y BCMul
 160         (/.) x y = op2 x y BCDiv
 161
 162 instance boolExpr ByteCode where
 163         (&.) x y =  op2 x y BCAnd
 164         (|.) x y =  op2 x y BCOr
 165         Not x = op x BCNot
 166         (==.) x y = op2 x y BCEq
 167         (!=.) x y = op2 x y BCNeq
 168         (<.)  x y = op2 x y  BCLes
 169         (>.)  x y = op2 x y BCGre
 170         (<=.) x y = op2 x y BCLeq
 171         (>=.) x y = op2 x y BCGeq
 172
 173 instance analogIO ByteCode where
 174         analogRead p = tell` [BCAnalogRead $ pin p]
 175         analogWrite p b = op b (BCAnalogWrite $ pin p)
 176
 177 instance digitalIO ByteCode where
 178         digitalRead p = tell` [BCDigitalRead $ pin p]
 179         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 180
 181 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 182 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 183 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 184 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 185 instance IF ByteCode where
 186         IF b t e = BCIfStmt b t e
 187         (?) b t = BCIfStmt b t $ tell` mempty
 188 BCIfStmt (BC b) (BC t) (BC e) = BC $
 189         freshl >>= \else->freshl >>= \endif->
 190         b >>| tell [BCJmpF else] >>|
 191         t >>| tell [BCJmp endif, BCLab else] >>|
 192         e >>| tell [BCLab endif]
 193
 194 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
 195 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
 196
 197 instance noOp ByteCode where noOp = tell` [BCNop]
 198
 199 unBC (BC x) = x
 200
 201 instance sds ByteCode where
 202         sds f = {main = BC $ freshs
 203                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 204                                 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
 205 //                              >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
 206                 where
 207                         addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(dynamic v),sdsbc=toByteCode v}:s.sdss]}
 208
 209         con f = undef
 210         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 211                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 212                 where
 213                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 214
 215 instance assign ByteCode where
 216         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 217                 where
 218                         //This is going to include pins as well, as variables
 219                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 220
 221 instance seq ByteCode where
 222         (>>=.) _ _ = abort "undef on >>=."
 223         (:.) (BC x) (BC y) = BC $ x >>| y
 224
 225 instance serial ByteCode where
 226         serialAvailable = tell` [BCSerialAvail]
 227         serialPrint s = tell` [BCSerialPrint]
 228         serialPrintln s = tell` [BCSerialPrintln]
 229         serialRead = tell` [BCSerialRead]
 230         serialParseInt = tell` [BCSerialParseInt]
 231
 232 instance userLed ByteCode where
 233         ledOn  (BC l) = BC $ l >>| tell [BCLedOn]
 234         ledOff (BC l) = BC $ l >>| tell [BCLedOff]
 235
 236 func :: (a -> BC) [BC] -> [BC] | mTaskType a
 237 func f b = abort ('Text'.join "\n" (map printToString b))
 238
 239 instance zero BCState where
 240         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 241
 242 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 243 toRealByteCode x s
 244 # (s, bc) = runBC x s
 245 # (bc, gtmap) = computeGotos bc 1
 246 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 247
 248 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 249 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 250 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 251 implGotos _ i = i
 252
 253 import StdDebug
 254 bclength :: BC -> Int
 255 bclength (BCPush s) = 1 + size s
 256 bclength (BCSdsStore _) = 3
 257 bclength (BCSdsFetch _) = 3
 258 bclength (BCSdsPublish _) = 3
 259 bclength x = 1 + consNum{|*|} x
 260
 261 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 262 computeGotos [] _ = ([], 'DM'.newMap)
 263 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 264 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 265
 266 readable :: BC -> String
 267 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
 268         where
 269                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 270 readable b = printToString b
 271
 272 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 273 runBC (BC x) = execRWS x ()
 274
 275 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 276 toReadableByteCode x s
 277 # (s, bc) = runBC x s
 278 | not (trace_tn $ ('Text'.join "\n" $ lineNumbers numbers bc) +++ "\n") = undef
 279 # (bc, gtmap) = computeGotos bc 0
 280 = ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s)
 281         where
 282                 numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..]
 283                 lineNumbers ls [] = []
 284                 lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc]
 285                         where
 286                                 (ex, newls) = splitAt (bclength b - 1) ls
 287
 288 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 289 toMessages interval (bytes, st=:{sdss}) = (
 290         [MTSds s.sdsi s.sdsbc\\s<-sdss] ++
 291         [MTTask interval bytes], st)
 292
 293 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 294 toSDSUpdate i v = [MTUpd i (to16bit v)]
 295
 296 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 297 Start = fst $ toReadableByteCode (unMain $ blink LED1) zero
 298 //Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 299 //              in (bcs, st.sdss)
 300         where
 301 //              bc = {main = ledOn (lit LED1)}
 302                 bc = sds \x=5 In
 303                         sds \y=4 In
 304                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 305
 306 to16bit :: Int -> String
 307 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 308
 309 from16bit :: String -> Int
 310 from16bit s = toInt s.[0] * 256 + toInt s.[1]