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