From ff7049a99f7fdd701d49222019df65a9aee8f05a Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Mon, 6 Mar 2017 19:50:15 +0100 Subject: [PATCH] update --- Devices/mTaskDevice.icl | 5 ++- Generics/gCons.dcl | 5 +++ Generics/gCons.icl | 7 ++++ Shares/mTaskShare.dcl | 1 - Shares/mTaskShare.icl | 8 ++-- Tasks/mTaskTask.icl | 2 +- Utils/SDS.dcl | 2 +- Utils/SDS.icl | 4 +- mTask.dcl | 6 +-- mTask.icl | 7 ++-- mTaskInterpret.dcl | 37 ++++++++++--------- mTaskInterpret.icl | 81 ++++++++++++++++++++++++----------------- mTaskLCD.icl | 1 - mTaskMakeSymbols.icl | 5 +-- 14 files changed, 98 insertions(+), 73 deletions(-) diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 928432b..85ca1c3 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -93,13 +93,14 @@ sendToDevice wta mTask (device, timeout) = where sharename i = device.deviceChannels +++ "-" +++ toString i toSDSRecords st = [{MTaskShare | - initValue=toInt (sdsval!!0)*265 + toInt (sdsval!!1), withTask=wta, identifier=sdsi, //We skip the only/local shares realShare="mTaskSDS-" +++ toString sdsi} \\{sdsi,sdspub,sdsval}<-st.sdss | sdspub] - makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) + + makeShares :: ([MTaskShare] -> Task ()) + makeShares = undef //foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) addTask :: MTaskTask MTaskDevice -> MTaskDevice addTask task device = {device & deviceTasks=[task:device.deviceTasks]} diff --git a/Generics/gCons.dcl b/Generics/gCons.dcl index 02f182e..409a255 100644 --- a/Generics/gCons.dcl +++ b/Generics/gCons.dcl @@ -7,8 +7,13 @@ definition module Generics.gCons ARDSL project */ +from Data.Maybe import :: Maybe import StdGeneric +class gCons a | conses{|*|}, consName{|*|}, consIndex{|*|} a + +consByName :: String -> Maybe a | conses{|*|}, consName{|*|} a + generic consName a :: a -> String derive consName CONS of {gcd_name},UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),{},{!},[],[! ],[ !],[!!] diff --git a/Generics/gCons.icl b/Generics/gCons.icl index 8fbf479..62caa27 100644 --- a/Generics/gCons.icl +++ b/Generics/gCons.icl @@ -8,7 +8,14 @@ implementation module Generics.gCons */ import StdEnv, StdGeneric, GenBimap, _SystemStrictLists +import Data.Functor import Data.List +import Data.Maybe + +consByName :: String -> Maybe a | conses{|*|}, consName{|*|} a +consByName a = let cs = conses{|*|} + in ((!!) cs) <$> elemIndex a (map consName{|*|} cs) + generic consName a :: a -> String consName{|CONS of {gcd_name}|} f x = gcd_name diff --git a/Shares/mTaskShare.dcl b/Shares/mTaskShare.dcl index a9c6f39..bb6ec46 100644 --- a/Shares/mTaskShare.dcl +++ b/Shares/mTaskShare.dcl @@ -3,7 +3,6 @@ definition module Shares.mTaskShare import iTasks :: MTaskShare = { - initValue :: Int, withTask :: String, identifier :: Int, realShare :: String diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index 1e9294c..c0087d8 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -18,7 +18,7 @@ manageShares shares = forever (enterChoice "Choose share to update" [ChooseFromG ) @! () -updateShare :: MTaskShare a -> Task MTaskShare | toByteCode a +updateShare :: MTaskShare a -> Task MTaskShare | toByteCode, iTask a updateShare sh=:{withTask,identifier} a = getDeviceByName withTask >>= sendMessages [MTUpd identifier $ toString $ toByteCode a] >>| treturn sh @@ -28,9 +28,9 @@ viewShares :: [MTaskShare] -> Task () viewShares sh = anyTask (map viewShare sh) <<@ ArrangeHorizontal @! () viewShare :: MTaskShare -> Task () -viewShare m = viewSharedInformation "" [] (getSDSStore m) - <<@ Title ("SDS: " +++ toString m.identifier) @! () +viewShare m = treturn ()//viewSharedInformation "" [] (getSDSStore m) + //<<@ Title ("SDS: " +++ toString m.identifier) @! () instance zero MTaskShare where - zero = {initValue=0,withTask="",identifier=0,realShare=""} + zero = {withTask="",identifier=0,realShare=""} diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl index d15f8f3..18ad5b1 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 +derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, UserLED makeTask :: String Int -> Task MTaskTask makeTask name ident = get currentDateTime diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl index b33045a..6836af1 100644 --- a/Utils/SDS.dcl +++ b/Utils/SDS.dcl @@ -13,5 +13,5 @@ sdsStore :: Shared [MTaskShare] bcStateStore :: Shared BCState mTaskTaskStore :: Shared [String] -getSDSStore :: MTaskShare -> Shared Int +getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a getSDSRecord :: Int -> Task MTaskShare diff --git a/Utils/SDS.icl b/Utils/SDS.icl index 8e78cf0..d67ba6e 100644 --- a/Utils/SDS.icl +++ b/Utils/SDS.icl @@ -25,8 +25,8 @@ bcStateStore = memoryShare "mTaskBCState" zero mTaskTaskStore :: Shared [String] mTaskTaskStore = memoryShare "mTaskTasks" $ 'DM'.keys allmTasks -getSDSStore :: MTaskShare -> Shared Int -getSDSStore sh = memoryShare sh.realShare 0 +getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a +getSDSStore sh = memoryShare sh.realShare zero getSDSRecord :: Int -> Task MTaskShare getSDSRecord i = get sdsStore @ \l->hd [s\\s<-l | s.identifier == i] diff --git a/mTask.dcl b/mTask.dcl index ac9405c..e8f62f2 100644 --- a/mTask.dcl +++ b/mTask.dcl @@ -14,6 +14,7 @@ todo: imporove setp: >>*. */ +import GenPrint import Generics.gCons import Generics.gdynamic @@ -212,13 +213,12 @@ instance long Eval Long // ----- tools ----- // -derive consName DigitalPin, AnalogPin, PinMode +derive gPrint Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode +derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode instance == DigitalPin instance == AnalogPin -derive consIndex DigitalPin, AnalogPin - tab =: toString (repeatn tabSize ' ') tabSize :== 2 diff --git a/mTask.icl b/mTask.icl index 66649d7..9d42d2f 100644 --- a/mTask.icl +++ b/mTask.icl @@ -18,7 +18,7 @@ import Generics.gCons import Generics.gdynamic import iTasks -import GenEq, StdMisc, StdArray +import GenEq, StdMisc, StdArray, GenBimap import mTaskCode import mTaskSerial, mTaskLCD @@ -121,8 +121,9 @@ instance long Eval Long where instance == DigitalPin where (==) x y = x === y instance == AnalogPin where (==) x y = x === y -derive consName DigitalPin, AnalogPin, PinMode -derive consIndex DigitalPin, AnalogPin +derive gPrint Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode +derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode + tab =: toString (repeatn tabSize ' ') tabSize :== 2 diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl index 17034be..f853c65 100644 --- a/mTaskInterpret.dcl +++ b/mTaskInterpret.dcl @@ -34,7 +34,8 @@ decode :: String -> MTaskMSGRecv :: BC = BCNop | BCLab Int - | BCPush [Char] +// | E.e: BCPush e & toByteCode e + | BCPush String | BCPop //SDS functions | BCSdsStore Int @@ -61,8 +62,8 @@ decode :: String -> MTaskMSGRecv | BCJmpT Int | BCJmpF Int //UserLED - | BCLedOn [Char] - | BCLedOff [Char] + | BCLedOn UserLED + | BCLedOff UserLED //Serial | BCSerialAvail | BCSerialPrint @@ -76,6 +77,9 @@ decode :: String -> MTaskMSGRecv | BCDigitalWrite Pin | BCTest AnalogPin +derive gPrint BC +derive class gCons BC + :: ByteCode a p = BC (BCState -> ([BC], BCState)) instance Semigroup (ByteCode a p) instance Monoid (ByteCode a p) @@ -83,7 +87,7 @@ instance Monoid (ByteCode a p) :: BCShare = { sdsi :: Int, sdspub :: Bool, - sdsval :: [Char] + sdsval :: String } :: BCState = { @@ -93,15 +97,14 @@ instance Monoid (ByteCode a p) } instance zero BCState -class toByteCode a :: a -> [Char] -instance toByteCode Int -instance toByteCode Bool -instance toByteCode Char -instance toByteCode String -instance toByteCode Long -instance toByteCode Button -instance toByteCode UserLED -//instance toByteCode MTaskInterval +class toByteCode a :: a -> String +class fromByteCode a :: String -> a +class mTaskType a | toByteCode, fromByteCode, zero a + +instance toByteCode Int, Bool, Char, Long, String, Button, UserLED +instance fromByteCode Int, Bool, Char, Long, String, Button, UserLED +instance toByteCode MTaskInterval +instance fromByteCode MTaskInterval instance toChar Pin instance arith ByteCode @@ -109,9 +112,9 @@ instance boolExpr ByteCode instance analogIO ByteCode instance digitalIO ByteCode instance userLed ByteCode -//instance If ByteCode Stmt Stmt Stmt -//instance If ByteCode e Stmt Stmt -//instance If ByteCode Stmt e Stmt +instance If ByteCode Stmt Stmt Stmt +instance If ByteCode e Stmt Stmt +instance If ByteCode Stmt e Stmt instance If ByteCode x y Stmt instance IF ByteCode instance noOp ByteCode @@ -124,6 +127,6 @@ instance serial ByteCode toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState) toSDSUpdate :: Int Int -> [MTaskMSGSend] -toByteVal :: BC -> [Char] +toByteVal :: BC -> String toReadableByteCode :: (ByteCode a b) -> (String, BCState) toRealByteCode :: (ByteCode a b) BCState -> (String, BCState) diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index acbff39..615aa10 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -22,6 +22,7 @@ import StdList from Data.Func import $ from Text import class Text(concat,join,toUpperCase), instance Text String +import Data.Array import qualified Data.Map as DM import Text.Encodings.Base64 @@ -93,25 +94,24 @@ bclength (BCJmpT i) = 2 bclength (BCJmpF i) = 2 bclength _ = 1 -toByteVal :: BC -> [Char] -toByteVal b -# bt = toChar $ consIndex{|*|} b -= [bt:case b of +toByteVal :: BC -> String +toByteVal b = {toChar $ consIndex{|*|} b} +++ + case b of (BCPush i) = i - (BCLab i) = [toChar i] - (BCSdsStore i) = [c\\c<-:to16bit i] - (BCSdsFetch i) = [c\\c<-:to16bit i] - (BCSdsPublish i) = [c\\c<-:to16bit i] - (BCAnalogRead i) = [toChar i] - (BCAnalogWrite i) = [toChar i] - (BCDigitalRead i) = [toChar i] - (BCDigitalWrite i) = [toChar i] - (BCLedOn i) = i - (BCLedOff i) = i - (BCJmp i) = [toChar i] - (BCJmpT i) = [toChar i] - (BCJmpF i) = [toChar i] - _ = []] + (BCLab i) = {toChar i} + (BCSdsStore i) = to16bit i + (BCSdsFetch i) = to16bit i + (BCSdsPublish i) = to16bit i + (BCAnalogRead i) = {toChar i} + (BCAnalogWrite i) = {toChar i} + (BCDigitalRead i) = {toChar i} + (BCDigitalWrite i) = {toChar i} + (BCLedOn i) = toByteCode i + (BCLedOff i) = toByteCode i + (BCJmp i) = {toChar i} + (BCJmpT i) = {toChar i} + (BCJmpF i) = {toChar i} + _ = "" instance Semigroup (ByteCode a p) where mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t) @@ -132,27 +132,42 @@ retrn = BC o tuple fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a q fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`) -instance toByteCode Bool where toByteCode b = toByteCode $ if b 1 0 -instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256] +instance toByteCode Bool where toByteCode b = if b "\x01" "\x00" +instance toByteCode Int where toByteCode n = {toChar $ n/256,toChar $ n rem 256} instance toByteCode Long where toByteCode (L n) = toByteCode n -instance toByteCode Char where toByteCode c = [c] +instance toByteCode Char where toByteCode s = toString s instance toByteCode String where toByteCode s = undef -instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s] -instance toByteCode UserLED where toByteCode s = [toChar $ consIndex{|*|} s] +instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s} +instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s} instance toByteCode MTaskInterval where toByteCode OneShot = toByteCode 0 //Intervals have the first bit 0 and the rest is a 15 bit unsigned int - toByteCode (OnInterval i) = map toChar [i/256 bitand 127, i rem 256] + toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256} //Intervals have the first bit 1 and the rest is a 15 bit unsigned int - toByteCode (OnInterrupt i) = map toChar [i/256 bitor 128, i rem 256] + toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256} + +instance fromByteCode Bool where fromByteCode s = s == "\x01" +instance fromByteCode Int where fromByteCode s = (toInt s.[0])*256 + toInt s.[1] +instance fromByteCode Long where fromByteCode s = L $ fromByteCode s +instance fromByteCode Char where fromByteCode s = toChar s.[0] +instance fromByteCode String where fromByteCode s = undef +instance fromByteCode Button where fromByteCode s = fromJust $ consByName s +instance fromByteCode UserLED where fromByteCode s = fromJust $ consByName s +instance fromByteCode MTaskInterval + where + fromByteCode s + //Interval + | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of + 0 = OneShot + i = OnInterval i + = OnInterrupt $ fromByteCode s bitand 127 instance toChar Pin where toChar (Digital p) = toChar $ consIndex{|*|} p toChar (Analog p) = toChar $ consIndex{|*|} p -derive gPrint BC, AnalogPin, Pin, DigitalPin -derive consIndex BC, Pin, Button, UserLED -derive consName BC, Pin, Button +derive gPrint BC +derive class gCons BC instance arith ByteCode where lit x = retrn [BCPush $ toByteCode x] @@ -234,8 +249,8 @@ instance serial ByteCode where serialParseInt = retrn [BCSerialParseInt] instance userLed ByteCode where - ledOn l = retrn [BCLedOn $ toByteCode l] - ledOff l = retrn [BCLedOff $ toByteCode l] + ledOn l = retrn [BCLedOn l] + ledOff l = retrn [BCLedOff l] instance zero BCState where zero = {freshl=[1..], freshs=[1..], sdss=[]} @@ -257,11 +272,9 @@ 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 (map safe d) +readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d] where - safe c - | isControl c = "\\d" +++ toString (toInt c) - = toString c + safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c) readable b = printToString b toReadableByteCode :: (ByteCode a b) -> (String, BCState) diff --git a/mTaskLCD.icl b/mTaskLCD.icl index 6c9d16b..1cc2dfa 100644 --- a/mTaskLCD.icl +++ b/mTaskLCD.icl @@ -4,7 +4,6 @@ import iTasks import GenEq, StdMisc, StdArray import mTask -derive consIndex Button derive toGenDynamic LCD derive fromGenDynamic LCD diff --git a/mTaskMakeSymbols.icl b/mTaskMakeSymbols.icl index 356493f..6781ce8 100644 --- a/mTaskMakeSymbols.icl +++ b/mTaskMakeSymbols.icl @@ -5,6 +5,7 @@ import Generics.gCons import GenEq, StdMisc, StdArray, GenBimap import GenPrint import mTask +import mTaskInterpret import StdEnum import StdFile @@ -19,10 +20,6 @@ from Data.Func import $ import Data.List from Text import class Text(join,toUpperCase), instance Text String -derive consIndex BC, Pin -derive consName BC, Pin -derive conses BC, AnalogPin, DigitalPin, Pin - (<+) infixr 5 :: a b -> String | toString a & toString b (<+) a b = toString a +++ toString b -- 2.20.1