From: Mart Lubbers 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