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