mTaskInterpret.icl

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