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 p
  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 _ = undef
 162
 163 instance assign ByteCode where
 164         (=.) v e = e <++> fmp makeStore v
 165
 166 makePub [] = []
 167 makePub [x:xs] = case x of
 168         BCSdsFetch i = [BCSdsPublish i:xs]
 169         y = [y:xs]
 170
 171 makeStore [] = []
 172 makeStore [x:xs] = case x of
 173         BCSdsFetch i = [BCSdsStore i:xs]
 174         y = [y:xs]
 175
 176 instance seq ByteCode where
 177         (>>=.) _ _ = abort "undef on >>=."
 178         (:.) x y = x <++> y
 179
 180 instance serial ByteCode where
 181         serialAvailable = retrn [BCSerialAvail]
 182         serialPrint s = retrn [BCSerialPrint]
 183         serialPrintln s = retrn [BCSerialPrintln]
 184         serialRead = retrn [BCSerialRead]
 185         serialParseInt = retrn [BCSerialParseInt]
 186
 187 instance zero BCState where
 188         zero = {freshl=[1..], freshs=[1..], sdss=[]}
 189
 190 makeSafe :: Char -> Char
 191 makeSafe c = c//toChar $ toInt c + 31
 192
 193 toRealByteCode :: (ByteCode a b) -> (String, BCState)
 194 toRealByteCode x
 195 # (bc, st) = runBC x zero
 196 = (concat $ map (toString o map makeSafe o toByteVal) bc, st)
 197
 198 readable :: BC -> String
 199 readable (BCPush d) = "BCPush " +++ concat (map safe d)
 200         where
 201                 safe c
 202                 | isControl c = "\\d" +++ toString (toInt c)
 203                 = toString c
 204 readable b = printToString b
 205
 206 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
 207 toReadableByteCode x
 208 # (bc, st) = runBC x zero
 209 = (join "\n" $ map readable bc, st)
 210
 211 //Start :: String
 212 //Start = toReadableByteCode bc
 213 //      where
 214 //              bc :: ByteCode Int Expr
 215 //              bc = (lit 36 +. lit 42) +. lit 44
 216 toMessages :: Int (String, BCState) -> [MTaskMessage]
 217 toMessages interval (bytes, {sdss}) = [MTSds i (toString b)\\(i,b)<-sdss] ++ [MTTask interval bytes]
 218
 219 Start = toMessages 500 $ toRealByteCode (unMain bc)
 220 //Start = fst $ toReadableByteCode $ unMain bc
 221         where
 222                 bc = sds \x=5 In
 223                         sds \y=4 In
 224                         {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
 225
 226 pub :: (ByteCode a b) -> ByteCode a b
 227 pub x = fmp makePub x
 228
 229 to16bit :: Int -> String
 230 to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
 231
 232 from16bit :: String -> Int
 233 from16bit s = toInt s.[0] * 265 + toInt s.[1]