1 implementation module mTaskInterpret
4 import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
12 from StdFunc import o, const
19 from Data.Func import $
20 from Text import class Text(concat,join,toUpperCase), instance Text String
22 import Text.Encodings.Base64
24 toByteVal :: BC -> [Char]
26 # bt = toChar $ consIndex{|*|} b + 1
29 (BCSdsStore i) = [toChar i]
30 (BCSdsFetch i) = [toChar i]
31 (BCSdsPublish i) = [toChar i]
32 (BCAnalogRead i) = [toChar i]
33 (BCAnalogWrite i) = [toChar i]
34 (BCDigitalRead i) = [toChar i]
35 (BCDigitalWrite i) = [toChar i]
36 (BCJmp i) = [toChar i]
37 (BCJmpT i) = [toChar i]
38 (BCJmpF i) = [toChar i]
41 instance Semigroup (ByteCode a p) where
42 mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t)
44 instance Monoid (ByteCode a p) where
47 (<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r
48 (<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t)
51 (<+->) m n :== m <++> retrn n
55 retrn :: ([BC] -> ByteCode a p)
57 fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a p
58 fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)
60 instance toByteCode Bool where
61 toByteCode True = [toChar 1]
62 toByteCode False = [toChar 0]
63 instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256]
64 instance toByteCode Long where toByteCode (L n) = toByteCode n
65 instance toByteCode Char where toByteCode c = [c]
66 instance toByteCode String where toByteCode s = undef
67 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
69 instance toChar Pin where
70 toChar (Digital p) = toChar $ consIndex{|*|} p + 1
71 toChar (Analog p) = toChar $ consIndex{|*|} p + 1
73 derive gPrint BC, AnalogPin, Pin, DigitalPin
74 derive consIndex BC, Pin, Button
75 derive consName BC, Pin, Button
77 instance arith ByteCode where
78 lit x = retrn [BCPush $ toByteCode x]
79 (+.) x y = x <++> y <+-> [BCAdd]
80 (-.) x y = x <++> y <+-> [BCSub]
81 (*.) x y = x <++> y <+-> [BCMul]
82 (/.) x y = x <++> y <+-> [BCDiv]
84 instance boolExpr ByteCode where
85 (&.) x y = x <++> y <+-> [BCAnd]
86 (|.) x y = x <++> y <+-> [BCOr]
87 Not x = x <+-> [BCNot]
88 (==.) x y = x <++> y <+-> [BCEq]
89 (!=.) x y = x <++> y <+-> [BCNeq]
90 (<.) x y = x <++> y <+-> [ BCLes]
91 (>.) x y = x <++> y <+-> [BCGre]
92 (<=.) x y = x <++> y <+-> [BCLeq]
93 (>=.) x y = x <++> y <+-> [BCGeq]
95 instance analogIO ByteCode where
96 analogRead p = retrn [BCAnalogRead $ pin p]
97 analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
99 instance digitalIO ByteCode where
100 digitalRead p = retrn [BCDigitalRead $ pin p]
101 digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
103 instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
104 instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
105 instance If ByteCode Stmt Stmt e where If b t e = BCIfStmt b t e
106 instance If ByteCode x y Expr where If b t e = BCIfStmt b t e
107 instance IF ByteCode where
108 IF b t e = BCIfStmt b t e
109 (?) b t = BCIfStmt b t $ retrn []
110 BCIfStmt b t e = withLabel \else->withLabel \endif->retrn [BCJmpF else] <++> t
111 <++> retrn [BCJmp endif] <++> e <++> retrn [BCLab endif]
113 instance noOp ByteCode where noOp = mempty
115 withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q
116 withLabel f = BC \s->let [fresh:fs] = s.freshl
117 in runBC (f fresh) {s & freshl=fs}
119 withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q
120 withSDS f = BC \s->let [fresh:fs] = s.freshs
121 in runBC (f fresh) {s & freshs=fs}
123 setSDS :: Int v -> ByteCode b q | toByteCode v
124 setSDS ident val = BC \s->([], {s & sdss = [(ident, toByteCode val):s.sdss]})
126 instance sds ByteCode where
127 sds f = {main = withSDS \sds->
128 let (v In body) = f $ retrn [BCSdsFetch sds]
129 in setSDS sds v <++> unMain body
134 instance assign ByteCode where
135 (=.) v e = e <++> fmp makeStore v
138 makePub [x:xs] = case x of
139 BCSdsFetch i = [BCSdsPublish i:xs]
143 makeStore [x:xs] = case x of
144 BCSdsFetch i = [BCSdsStore i:xs]
147 instance seq ByteCode where
148 (>>=.) _ _ = abort "undef on >>=."
151 instance serial ByteCode where
152 serialAvailable = retrn [BCSerialAvail]
153 serialPrint s = retrn [BCSerialPrint]
154 serialPrintln s = retrn [BCSerialPrintln]
155 serialRead = retrn [BCSerialRead]
156 serialParseInt = retrn [BCSerialParseInt]
158 instance zero BCState where
159 zero = {freshl=[1..], freshs=[1..], sdss=[]}
161 makeSafe :: Char -> Char
162 makeSafe c = c//toChar $ toInt c + 31
164 toRealByteCode :: (ByteCode a b) -> (String, BCState)
166 # (bc, st) = runBC x zero
167 = (concat $ map (toString o map makeSafe o toByteVal) bc, st)
169 readable :: BC -> String
170 readable (BCPush d) = "BCPush " +++ concat (map safe d)
173 | isControl c = "\\d" +++ toString (toInt c)
175 readable b = printToString b
177 toReadableByteCode :: (ByteCode a b) -> (String, BCState)
179 # (bc, st) = runBC x zero
180 = (join "\n" $ map readable bc, st)
183 //Start = toReadableByteCode bc
185 // bc :: ByteCode Int Expr
186 // bc = (lit 36 +. lit 42) +. lit 44
187 getSDSBytes :: BCState -> String
188 getSDSBytes {sdss} = concat $ map sd sdss
189 where sd (i, v) = "s" +++ toString (toChar i) +++ toString v +++ "\n"
191 getTaskBytes :: Int String -> String
192 getTaskBytes i b = "t" +++ to16bit i +++ to16bit (size b) +++ b
194 Start = getSDSBytes (snd bc`) +++ getTaskBytes 400 (fst bc`)
195 //Start = fst $ toReadableByteCode $ unMain bc
197 bc` = toRealByteCode (unMain bc)
198 bc :: Main (ByteCode Int Stmt)
200 {main = x =. x +. lit 1 :. pub x}
202 pub :: (ByteCode a b) -> ByteCode a b
203 pub x = fmp makePub x
205 to16bit :: Int -> String
206 to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
208 ////Run test programma en pretty print
210 ////Start = "t" +++ to16bit (size b) +++ b
211 //Start :: Main (ByteCode Int Expr)
214 // bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
215 // b = toRealByteCode bc
216 //Start :: ByteCode Int Expr
217 //Start = If (lit True) (analogRead A1) (analogRead A0)
218 //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)