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