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