mTaskInterpret.icl

   1 implementation module mTaskInterpret
   2
   3 //import iTasks
   4 import Generics.gCons
   5
   6 import GenEq, StdMisc, StdArray, GenBimap
   7 import GenPrint
   8 import StdEnum
   9 import mTask
  10
  11 import StdInt
  12 import StdFile
  13 import StdString
  14
  15 from StdFunc import o, const
  16 import StdBool
  17 import StdTuple
  18 import Data.Tuple
  19 import Data.Monoid
  20 import Data.Functor
  21 import StdList
  22 from Data.Func import $
  23 from Text import class Text(concat,join,toUpperCase), instance Text String
  24
  25 import Data.Array
  26 import qualified Data.Map as DM
  27 import Text.Encodings.Base64
  28
  29 encode :: MTaskMSGSend -> String
  30 encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
  31         where
  32                 tob = case to of
  33                         OneShot = to16bit 0
  34                         OnInterval i = to16bit i
  35                         OnInterrupt _ = abort "Interrupts not implemented yet"
  36 encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
  37 encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
  38 encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
  39
  40 decode :: String -> MTaskMSGRecv
  41 decode x
  42 | size x == 0 = MTEmpty
  43 = case x.[0] of
  44         't' = MTTaskAck (from16bit (x % (1,3)))
  45         'd' = MTTaskDelAck (from16bit (x % (1,3)))
  46         'm' = MTMessage x
  47         's' = MTSDSAck (from16bit (x % (1,3)))
  48         'a' = MTSDSDelAck (from16bit (x % (1,3)))
  49         'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
  50         '\0' = MTEmpty
  51         '\n' = MTEmpty
  52         _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
  53
  54 safePrint :== toString o toJSON
  55
  56 instance toString MTaskInterval where
  57         toString OneShot = "One shot"
  58         toString (OnInterrupt i) = "Interrupt: " +++ toString i
  59         toString (OnInterval i) = "Every " +++ toString i +++ "ms"
  60
  61 instance toString MTaskMSGSend where
  62         toString (MTSds i v) = "Sds id: " +++ toString i
  63                 +++ " value " +++ safePrint v
  64         toString (MTTask to data) = "Task timeout: " +++ toString to
  65                 +++ " data " +++ safePrint data
  66         toString (MTTaskDel i) = "Task delete request: " +++ toString i
  67         toString (MTUpd i v) = "Update id: " +++ toString i
  68                 +++ " value " +++ safePrint v
  69
  70 instance toString MTaskMSGRecv where
  71         toString (MTTaskAck i) = "Task added with id: " +++ toString i
  72         toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i
  73         toString (MTSDSAck i) = "SDS added with id: " +++ toString i
  74         toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i
  75         toString (MTPub i v) = "Publish id: " +++ toString i
  76                 +++ " value " +++ safePrint v
  77         toString (MTMessage m) = m
  78         toString MTEmpty = "Empty message"
  79
  80 bclength :: BC -> Int
  81 bclength (BCPush _) = 3
  82 bclength (BCLab _) = 2
  83 bclength (BCSdsStore _) = 3
  84 bclength (BCSdsFetch _) = 3
  85 bclength (BCSdsPublish _) = 3
  86 bclength (BCAnalogRead _) = 2
  87 bclength (BCAnalogWrite _) = 2
  88 bclength (BCDigitalRead _) = 2
  89 bclength (BCDigitalWrite _) = 2
  90 bclength (BCLedOn _) = 2
  91 bclength (BCLedOff _) = 2
  92 bclength (BCJmp i) = 2
  93 bclength (BCJmpT i) = 2
  94 bclength (BCJmpF i) = 2
  95 bclength _ = 1
  96
  97 toByteVal :: BC -> String
  98 toByteVal b = {toChar $ consIndex{|*|} b} +++
  99         case b of
 100                 (BCPush i) = i
 101                 (BCLab i) = {toChar i}
 102                 (BCSdsStore i) = to16bit i
 103                 (BCSdsFetch i) = to16bit i
 104                 (BCSdsPublish i) = to16bit i
 105                 (BCAnalogRead i) = {toChar i}
 106                 (BCAnalogWrite i) = {toChar i}
 107                 (BCDigitalRead i) = {toChar i}
 108                 (BCDigitalWrite i) = {toChar i}
 109                 (BCLedOn i) = toByteCode i
 110                 (BCLedOff i) = toByteCode i
 111                 (BCJmp i) = {toChar i}
 112                 (BCJmpT i) = {toChar i}
 113                 (BCJmpF i) = {toChar i}
 114                 _ = ""
 115
 116 instance Semigroup (ByteCode a p) where
 117         mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
 118
 119 instance Monoid (ByteCode a p) where
 120         mempty = retrn []
 121
 122 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
 123 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
 124
 125 (<+->) infixr 1
 126 (<+->) m n :== m <++> retrn n
 127
 128 runBC (BC m) = m
 129
 130 retrn :: ([BC] -> ByteCode a p)
 131 retrn = BC o tuple
 132 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a q
 133 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
 134
 135 instance toByteCode Bool where toByteCode b = if b "\x01" "\x00"
 136 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
 137 instance toByteCode Long where toByteCode (L n) = toByteCode n
 138 instance toByteCode Char where toByteCode s = toString s
 139 instance toByteCode String where toByteCode s = undef
 140 instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s}
 141 instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s}
 142 instance toByteCode MTaskInterval where
 143         toByteCode OneShot = toByteCode 0
 144         //Intervals have the first bit 0 and the rest is a 15 bit unsigned int
 145         toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256}
 146         //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
 147         toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 148
 149 instance fromByteCode Bool where fromByteCode s = s == "\x01"
 150 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 151 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
 152 instance fromByteCode Char where fromByteCode s = toChar s.[0]
 153 instance fromByteCode String where fromByteCode s = undef
 154 instance fromByteCode Button where fromByteCode s = fromJust $ consByName s
 155 instance fromByteCode UserLED where fromByteCode s = fromJust $ consByName s
 156 instance fromByteCode MTaskInterval
 157         where
 158                 fromByteCode s
 159                 //Interval
 160                 | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of
 161                         0 = OneShot
 162                         i = OnInterval i
 163                 = OnInterrupt $ fromByteCode s bitand 127
 164
 165 instance toChar Pin where
 166         toChar (Digital p) = toChar $ consIndex{|*|} p
 167         toChar (Analog p) = toChar $ consIndex{|*|} p
 168
 169 derive gPrint BC
 170 derive class gCons BC
 171
 172 instance arith ByteCode where
 173         lit x = retrn [BCPush $ toByteCode x]
 174         (+.) x y = x <++> y <+-> [BCAdd]
 175         (-.) x y = x <++> y <+-> [BCSub]
 176         (*.) x y = x <++> y <+-> [BCMul]
 177         (/.) x y = x <++> y <+-> [BCDiv]
 178
 179 instance boolExpr ByteCode where
 180         (&.) x y = x <++> y <+-> [BCAnd]
 181         (|.) x y = x <++> y <+-> [BCOr]
 182         Not x = x <+-> [BCNot]
 183         (==.) x y = x <++> y <+-> [BCEq]
 184         (!=.) x y = x <++> y <+-> [BCNeq]
 185         (<.) x y = x <++> y <+-> [ BCLes]
 186         (>.)  x y = x <++> y <+-> [BCGre]
 187         (<=.) x y = x <++> y <+-> [BCLeq]
 188         (>=.) x y = x <++> y <+-> [BCGeq]
 189
 190 instance analogIO ByteCode where
 191         analogRead p = retrn [BCAnalogRead $ pin p]
 192         analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
 193
 194 instance digitalIO ByteCode where
 195         digitalRead p = retrn [BCDigitalRead $ pin p]
 196         digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
 197
 198 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
 199 instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e
 200 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
 201 instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e
 202 instance IF ByteCode where
 203         IF b t e = BCIfStmt b t e
 204         (?) b t = BCIfStmt b t $ retrn []
 205 BCIfStmt b t e =
 206         withLabel \else->withLabel \endif->
 207         b <++> retrn [BCJmpF else] <++> t
 208         <++> retrn [BCJmp endif,BCLab else] <++> e <++> retrn [BCLab endif]
 209
 210 instance noOp ByteCode where noOp = retrn [BCNop]
 211
 212 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
 213 withLabel f = BC \s->let [fresh:fs] = s.freshl
 214         in runBC (f fresh) {s & freshl=fs}
 215
 216 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
 217 withSDS f = BC \s->let [fresh:fs] = s.freshs
 218         in runBC (f fresh) {s & freshs=fs}
 219
 220 setSDS :: Int v -> ByteCode b q | toByteCode v
 221 setSDS ident val = BC \s->([], {s & sdss=[
 222         {BCShare|sdsi=ident,sdspub=False,sdsval=toByteCode val}:s.sdss]})
 223
 224 instance sds ByteCode where
 225         sds f = {main = withSDS \sds->
 226                         let (v In body) = f $ retrn [BCSdsFetch sds]
 227                         in setSDS sds v <++> unMain body
 228                 }
 229         con f = undef
 230         pub x = BC \s-> let ((i, bc), s`) = appFst makePub $ runBC x s
 231                         in  (bc, {s` & sdss=map (publish i) s`.sdss})
 232                 where
 233                         publish i s = if (i == s.sdsi) {s & sdspub=True} s
 234                         makePub [BCSdsFetch i:xs] = (i, [BCSdsPublish i:xs])
 235
 236 instance assign ByteCode where
 237         (=.) v e = e <++> fmp makeStore v
 238                 where makeStore [BCSdsFetch i:xs] = [BCSdsStore i:xs]
 239
 240 instance seq ByteCode where
 241         (>>=.) _ _ = abort "undef on >>=."
 242         (:.) x y = x <++> y
 243
 244 instance serial ByteCode where
 245         serialAvailable = retrn [BCSerialAvail]
 246         serialPrint s = retrn [BCSerialPrint]
 247         serialPrintln s = retrn [BCSerialPrintln]
 248         serialRead = retrn [BCSerialRead]
 249         serialParseInt = retrn [BCSerialParseInt]
 250
 251 instance userLed ByteCode where
 252         ledOn l = retrn [BCLedOn l]
 253         ledOff l = retrn [BCLedOff l]
 254
 255 instance zero BCState where
 256         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 257
 258 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)
 259 toRealByteCode x s
 260 # (bc, st) = runBC x s
 261 # (bc, gtmap) = computeGotos bc 1
 262 = (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st)
 263
 264 implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
 265 implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
 266 implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
 267 implGotos _ i = i
 268
 269 computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int)
 270 computeGotos [] _ = ([], 'DM'.newMap)
 271 computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 272 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs (i+(bclength x)))
 273
 274 readable :: BC -> String
 275 readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
 276         where
 277                 safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 278 readable b = printToString b
 279
 280 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
 281 toReadableByteCode x
 282 # (bc, st) = runBC x zero
 283 # (bc, gtmap) = computeGotos bc 0
 284 = (join "\n" $ map readable (map (implGotos gtmap) bc), st)
 285
 286 toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
 287 toMessages interval (bytes, st=:{sdss}) = (
 288         [MTSds s.sdsi (toString s.sdsval)\\s<-sdss] ++
 289         [MTTask interval bytes], st)
 290
 291 toSDSUpdate :: Int Int -> [MTaskMSGSend]
 292 toSDSUpdate i v = [MTUpd i (to16bit v)]
 293
 294 Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero
 295         where
 296                 bc = sds \x=5 In
 297                         sds \y=4 In
 298                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 299
 300 to16bit :: Int -> String
 301 to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 302
 303 from16bit :: String -> Int
 304 from16bit s = toInt s.[0] * 256 + toInt s.[1]