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