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