BCValue is existential now

[mTask.git] / mTaskInterpret.icl

diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl
index 71555a5..c6a3e53 100644 (file)
--- a/mTaskInterpret.icl
+++ b/mTaskInterpret.icl
@@ -19,7 +19,7 @@ import Data.Monoid
 import Data.Functor
 import StdList
 from Data.Func import $
-from Text import class Text(lpad,concat,toUpperCase), instance Text String
+from Text import class Text(subString,lpad,concat,toUpperCase), instance Text String
 import qualified Text
 import Text.JSON
 
@@ -91,7 +91,7 @@ instance toString MTaskMSGRecv where
 toByteVal :: BC -> String
 toByteVal b = {toChar $ consIndex{|*|} b} +++
        case b of
-               (BCPush i) = i
+               (BCPush i) = toByteCode i
                (BCLab i) = {toChar i}
                (BCSdsStore i) = to16bit i
                (BCSdsFetch i) = to16bit i
@@ -105,6 +105,7 @@ toByteVal b = {toChar $ consIndex{|*|} b} +++
                (BCJmpF i) = {toChar i}
                _ = ""
 
+instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v
 instance toByteCode Bool where toByteCode b = toByteCode $ if b 1 0
 instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256}
 instance toByteCode Long where toByteCode (L n) = toByteCode n
@@ -119,6 +120,10 @@ instance toByteCode MTaskInterval where
        //Intervals have the first bit 1 and the rest is a 15 bit unsigned int
        toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256}
 
+//parseByteCode :: String -> BCValue
+//parseByteCode "b" = BCValue True
+//parseByteCode "i" = BCValue 0
+
 instance fromByteCode Bool where fromByteCode s = fromByteCode s == 1
 instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1]
 instance fromByteCode Long where fromByteCode s = L $ fromByteCode s
@@ -126,6 +131,19 @@ instance fromByteCode Char where fromByteCode s = fromInt $ fromByteCode s
 instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s
 instance fromByteCode Button where fromByteCode s = conses{|*|} !! fromByteCode s
 instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! fromByteCode s
+instance fromByteCode BCValue
+       where
+               fromByteCode s = let tail = subString 1 (size s) s in case s.[0] of
+                       'b' = BCValue $ castfbc True tail
+                       'i' = BCValue $ castfbc 0 tail
+                       'l' = BCValue $ castfbc (L 0) tail
+                       'c' = BCValue $ castfbc ('0') tail
+                       'B' = BCValue $ castfbc (NoButton) tail
+                       'L' = BCValue $ castfbc (LED1) tail
+               where
+                       castfbc :: a -> (String -> a) | mTaskType a
+                       castfbc _ = fromByteCode
+               
 instance fromByteCode MTaskInterval
        where
                fromByteCode s
@@ -139,9 +157,29 @@ instance toChar Pin where
        toChar (Digital p) = toChar $ consIndex{|*|} p
        toChar (Analog p) = toChar $ consIndex{|*|} p
 
-derive gPrint BC
+derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC
 derive class gCons BC
 
+consIndex{|BCValue|} _ = 0
+consName{|BCValue|} _ = "BCValue"
+conses{|BCValue|} = [BCValue 0]
+consNum{|BCValue|} _ = 1
+gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps
+
+gEditor{|BCValue|} = undef
+gText{|BCValue|} fm Nothing = []
+gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e)
+JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e)
+JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n
+       where
+               JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode]))
+               JSS = JSONDecode{|*|}
+gDefault{|BCValue|} = BCValue 0
+gEq{|BCValue|} (BCValue e) (BCValue f) = False
+
+derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
+derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
+
 op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr
 op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]
 
@@ -150,10 +188,8 @@ op (BC x) bc = BC $ x >>| tell [bc]
 
 tell` x = BC $ tell x
 
-instance zero Bool where zero = False
-
 instance arith ByteCode where
-       lit x = tell` [BCPush $ toByteCode x]
+       lit x = tell` [BCPush $ BCValue x]
        (+.) x y = op2 x y BCAdd
        (-.) x y = op2 x y BCSub
        (*.) x y = op2 x y BCMul
@@ -252,7 +288,7 @@ implGotos _ i = i
 
 import StdDebug
 bclength :: BC -> Int
-bclength (BCPush s) = 1 + size s
+bclength (BCPush s) = 1 + size (toByteCode s)
 bclength (BCSdsStore _) = 3
 bclength (BCSdsFetch _) = 3
 bclength (BCSdsPublish _) = 3
@@ -264,7 +300,7 @@ computeGotos [BCLab l:xs] i = appSnd ('DM'.put l i) (computeGotos xs i)
 computeGotos [x:xs] i = appFst (\bc->[x:bc]) (computeGotos xs $ i + bclength x)
 
 readable :: BC -> String
-readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d]
+readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:toByteCode d]
        where
                safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c)
 readable b = printToString b
@@ -308,3 +344,5 @@ to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
 
 from16bit :: String -> Int
 from16bit s = toInt s.[0] * 256 + toInt s.[1]
+
+//derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode