From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 13 Mar 2017 12:01:32 +0000 (+0100)
Subject: BCValue is existential now
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=18c1286739897b65578e87b17167c6cef1922a3b;p=mTask.git

BCValue is existential now
---

diff --git a/Shares/mTaskShare.dcl b/Shares/mTaskShare.dcl
index a6967af..df4a2f1 100644
--- a/Shares/mTaskShare.dcl
+++ b/Shares/mTaskShare.dcl
@@ -4,12 +4,21 @@ import iTasks
 import iTasks._Framework.Serialization
 
 derive class iTask MTaskShareType
+
+derive gEditor MTaskShare
+derive gText MTaskShare
+derive JSONEncode MTaskShare
+derive JSONDecode MTaskShare
+derive gDefault MTaskShare
+derive gEq MTaskShare
+
 :: MTaskShareType = MTaskWithShare String | MTaskLens String
 :: MTaskShare =
 		{withTask :: String
 		,identifier :: Int
 		,realShare :: MTaskShareType
 		,value :: String
+		,dynvalue :: Dynamic
 		}
 
 manageShares :: [MTaskShare] -> Task ()
diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl
index 8eb7dc0..7f9a2f4 100644
--- a/Shares/mTaskShare.icl
+++ b/Shares/mTaskShare.icl
@@ -8,6 +8,14 @@ import mTask
 from Data.Func import $
 
 derive class iTask MTaskShareType
+
+derive gEditor MTaskShare
+derive gText MTaskShare
+derive JSONEncode MTaskShare
+derive JSONDecode MTaskShare
+derive gDefault MTaskShare
+gEq{|MTaskShare|} m1 m2 = m1.identifier == m2.identifier
+
 manageShares :: [MTaskShare] -> Task ()
 manageShares shares =
 	forever (enterChoice "Choose share to update" [ChooseFromGrid id] shares
@@ -45,5 +53,6 @@ makeShare withTask identifier value = treturn
 		|withTask=withTask
 		,identifier=identifier
 		,value=value
+		,dynvalue=dynamic value
 		,realShare=MTaskWithShare $ "mTaskSDS-" +++ toString identifier
 		} >>= \sh->set value (getSDSShare sh) >>| treturn sh
diff --git a/Tasks/mTaskTask.dcl b/Tasks/mTaskTask.dcl
index b27bb73..19a3db0 100644
--- a/Tasks/mTaskTask.dcl
+++ b/Tasks/mTaskTask.dcl
@@ -4,7 +4,7 @@ import Devices.mTaskDevice
 import mTask
 import iTasks
 
-derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, UserLED, RWST
+derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, RWST
 
 :: MTaskTask = {
 		name :: String,
diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl
index 9cc5a98..1cd45f8 100644
--- a/Tasks/mTaskTask.icl
+++ b/Tasks/mTaskTask.icl
@@ -5,7 +5,7 @@ import iTasks
 
 import iTasks._Framework.Serialization
 
-derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, UserLED, RWST, Identity
+derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, RWST, Identity
 
 makeTask :: String Int -> Task MTaskTask
 makeTask name ident = get currentDateTime 
diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl
index 47e6647..785af5d 100644
--- a/Utils/SDS.dcl
+++ b/Utils/SDS.dcl
@@ -4,8 +4,6 @@ import Shares.mTaskShare
 import Devices.mTaskDevice
 import iTasks
 
-derive class iTask MTaskShare
-
 memoryShare :: String a -> Shared a | iTask a
 
 deviceStore :: Shared [MTaskDevice]
diff --git a/Utils/SDS.icl b/Utils/SDS.icl
index 9c6b46a..920c7a6 100644
--- a/Utils/SDS.icl
+++ b/Utils/SDS.icl
@@ -8,8 +8,6 @@ import Tasks.Examples
 import qualified Data.Map as DM
 from Data.Func import $
 
-derive class iTask MTaskShare
-
 memoryShare :: String a -> Shared a | iTask a
 memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
 
diff --git a/mTask.dcl b/mTask.dcl
index 9b82478..b1510af 100644
--- a/mTask.dcl
+++ b/mTask.dcl
@@ -14,10 +14,6 @@ todo:
 	imporove setp: >>*.
 */
 
-import GenPrint
-import Generics.gCons
-import Generics.gdynamic
-
 //import iTasks
 //
 //import iTasks._Framework.Generic
@@ -26,6 +22,7 @@ import StdClass
 import GenEq, StdMisc, StdArray
 
 import mTaskCode, mTaskSimulation, mTaskInterpret
+//import mTaskCode, mTaskInterpret
 import mTaskSerial, mTaskLCD
 
 // =================== mTask ===================
@@ -66,7 +63,7 @@ instance == MTask
 unMain :: (Main x) -> x
 
 class arith v where
-  lit :: t -> v t Expr | toCode t & toByteCode t
+  lit :: t -> v t Expr | toCode t & mTaskType t
   (+.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, +, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
   (-.) infixl 6 :: (v t p) (v t q) -> v t Expr | type, -, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
   (*.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, *, zero, one t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q
@@ -214,9 +211,6 @@ instance long Eval Long
 
 // ----- tools ----- //
 
-derive gPrint Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
-derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
-
 instance == DigitalPin
 instance == AnalogPin
 instance == UserLED
diff --git a/mTask.icl b/mTask.icl
index b92b1fc..2bbcc30 100644
--- a/mTask.icl
+++ b/mTask.icl
@@ -123,9 +123,8 @@ instance == DigitalPin where (==) x y = x === y
 instance == AnalogPin   where (==) x y = x === y
 instance == UserLED where (==) x y = x === y
 
-derive gEq UserLED
-derive gPrint Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
-derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
+//derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
+//derive class iTask UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
 
 tab =: toString (repeatn tabSize ' ')
 tabSize :== 2
diff --git a/mTaskCode.icl b/mTaskCode.icl
index 7ac8aa6..cca5a67 100644
--- a/mTaskCode.icl
+++ b/mTaskCode.icl
@@ -2,8 +2,9 @@ implementation module mTaskCode
 
 import Generics.gdynamic
 import Generics.gCons
+import StdEnv
 
-import iTasks
+//import iTasks
 import GenEq, StdMisc, StdArray
 import mTask
 
diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl
index 999d734..d104b02 100644
--- a/mTaskInterpret.dcl
+++ b/mTaskInterpret.dcl
@@ -1,10 +1,14 @@
 definition module mTaskInterpret
 
+import mTask
+
 from Data.Functor.Identity import :: Identity
 from Control.Monad.State import :: State, :: StateT
 from Control.Monad.RWST import :: RWST, :: RWS
 from Data.Either import :: Either
-import mTask
+from iTasks._Framework.Generic.Defaults import generic gDefault
+from GenPrint import generic gPrint
+from Generics.gCons import class gCons, generic conses, generic consName, generic consIndex, generic consNum
 
 :: MTaskMSGRecv
 	= MTTaskAck Int
@@ -26,6 +30,8 @@ import mTask
 	| OnInterval Int
 	| OnInterrupt Int
 
+:: BCValue = E.e: BCValue e & mTaskType e
+
 instance toString MTaskInterval
 instance toString MTaskMSGRecv
 instance toString MTaskMSGSend
@@ -35,8 +41,8 @@ decode :: String -> MTaskMSGRecv
 :: BC
 	= BCNop
 	| BCLab Int
-//	| E.e: BCPush e & toByteCode e
-	| BCPush String
+	| BCPush BCValue
+//	| BCPush String
 	| BCPop
 	//SDS functions
 	| BCSdsStore Int
@@ -78,7 +84,20 @@ decode :: String -> MTaskMSGRecv
 	| BCDigitalWrite Pin
 	| BCTest AnalogPin
 
-derive class gCons BC
+derive gPrint BCValue
+derive consIndex BCValue
+derive consName BCValue
+derive conses BCValue
+derive consNum BCValue
+
+derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin
+derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode
+derive gEditor BCValue
+derive gText BCValue
+derive JSONEncode BCValue
+derive JSONDecode BCValue
+derive gDefault BCValue
+derive gEq BCValue
 
 :: ByteCode a p = BC (RWS () [BC] BCState ())
 
@@ -98,9 +117,9 @@ instance zero BCState
 
 class toByteCode a :: a -> String
 class fromByteCode a :: String -> a
-class mTaskType a | toByteCode, fromByteCode, TC a
+class mTaskType a | toByteCode, fromByteCode, iTask, TC a
 
-instance toByteCode Int, Bool, Char, Long, String, Button, UserLED
+instance toByteCode Int, Bool, Char, Long, String, Button, UserLED, BCValue
 instance fromByteCode Int, Bool, Char, Long, String, Button, UserLED
 instance toByteCode MTaskInterval
 instance fromByteCode MTaskInterval
diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl
index 71555a5..c6a3e53 100644
--- 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
diff --git a/mTaskSimulation.dcl b/mTaskSimulation.dcl
index ed86068..b3870cf 100644
--- a/mTaskSimulation.dcl
+++ b/mTaskSimulation.dcl
@@ -1,8 +1,12 @@
 definition module mTaskSimulation
 
-from iTasks.API.Core.Types import class iTask, :: Task, generic gEditor, generic gText, generic JSONEncode, generic JSONDecode, generic gDefault, :: Editor, :: TextFormat, :: JSONNode
 import mTask
 
+from Generics.gdynamic import :: Dyn, class dyn, generic toGenDynamic, generic fromGenDynamic
+from GenPrint import class PrintOutput, :: PrintState
+from Data.Maybe import :: Maybe
+from iTasks import class iTask, generic gEditor, generic gDefault, generic gText, generic JSONEncode, generic JSONDecode, :: Task, :: Editor, :: JSONNode, :: TextFormat
+
 :: Display a = Display a
 
 derive class iTask Display
@@ -81,8 +85,6 @@ instance writePinD AnalogPin
 
 // ----- Interactive Simulation ----- //
 
-derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
-
 simulate :: (Main (Eval a p)) -> Task ()
 toView :: State` -> StateInterface
 mergeView :: State` StateInterface -> State`
diff --git a/mTaskSimulation.icl b/mTaskSimulation.icl
index f4835be..801235e 100644
--- a/mTaskSimulation.icl
+++ b/mTaskSimulation.icl
@@ -155,7 +155,7 @@ instance writePinD AnalogPin where
 
 // ----- Interactive Simulation ----- //
 
-derive class iTask DigitalPin, AnalogPin, Dyn, StateInterface, DisplayVar, Pin
+derive class iTask StateInterface, DisplayVar
 
 simulate :: (Main (Eval a p)) -> Task ()
 simulate {main=(E f)} = setup zero where