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 (toByteCode v)) >>| unBC (unMain bdy)}
 219                 where
 220                         addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=v}:s.sdss]}
 221
 222         con f = undef
 223         pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s])
 224                         (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty
 225                 where
 226                         publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]}
 227
 228 instance assign ByteCode where
 229         (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v
 230                 where
 231                         //This is going to include pins as well, as variables
 232                         makeStore [BCSdsFetch i] = [BCSdsStore i]
 233
 234 instance seq ByteCode where
 235         (>>=.) _ _ = abort "undef on >>=."
 236         (:.) (BC x) (BC y) = BC $ x >>| y
 237
 238 instance serial ByteCode where
 239         serialAvailable = tell` [BCSerialAvail]
 240         serialPrint s = tell` [BCSerialPrint]
 241         serialPrintln s = tell` [BCSerialPrintln]
 242         serialRead = tell` [BCSerialRead]
 243         serialParseInt = tell` [BCSerialParseInt]
 244
 245 instance userLed ByteCode where
 246         ledOn  (BC l) = BC $ l >>| tell [BCLedOn]
 247         ledOff (BC l) = BC $ l >>| tell [BCLedOff]
 248
 249 func :: (a -> BC) [BC] -> [BC] | mTaskType a
 250 func f b = abort ('Text'.join "\n" (map printToString b))
 251
 252 instance zero BCState where
 253         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 254
 255 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 256 toRealByteCode x s
 257 # (s, bc) = runBC x s
 258 # (bc, gtmap) = computeGotos bc 1
 259 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s)
 260
 261 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 262 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 263 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 264 implGotos _ i = i
 265
 266 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 267 computeGotos [] _ = ([], 'DM'.newMap)
 268 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 269 computeGotos [x:xs] i = appFst (\bc->[x:bc])
 270         (computeGotos xs $ i + 1 + consNum{|*|} x)
 271
 272 readable :: BC -> String
 273 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
 274         where
 275                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 276 readable b = printToString b
 277
 278 runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC]))
 279 runBC (BC x) = execRWS x ()
 280
 281 toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState)
 282 toReadableByteCode x s
 283 # (s, bc) = runBC x s
 284 # (bc, gtmap) = computeGotos bc 0
 285 = ('Text'.join "\n" $ map readable (map (implGotos gtmap) bc), s)
 286
 287 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 288 toMessages interval (bytes, st=:{sdss}) = (
 289         [MTSds s.sdsi (toByteCode s.sdsval)\\s<-sdss] ++
 290         [MTTask interval bytes], st)
 291
 292 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 293 toSDSUpdate i v = [MTUpd i (to16bit v)]
 294
 295 //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 296 Start = let (bcs, st) = toReadableByteCode (unMain bc) zero
 297                 in (bcs, st.sdss)
 298         where
 299 //              bc = {main = ledOn (lit LED1)}
 300                 bc = sds \x=5 In
 301                         sds \y=4 In
 302                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 303
 304 to16bit :: Int -> String
 305 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 306
 307 from16bit :: String -> Int
 308 from16bit s = toInt s.[0] * 256 + toInt s.[1]