mTaskInterpret.icl

   1 implementation module mTaskInterpret
   2
   3 //import iTasks
   4 import Generics.gCons
   5
   6 import GenEq, StdMisc, StdArray, GenBimap
   7 import GenPrint
   8 import StdEnum
   9 import mTask
  10
  11 import StdInt
  12 import StdFile
  13 import StdString
  14
  15 from StdFunc import o, const
  16 import StdBool
  17 import StdTuple
  18 import Data.Tuple
  19 import Data.Monoid
  20 import Data.Functor
  21 import StdList
  22 from Data.Func import $
  23 from Text import class Text(concat,join,toUpperCase), instance Text String
  24
  25 import qualified Data.Map as DM
  26 import Text.Encodings.Base64
  27
  28 encode :: MTaskMSGSend -> String
  29 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
  30         where
  31                 tob = case to of
  32                         OneShot = to16bit 0
  33                         OnInterval i = to16bit i
  34                         OnInterrupt _ = abort "Interrupts not implemented yet"
  35 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
  36 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
  37 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
  38
  39 decode :: String -> MTaskMSGRecv
  40 decode x
  41 | size x == 0 = MTEmpty
  42 = case x.[0] of
  43         't' = MTTaskAck (from16bit (x % (1,3)))
  44         'd' = MTTaskDelAck (from16bit (x % (1,3)))
  45         'm' = MTMessage x
  46         's' = MTSDSAck (from16bit (x % (1,3)))
  47         'a' = MTSDSDelAck (from16bit (x % (1,3)))
  48         'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
  49         '\0' = MTEmpty
  50         '\n' = MTEmpty
  51         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  52
  53 safePrint :== toString o toJSON
  54
  55 instance toString MTaskInterval where
  56         toString OneShot = "One shot"
  57         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  58         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  59
  60 instance toString MTaskMSGSend where
  61         toString (MTSds i v) = "Sds id: " +++ toString i
  62                 +++ " value " +++ safePrint v
  63         toString (MTTask to data) = "Task timeout: " +++ toString to
  64                 +++ " data " +++ safePrint data
  65         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  66         toString (MTUpd i v) = "Update id: " +++ toString i
  67                 +++ " value " +++ safePrint v
  68
  69 instance toString MTaskMSGRecv where
  70         toString (MTTaskAck i) = "Task added with id: " +++ toString i
  71         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  72         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  73         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  74         toString (MTPub i v) = "Publish id: " +++ toString i
  75                 +++ " value " +++ safePrint v
  76         toString (MTMessage m) = m
  77         toString MTEmpty = "Empty message"
  78
  79 bclength :: BC -> Int
  80 bclength (BCPush _) = 3
  81 bclength (BCLab _) = 2
  82 bclength (BCSdsStore _) = 3
  83 bclength (BCSdsFetch _) = 3
  84 bclength (BCSdsPublish _) = 3
  85 bclength (BCAnalogRead _) = 2
  86 bclength (BCAnalogWrite _) = 2
  87 bclength (BCDigitalRead _) = 2
  88 bclength (BCDigitalWrite _) = 2
  89 bclength (BCLedOn _) = 2
  90 bclength (BCLedOff _) = 2
  91 bclength (BCJmp i) = 2
  92 bclength (BCJmpT i) = 2
  93 bclength (BCJmpF i) = 2
  94 bclength _ = 1
  95
  96 toByteVal :: BC -> [Char]
  97 toByteVal b
  98 # bt = toChar $ consIndex{|*|} b
  99 = [bt:case b of
 100                 (BCPush i) = i
 101                 (BCLab i) = [toChar i]
 102                 (BCSdsStore i) = [c\\c<-:to16bit i]
 103                 (BCSdsFetch i) = [c\\c<-:to16bit i]
 104                 (BCSdsPublish i) = [c\\c<-:to16bit i]
 105                 (BCAnalogRead i) = [toChar i]
 106                 (BCAnalogWrite i) = [toChar i]
 107                 (BCDigitalRead i) = [toChar i]
 108                 (BCDigitalWrite i) = [toChar i]
 109                 (BCLedOn i) = i
 110                 (BCLedOff i) = i
 111                 (BCJmp i) = [toChar i]
 112                 (BCJmpT i) = [toChar i]
 113                 (BCJmpF i) = [toChar i]
 114                 _ = []]
 115
 116 instance Semigroup (ByteCode a p) where
 117         mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
 118
 119 instance Monoid (ByteCode a p) where
 120         mempty = retrn []
 121
 122 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
 123 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
 124
 125 (<+->) infixr 1
 126 (<+->) m n :== m <++> retrn n
 127
 128 runBC (BC m) = m
 129
 130 retrn :: ([BC] -> ByteCode a p)
 131 retrn = BC o tuple
 132 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a q
 133 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
 134
 135 instance toByteCode Bool where toByteCode b = toByteCode $ if b 1 0
 136 instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256]
 137 instance toByteCode Long where toByteCode (L n) = toByteCode n
 138 instance toByteCode Char where toByteCode c = [c]
 139 instance toByteCode String where toByteCode s = undef
 140 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
 141 instance toByteCode UserLED where toByteCode s = [toChar $ consIndex{|*|} s]
 142 instance toByteCode MTaskInterval where
 143         toByteCode OneShot = toByteCode 0
 144         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 145         toByteCode (OnInterval i) = map toChar [i/256 bitand 127, i rem 256]
 146         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 147         toByteCode (OnInterrupt i) = map toChar [i/256 bitor 128, i rem 256]
 148
 149 instance toChar Pin where
 150         toChar (Digital p) = toChar $ consIndex{|*|} p
 151         toChar (Analog p) = toChar $ consIndex{|*|} p
 152
 153 derive gPrint BC, AnalogPin, Pin, DigitalPin
 154 derive consIndex BC, Pin, Button, UserLED
 155 derive consName BC, Pin, Button
 156
 157 instance arith ByteCode where
 158         lit x = retrn [BCPush $ toByteCode x]
 159         (+.) x y = x <++> y <+-> [BCAdd]
 160         (-.) x y = x <++> y <+-> [BCSub]
 161         (*.) x y = x <++> y <+-> [BCMul]
 162         (/.) x y = x <++> y <+-> [BCDiv]
 163
 164 instance boolExpr ByteCode where
 165         (&.) x y = x <++> y <+-> [BCAnd]
 166         (|.) x y = x <++> y <+-> [BCOr]
 167         Not x = x <+-> [BCNot]
 168         (==.) x y = x <++> y <+-> [BCEq]
 169         (!=.) x y = x <++> y <+-> [BCNeq]
 170         (<.) x y = x <++> y <+-> [ BCLes]
 171         (>.)  x y = x <++> y <+-> [BCGre]
 172         (<=.) x y = x <++> y <+-> [BCLeq]
 173         (>=.) x y = x <++> y <+-> [BCGeq]
 174
 175 instance analogIO ByteCode where
 176         analogRead p = retrn [BCAnalogRead $ pin p]
 177         analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
 178
 179 instance digitalIO ByteCode where
 180         digitalRead p = retrn [BCDigitalRead $ pin p]
 181         digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
 182
 183 //instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 184 //instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 185 //instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 186 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 187 instance IF ByteCode where
 188         IF b t e = BCIfStmt b t e
 189         (?) b t = BCIfStmt b t $ retrn []
 190 BCIfStmt b t e =
 191         withLabel \else->withLabel \endif->
 192         b <++> retrn [BCJmpF else] <++> t
 193         <++> retrn [BCJmp endif,BCLab else] <++> e <++> retrn [BCLab endif]
 194
 195 instance noOp ByteCode where noOp = retrn [BCNop]
 196
 197 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
 198 withLabel f = BC \s->let [fresh:fs] = s.freshl
 199         in runBC (f fresh) {s & freshl=fs}
 200
 201 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
 202 withSDS f = BC \s->let [fresh:fs] = s.freshs
 203         in runBC (f fresh) {s & freshs=fs}
 204
 205 setSDS :: Int v -> ByteCode b q | toByteCode v
 206 setSDS ident val = BC \s->([], {s & sdss = [(ident, toByteCode val):s.sdss]})
 207
 208 instance sds ByteCode where
 209         sds f = {main = withSDS \sds->
 210                         let (v In body) = f $ retrn [BCSdsFetch sds]
 211                         in setSDS sds v <++> unMain body
 212                 }
 213         con f = undef
 214         pub x = fmp makePub x
 215
 216 instance assign ByteCode where
 217         (=.) v e = e <++> fmp makeStore v
 218
 219 makePub [] = []
 220 makePub [x:xs] = case x of
 221         BCSdsFetch i = [BCSdsPublish i:xs]
 222         y = [y:xs]
 223
 224 makeStore [] = []
 225 makeStore [x:xs] = case x of
 226         BCSdsFetch i = [BCSdsStore i:xs]
 227         y = [y:xs]
 228
 229 instance seq ByteCode where
 230         (>>=.) _ _ = abort "undef on >>=."
 231         (:.) x y = x <++> y
 232
 233 instance serial ByteCode where
 234         serialAvailable = retrn [BCSerialAvail]
 235         serialPrint s = retrn [BCSerialPrint]
 236         serialPrintln s = retrn [BCSerialPrintln]
 237         serialRead = retrn [BCSerialRead]
 238         serialParseInt = retrn [BCSerialParseInt]
 239
 240 instance userLed ByteCode where
 241         ledOn l = retrn [BCLedOn $ toByteCode l]
 242         ledOff l = retrn [BCLedOff $ toByteCode l]
 243
 244 instance zero BCState where
 245         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 246
 247 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 248 toRealByteCode x s
 249 # (bc, st) = runBC x s
 250 # (bc, gtmap) = computeGotos bc 1
 251 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st)
 252
 253 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 254 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 255 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 256 implGotos _ i = i
 257
 258 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 259 computeGotos [] _ = ([], 'DM'.newMap)
 260 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 261 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs (i+(bclength x)))
 262
 263 readable :: BC -> String
 264 readable (BCPush d) = "BCPush " +++ concat (map safe d)
 265         where
 266                 safe c
 267                 | isControl c = "\\d" +++ toString (toInt c)
 268                 = toString c
 269 readable b = printToString b
 270
 271 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
 272 toReadableByteCode x
 273 # (bc, st) = runBC x zero
 274 # (bc, gtmap) = computeGotos bc 0
 275 = (join "\n" $ map readable (map (implGotos gtmap) bc), st)
 276
 277 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 278 toMessages interval (bytes, st=:{sdss}) = ([MTSds i (toString b)\\(i,b)<-sdss] ++ [MTTask interval bytes], st)
 279
 280 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 281 toSDSUpdate i v = [MTUpd i (to16bit v)]
 282
 283 Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 284         where
 285                 bc = sds \x=5 In
 286                         sds \y=4 In
 287                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 288
 289 to16bit :: Int -> String
 290 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 291
 292 from16bit :: String -> Int
 293 from16bit s = toInt s.[0] * 256 + toInt s.[1]