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 bclength :: BC -> Int
  90 bclength (BCPush _) = 3
  91 bclength (BCLab _) = 2
  92 bclength (BCSdsStore _) = 3
  93 bclength (BCSdsFetch _) = 3
  94 bclength (BCSdsPublish _) = 3
  95 bclength (BCAnalogRead _) = 2
  96 bclength (BCAnalogWrite _) = 2
  97 bclength (BCDigitalRead _) = 2
  98 bclength (BCDigitalWrite _) = 2
  99 bclength (BCLedOn _) = 2
 100 bclength (BCLedOff _) = 2
 101 bclength (BCJmp i) = 2
 102 bclength (BCJmpT i) = 2
 103 bclength (BCJmpF i) = 2
 104 bclength _ = 1
 105
 106 toByteVal :: BC -> String
 107 toByteVal b = {toChar $ consIndex{|*|} b} +++
 108         case b of
 109                 (BCPush i) = i
 110                 (BCLab i) = {toChar i}
 111                 (BCSdsStore i) = to16bit i
 112                 (BCSdsFetch i) = to16bit i
 113                 (BCSdsPublish i) = to16bit i
 114                 (BCAnalogRead i) = {toChar i}
 115                 (BCAnalogWrite i) = {toChar i}
 116                 (BCDigitalRead i) = {toChar i}
 117                 (BCDigitalWrite i) = {toChar i}
 118                 (BCLedOn i) = toByteCode i
 119                 (BCLedOff i) = toByteCode i
 120                 (BCJmp i) = {toChar i}
 121                 (BCJmpT i) = {toChar i}
 122                 (BCJmpF i) = {toChar i}
 123                 _ = ""
 124
 125 //(>>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode b q
 126 //(>>) m n = BC \s->(let (_, s1) = runBC m s in
 127 //      let (a, s2) = runBC n s1
 128 //      in (a, {s2 & bytecode=(s2.BCState.bytecode ++ s1.BCState.bytecode)}))
 129 //
 130 //(<+->) infixr 1
 131 //(<+->) m n :== m >> tell n
 132 //
 133 //runBC (BC m) = m
 134 //
 135 //tell :: [BC] -> ByteCode a p | mTaskType a
 136 //tell b = BC \s->(zero, {s & bytecode=b++s.bytecode})
 137 //
 138 //fmp :: (a -> BC) (ByteCode a p) -> ByteCode a q
 139 //fmp f b = BC \s->let (a, s`) = runBC b s in (a, {s` & code=[f a:s`.code]})
 140
 141 instance toByteCode Bool where toByteCode b = if b "\x01" "\x00"
 142 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
 143 instance toByteCode Long where toByteCode (L n) = toByteCode n
 144 instance toByteCode Char where toByteCode s = toString s
 145 instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s
 146 instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s}
 147 instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s}
 148 instance toByteCode MTaskInterval where
 149         toByteCode OneShot = toByteCode 0
 150         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 151         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 152         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 153         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 154
 155 instance fromByteCode Bool where fromByteCode s = s == "\x01"
 156 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 157 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 158 instance fromByteCode Char where fromByteCode s = toChar s.[0]
 159 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 160 instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[0]
 161 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[0]
 162 instance fromByteCode MTaskInterval
 163         where
 164                 fromByteCode s
 165                 //Interval
 166                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 167                         0 = OneShot
 168                         i = OnInterval i
 169                 = OnInterrupt $ fromByteCode s bitand 127
 170
 171 instance toChar Pin where
 172         toChar (Digital p) = toChar $ consIndex{|*|} p
 173         toChar (Analog p) = toChar $ consIndex{|*|} p
 174
 175 derive gPrint BC
 176 derive class gCons BC
 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 zero Bool where zero = False
 187
 188 instance arith ByteCode where
 189         lit x = tell` [BCPush $ toByteCode x]
 190         (+.) x y = op2 x y BCAdd
 191         (-.) x y = op2 x y BCSub
 192         (*.) x y = op2 x y BCMul
 193         (/.) x y = op2 x y BCDiv
 194
 195 instance boolExpr ByteCode where
 196         (&.) x y =  op2 x y BCAnd
 197         (|.) x y =  op2 x y BCOr
 198         Not x = op x BCNot
 199         (==.) x y = op2 x y BCEq
 200         (!=.) x y = op2 x y BCNeq
 201         (<.)  x y = op2 x y  BCLes
 202         (>.)  x y = op2 x y BCGre
 203         (<=.) x y = op2 x y BCLeq
 204         (>=.) x y = op2 x y BCGeq
 205
 206 instance analogIO ByteCode where
 207         analogRead p = tell` [BCAnalogRead $ pin p]
 208         analogWrite p b = op b (BCAnalogWrite $ pin p)
 209
 210 instance digitalIO ByteCode where
 211         digitalRead p = tell` [BCDigitalRead $ pin p]
 212         digitalWrite p b = op b (BCDigitalWrite $ pin p)
 213
 214 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 215 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 216 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 217 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 218 instance IF ByteCode where
 219         IF b t e = BCIfStmt b t e
 220         (?) b t = BCIfStmt b t $ tell` mempty
 221 BCIfStmt (BC b) (BC t) (BC e) = BC $
 222         freshl >>= \else->freshl >>= \endif->
 223         b >>| tell [BCJmpF else] >>|
 224         t >>| tell [BCJmp endif, BCLab else] >>|
 225         e >>| tell [BCLab endif]
 226
 227 freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr
 228 freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr
 229
 230 instance noOp ByteCode where noOp = tell` [BCNop]
 231
 232 unBC (BC x) = x
 233
 234 instance sds ByteCode where
 235         sds f = {main = BC $ freshs
 236                                 >>= \sds->pure (f (tell` [BCSdsFetch sds]))
 237                                 >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)}
 238                 where
 239                         addSDS i v s = {s & sdss=[
 240                                 {sdsi=i,sdspub=False,sdsval=toByteCode v}:s.sdss]}
 241         con f = undef
 242         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 243                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 244                 where
 245                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 246
 247 instance assign ByteCode where
 248         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 249                 where
 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 $ censor (\[BCPush d]->[BCLedOn  $ fromByteCode d]) l
 265         ledOff (BC l) = BC $ censor (\[BCPush d]->[BCLedOff $ fromByteCode d]) l
 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 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 282 computeGotos [] _ = ([], 'DM'.newMap)
 283 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 284 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs (i+(bclength x)))
 285
 286 readable :: BC -> String
 287 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
 288         where
 289                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 290 readable b = printToString b
 291
 292 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 293 runBC (BC x) = execRWS x ()
 294
 295 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 296 toReadableByteCode x s
 297 # (s, bc) = runBC x s
 298 # (bc, gtmap) = computeGotos bc 0
 299 = ('Text'.join "\n" $ map readable (map (implGotos gtmap) bc), s)
 300
 301 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 302 toMessages interval (bytes, st=:{sdss}) = (
 303         [MTSds s.sdsi (toString s.sdsval)\\s<-sdss] ++
 304         [MTTask interval bytes], st)
 305
 306 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 307 toSDSUpdate i v = [MTUpd i (to16bit v)]
 308
 309 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 310 Start = fst $ toReadableByteCode (unMain bc) zero
 311         where
 312 //              bc = {main = ledOn (lit LED1)}
 313                 bc = sds \x=5 In
 314                         sds \y=4 In
 315                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 316
 317 to16bit :: Int -> String
 318 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 319
 320 from16bit :: String -> Int
 321 from16bit s = toInt s.[0] * 256 + toInt s.[1]