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