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