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