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(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 encode :: MTaskMSGSend -> String
  39 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
  40         where
  41                 tob = case to of
  42                         OneShot = to16bit 0
  43                         OnInterval i = to16bit i
  44                         OnInterrupt _ = abort "Interrupts not implemented yet"
  45 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
  46 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
  47 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
  48
  49 decode :: String -> MTaskMSGRecv
  50 decode x
  51 | size x == 0 = MTEmpty
  52 = case x.[0] of
  53         't' = MTTaskAck (from16bit (x % (1,3)))
  54         'd' = MTTaskDelAck (from16bit (x % (1,3)))
  55         'm' = MTMessage x
  56         's' = MTSDSAck (from16bit (x % (1,3)))
  57         'a' = MTSDSDelAck (from16bit (x % (1,3)))
  58         'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
  59         '\0' = MTEmpty
  60         '\n' = MTEmpty
  61         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  62
  63 safePrint :== toString o toJSON
  64
  65 instance toString MTaskInterval where
  66         toString OneShot = "One shot"
  67         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  68         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  69
  70 instance toString MTaskMSGSend where
  71         toString (MTSds i v) = "Sds id: " +++ toString i
  72                 +++ " value " +++ safePrint v
  73         toString (MTTask to data) = "Task timeout: " +++ toString to
  74                 +++ " data " +++ safePrint data
  75         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  76         toString (MTUpd i v) = "Update id: " +++ toString i
  77                 +++ " value " +++ safePrint v
  78
  79 instance toString MTaskMSGRecv where
  80         toString (MTTaskAck i) = "Task added with id: " +++ toString i
  81         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  82         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  83         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  84         toString (MTPub i v) = "Publish id: " +++ toString i
  85                 +++ " value " +++ safePrint v
  86         toString (MTMessage m) = m
  87         toString MTEmpty = "Empty message"
  88
  89 toByteVal :: BC -> String
  90 toByteVal b = {toChar $ consIndex{|*|} b} +++
  91         case b of
  92                 (BCPush i) = i
  93                 (BCLab i) = {toChar i}
  94                 (BCSdsStore i) = to16bit i
  95                 (BCSdsFetch i) = to16bit i
  96                 (BCSdsPublish i) = to16bit i
  97                 (BCAnalogRead i) = {toChar i}
  98                 (BCAnalogWrite i) = {toChar i}
  99                 (BCDigitalRead i) = {toChar i}
 100                 (BCDigitalWrite i) = {toChar i}
 101                 (BCJmp i) = {toChar i}
 102                 (BCJmpT i) = {toChar i}
 103                 (BCJmpF i) = {toChar i}
 104                 _ = ""
 105
 106 //(>>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode b q
 107 //(>>) m n = BC \s->(let (_, s1) = runBC m s in
 108 //      let (a, s2) = runBC n s1
 109 //      in (a, {s2 & bytecode=(s2.BCState.bytecode ++ s1.BCState.bytecode)}))
 110 //
 111 //(<+->) infixr 1
 112 //(<+->) m n :== m >> tell n
 113 //
 114 //runBC (BC m) = m
 115 //
 116 //tell :: [BC] -> ByteCode a p | mTaskType a
 117 //tell b = BC \s->(zero, {s & bytecode=b++s.bytecode})
 118 //
 119 //fmp :: (a -> BC) (ByteCode a p) -> ByteCode a q
 120 //fmp f b = BC \s->let (a, s`) = runBC b s in (a, {s` & code=[f a:s`.code]})
 121
 122 instance toByteCode Bool where toByteCode b = if b "\x01" "\x00"
 123 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
 124 instance toByteCode Long where toByteCode (L n) = toByteCode n
 125 instance toByteCode Char where toByteCode s = toString s
 126 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 127 instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s}
 128 instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s}
 129 instance toByteCode MTaskInterval where
 130         toByteCode OneShot = toByteCode 0
 131         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 132         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 133         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 134         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 135
 136 instance fromByteCode Bool where fromByteCode s = s == "\x01"
 137 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 138 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 139 instance fromByteCode Char where fromByteCode s = toChar s.[0]
 140 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 141 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[0]
 142 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[0]
 143 instance fromByteCode MTaskInterval
 144         where
 145                 fromByteCode s
 146                 //Interval
 147                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 148                         0 = OneShot
 149                         i = OnInterval i
 150                 = OnInterrupt $ fromByteCode s bitand 127
 151
 152 instance toChar Pin where
 153         toChar (Digital p) = toChar $ consIndex{|*|} p
 154         toChar (Analog p) = toChar $ consIndex{|*|} p
 155
 156 derive gPrint BC
 157 derive class gCons BC
 158
 159 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
 160 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 161
 162 op :: (ByteCode a p) BC -> ByteCode a Expr
 163 op (BC x) bc = BC $ x >>| tell [bc]
 164
 165 tell` x = BC $ tell x
 166
 167 instance zero Bool where zero = False
 168
 169 instance arith ByteCode where
 170         lit x = tell` [BCPush $ toByteCode x]
 171         (+.) x y = op2 x y BCAdd
 172         (-.) x y = op2 x y BCSub
 173         (*.) x y = op2 x y BCMul
 174         (/.) x y = op2 x y BCDiv
 175
 176 instance boolExpr ByteCode where
 177         (&.) x y =  op2 x y BCAnd
 178         (|.) x y =  op2 x y BCOr
 179         Not x = op x BCNot
 180         (==.) x y = op2 x y BCEq
 181         (!=.) x y = op2 x y BCNeq
 182         (<.)  x y = op2 x y  BCLes
 183         (>.)  x y = op2 x y BCGre
 184         (<=.) x y = op2 x y BCLeq
 185         (>=.) x y = op2 x y BCGeq
 186
 187 instance analogIO ByteCode where
 188         analogRead p = tell` [BCAnalogRead $ pin p]
 189         analogWrite p b = op b (BCAnalogWrite $ pin p)
 190
 191 instance digitalIO ByteCode where
 192         digitalRead p = tell` [BCDigitalRead $ pin p]
 193         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 194
 195 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 196 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 197 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 198 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 199 instance IF ByteCode where
 200         IF b t e = BCIfStmt b t e
 201         (?) b t = BCIfStmt b t $ tell` mempty
 202 BCIfStmt (BC b) (BC t) (BC e) = BC $
 203         freshl >>= \else->freshl >>= \endif->
 204         b >>| tell [BCJmpF else] >>|
 205         t >>| tell [BCJmp endif, BCLab else] >>|
 206         e >>| tell [BCLab endif]
 207
 208 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
 209 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
 210
 211 instance noOp ByteCode where noOp = tell` [BCNop]
 212
 213 unBC (BC x) = x
 214
 215 instance sds ByteCode where
 216         sds f = {main = BC $ freshs
 217                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 218                                 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
 219 //                              >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)}
 220                 where
 221                         addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=(dynamic v),sdsbc=toByteCode v}:s.sdss]}
 222
 223         con f = undef
 224         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 225                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 226                 where
 227                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 228
 229 instance assign ByteCode where
 230         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 231                 where
 232                         //This is going to include pins as well, as variables
 233                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 234
 235 instance seq ByteCode where
 236         (>>=.) _ _ = abort "undef on >>=."
 237         (:.) (BC x) (BC y) = BC $ x >>| y
 238
 239 instance serial ByteCode where
 240         serialAvailable = tell` [BCSerialAvail]
 241         serialPrint s = tell` [BCSerialPrint]
 242         serialPrintln s = tell` [BCSerialPrintln]
 243         serialRead = tell` [BCSerialRead]
 244         serialParseInt = tell` [BCSerialParseInt]
 245
 246 instance userLed ByteCode where
 247         ledOn  (BC l) = BC $ l >>| tell [BCLedOn]
 248         ledOff (BC l) = BC $ l >>| tell [BCLedOff]
 249
 250 func :: (a -> BC) [BC] -> [BC] | mTaskType a
 251 func f b = abort ('Text'.join "\n" (map printToString b))
 252
 253 instance zero BCState where
 254         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 255
 256 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 257 toRealByteCode x s
 258 # (s, bc) = runBC x s
 259 # (bc, gtmap) = computeGotos bc 1
 260 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 261
 262 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 263 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 264 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 265 implGotos _ i = i
 266
 267 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 268 computeGotos [] _ = ([], 'DM'.newMap)
 269 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 270 computeGotos [x:xs] i = appFst (\bc->[x:bc])
 271         (computeGotos xs $ i + 1 + consNum{|*|} x)
 272
 273 readable :: BC -> String
 274 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
 275         where
 276                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 277 readable b = printToString b
 278
 279 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 280 runBC (BC x) = execRWS x ()
 281
 282 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 283 toReadableByteCode x s
 284 # (s, bc) = runBC x s
 285 # (bc, gtmap) = computeGotos bc 0
 286 = ('Text'.join "\n" $ map readable (map (implGotos gtmap) bc), s)
 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 = let (bcs, st) = toReadableByteCode (unMain bc) zero
 298                 in (bcs, st.sdss)
 299         where
 300 //              bc = {main = ledOn (lit LED1)}
 301                 bc = sds \x=5 In
 302                         sds \y=4 In
 303                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 304
 305 to16bit :: Int -> String
 306 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 307
 308 from16bit :: String -> Int
 309 from16bit s = toInt s.[0] * 256 + toInt s.[1]