From: Mart Lubbers Date: Sun, 12 Mar 2017 14:11:47 +0000 (+0100) Subject: update a lot, try to type shares X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=5f4c4b61ea1e4062e90715af9e1027da6d1c7a66;p=mTask.git update a lot, try to type shares --- diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 71c6ee2..0304e7e 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -74,7 +74,7 @@ manageDevices processFun ds = anyTask [ <<@ ArrangeWithTabs @! () viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () -viewDevice pf d = forever $ anyTask +viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask [viewInformation "Device settings" [] d @! () ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! () ,forever $ @@ -96,26 +96,25 @@ deleteDevice d = upd (\(r,s,ss)->(r,s,True)) (channels d) sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () sendToDevice wta mTask (device, timeout) = - get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask) - >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords - >>= \sdss->set sdss sdsStore//MTaskShareaddToSDSShare - >>| makeShares sdss + traceValue "starting to send" + >>| get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask) + >>= \(msgs, st1)->traceValue "messages generated" + >>| set st1 bcStateStore + >>| traceValue "bcstate store updated" + >>| toSDSRecords st1 + >>= \sdss->traceValue "Shares created" + >>| set sdss sdsStore//MTaskShareaddToSDSShare + >>| traceValue "Shares store updated" >>| sendMessages msgs device + >>| traceValue "Messages sent" >>| makeTask wta -1 - >>= withDevices device o addTask + >>= \t->traceValue "Task made" + >>| withDevices device (addTask t) + >>| traceValue "Tasks share updated" @! () where sharename i = device.deviceChannels +++ "-" +++ toString i - toSDSRecords st = [{MTaskShare | - withTask=wta, - identifier=sdsi, - initVal=sdsval, - //We skip the only/local shares - realShare="mTaskSDS-" +++ toString sdsi} - \\{sdsi,sdspub,sdsval}<-st.sdss | sdspub] - - makeShares :: [MTaskShare] -> Task () - makeShares shs = treturn () //foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) + toSDSRecords st = sequence "" [makeShare wta sdsi sdsval\\{sdsi,sdspub,sdsval}<-st.sdss]// | sdspub] addTask :: MTaskTask MTaskDevice -> MTaskDevice addTask task device = {device & deviceTasks=[task:device.deviceTasks]} diff --git a/Generics/gCons.dcl b/Generics/gCons.dcl index 409a255..71183db 100644 --- a/Generics/gCons.dcl +++ b/Generics/gCons.dcl @@ -10,7 +10,7 @@ definition module Generics.gCons from Data.Maybe import :: Maybe import StdGeneric -class gCons a | conses{|*|}, consName{|*|}, consIndex{|*|} a +class gCons a | conses{|*|}, consName{|*|}, consIndex{|*|}, consNum{|*|} a consByName :: String -> Maybe a | conses{|*|}, consName{|*|} a @@ -22,3 +22,6 @@ derive consIndex CONS of {gcd_index},UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bo generic conses a :: [a] derive conses CONS,UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),{},{!},[],[! ],[ !],[!!],(->) + +generic consNum a :: a -> Int +derive consNum CONS of {gcd_arity},UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),{},{!},[],[! ],[ !],[!!] diff --git a/Generics/gCons.icl b/Generics/gCons.icl index 62caa27..07365e2 100644 --- a/Generics/gCons.icl +++ b/Generics/gCons.icl @@ -106,3 +106,22 @@ conses{|{}|} _ = [{}] conses{|{!}|} _ = [{!}] conses{|(->)|} _ _ = [const undef] derive conses [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) + +generic consNum a :: a -> Int +consNum{|CONS of {gcd_arity}|} f x = gcd_arity +consNum{|UNIT|} _ = 0 +consNum{|PAIR|} f _ (PAIR x y) = f x +consNum{|EITHER|} f _ (LEFT x) = f x +consNum{|EITHER|} _ g (RIGHT y) = g y +consNum{|OBJECT|} f (OBJECT x) = f x +consNum{|RECORD|} f (RECORD x) = f x +consNum{|FIELD|} f (FIELD x) = f x +consNum{|Int|} _ = 0 +consNum{|Bool|} _ = 0 +consNum{|Char|} _ = 0 +consNum{|Real|} _ = 0 +consNum{|String|} _ = 0 +consNum{|{}|} _ _ = 0 +consNum{|{!}|} _ _ = 0 +consNum{|(->)|} _ _ _ = 0 +derive consNum [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) diff --git a/Makefile b/Makefile index cbc1ea9..cbca7ae 100644 --- a/Makefile +++ b/Makefile @@ -19,7 +19,7 @@ CLMLIBS:=\ -I $(CLEAN_HOME)/lib/TCPIP\ -I ./CleanSerial -BINARIES:= mTaskInterpret miTask mTaskExamples +BINARIES:= testi mTaskInterpret miTask # mTaskExamples all: CleanSerial/Clean\ System\ Files/TTY.o $(BINARIES) #client/mTaskSymbols.h mkdir -p miTask-www diff --git a/Shares/mTaskShare.dcl b/Shares/mTaskShare.dcl index 6b39448..3af2eac 100644 --- a/Shares/mTaskShare.dcl +++ b/Shares/mTaskShare.dcl @@ -1,14 +1,17 @@ definition module Shares.mTaskShare import iTasks +import iTasks._Framework.Serialization -:: MTaskShare = { - withTask :: String, - identifier :: Int, - initVal :: String, - realShare :: String - } - -instance zero MTaskShare +derive class iTask MTaskShareType +:: MTaskShareType = MTaskWithShare String | MTaskLens String +:: MTaskShare = + {withTask :: String + ,identifier :: Int + ,realShare :: MTaskShareType + ,value :: String + } manageShares :: [MTaskShare] -> Task () + +makeShare :: String Int String -> Task MTaskShare diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index eb799df..8eb7dc0 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -1,42 +1,49 @@ implementation module Shares.mTaskShare +import dynamic_string import Utils.SDS import Utils.Devices import iTasks import mTask from Data.Func import $ +derive class iTask MTaskShareType manageShares :: [MTaskShare] -> Task () -manageShares shares = forever (enterChoice "Choose share to update" [ChooseFromGrid id] shares) - @! () - - - -/* +manageShares shares = forever (enterChoice "Choose share to update" [ChooseFromGrid id] shares >&^ \st->whileUnchanged st $ \msh->case msh of - Nothing = viewShares shares @! zero + Nothing = viewShares shares Just sh = forever ( - viewSharedInformation "View value" [] (getSDSStore sh) - >>* [OnAction (Action "Update") (withValue (Just o updateInformation "New value" []))] - >>= updateShare sh + viewSharedInformation "View value" [] (getSDSShare sh) >>| treturn sh +// >>* [OnAction (Action "Update") (withValue (Just o updateInformation "New value" []))] +// >>= updateShare sh ) - ) @! ()*/ - -updateShare :: MTaskShare a -> Task MTaskShare | toByteCode, iTask a -updateShare sh=:{withTask,identifier} a = getDeviceByName withTask - >>= sendMessages [MTUpd identifier $ toString $ toByteCode a] - >>| treturn sh - - -viewShares :: [MTaskShare] -> Task () -viewShares sh = anyTask (map viewShare sh) <<@ ArrangeHorizontal @! () - -viewShare :: MTaskShare -> Task () -viewShare m = treturn ()//viewSharedInformation "" [] (getSDSStore m) - //<<@ Title ("SDS: " +++ toString m.identifier) @! () - -instance zero MTaskShare where - zero = {withTask="",identifier=0,realShare="",initVal=""} - + ) @! () + +//updateShare :: MTaskShare a -> Task MTaskShare | toByteCode, iTask a +//updateShare sh=:{withTask,identifier} a = getDeviceByName withTask +// >>= sendMessages [MTUpd identifier $ toString $ toByteCode a] +// >>| treturn sh + + +viewShares :: [MTaskShare] -> Task MTaskShare +viewShares sh = anyTask (map viewShare sh) <<@ ArrangeHorizontal + >>| return (hd sh) + +viewShare :: MTaskShare -> Task String +viewShare m = viewSharedInformation "" [] (getSDSShare m) + <<@ Title ("SDS: " +++ toString m.identifier) + +getSDSShare :: MTaskShare -> Shared String +getSDSShare s=:{realShare=(MTaskWithShare id)} + = memoryShare id s.MTaskShare.value + +makeShare :: String Int String -> Task MTaskShare +makeShare withTask identifier value = treturn + {MTaskShare + |withTask=withTask + ,identifier=identifier + ,value=value + ,realShare=MTaskWithShare $ "mTaskSDS-" +++ toString identifier + } >>= \sh->set value (getSDSShare sh) >>| treturn sh diff --git a/Tasks/Examples.dcl b/Tasks/Examples.dcl index 6c099dd..f3a8a3a 100644 --- a/Tasks/Examples.dcl +++ b/Tasks/Examples.dcl @@ -5,6 +5,7 @@ import mTask countAndLed :: Main (ByteCode () Stmt) blink :: UserLED -> Main (ByteCode () Stmt) +blinkShare :: Main (ByteCode () Stmt) ledtOn :: UserLED -> Main (ByteCode () Stmt) ledtOff :: UserLED -> Main (ByteCode () Stmt) diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl index 6836af1..47e6647 100644 --- a/Utils/SDS.dcl +++ b/Utils/SDS.dcl @@ -13,5 +13,4 @@ sdsStore :: Shared [MTaskShare] bcStateStore :: Shared BCState mTaskTaskStore :: Shared [String] -getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a getSDSRecord :: Int -> Task MTaskShare diff --git a/Utils/SDS.icl b/Utils/SDS.icl index 3d8e3a0..9c6b46a 100644 --- a/Utils/SDS.icl +++ b/Utils/SDS.icl @@ -25,8 +25,5 @@ bcStateStore = memoryShare "mTaskBCState" zero mTaskTaskStore :: Shared [String] mTaskTaskStore = memoryShare "mTaskTasks" $ 'DM'.keys allmTasks -getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a -getSDSStore sh = memoryShare sh.realShare $ fromByteCode sh.initVal - getSDSRecord :: Int -> Task MTaskShare getSDSRecord i = get sdsStore @ \l->hd [s\\s<-l | s.identifier == i] diff --git a/client/interpret.c b/client/interpret.c index 39c24b0..0335f1d 100644 --- a/client/interpret.c +++ b/client/interpret.c @@ -140,10 +140,12 @@ void run_task(struct task *t) sp--; break; case BCLEDON: trace("LedOn(%d)", program[pc]); - led_on(program[pc++]); + led_on(stack[sp-1]); + sp--; break; case BCLEDOFF: trace("LedOn(%d)", program[pc]); - led_off(program[pc++]); + led_off(stack[sp-1]); + sp--; break; default: trace("unrecognized"); diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl index 24dc6a6..f476232 100644 --- a/mTaskInterpret.dcl +++ b/mTaskInterpret.dcl @@ -63,8 +63,8 @@ decode :: String -> MTaskMSGRecv | BCJmpT Int | BCJmpF Int //UserLED - | BCLedOn UserLED - | BCLedOff UserLED + | BCLedOn + | BCLedOff //Serial | BCSerialAvail | BCSerialPrint @@ -78,7 +78,6 @@ decode :: String -> MTaskMSGRecv | BCDigitalWrite Pin | BCTest AnalogPin -derive gPrint BC derive class gCons BC :: ByteCode a p = BC (RWS () [BC] BCState ()) diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index 1caa4ba..5acd1da 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -86,23 +86,6 @@ instance toString MTaskMSGRecv where toString (MTMessage m) = m toString MTEmpty = "Empty message" -bclength :: BC -> Int -bclength (BCPush _) = 3 -bclength (BCLab _) = 2 -bclength (BCSdsStore _) = 3 -bclength (BCSdsFetch _) = 3 -bclength (BCSdsPublish _) = 3 -bclength (BCAnalogRead _) = 2 -bclength (BCAnalogWrite _) = 2 -bclength (BCDigitalRead _) = 2 -bclength (BCDigitalWrite _) = 2 -bclength (BCLedOn _) = 2 -bclength (BCLedOff _) = 2 -bclength (BCJmp i) = 2 -bclength (BCJmpT i) = 2 -bclength (BCJmpF i) = 2 -bclength _ = 1 - toByteVal :: BC -> String toByteVal b = {toChar $ consIndex{|*|} b} +++ case b of @@ -115,8 +98,6 @@ toByteVal b = {toChar $ consIndex{|*|} b} +++ (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} @@ -234,10 +215,10 @@ unBC (BC x) = x instance sds ByteCode where sds f = {main = BC $ freshs >>= \sds->pure (f (tell` [BCSdsFetch sds])) - >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)} + >>= \(v In bdy)->modify (addSDS sds (toByteCode v)) >>| unBC (unMain bdy)} where - addSDS i v s = {s & sdss=[ - {sdsi=i,sdspub=False,sdsval=toByteCode v}:s.sdss]} + addSDS i v s = {s & sdss=[{sdsi=i,sdspub=False,sdsval=v}:s.sdss]} + con f = undef pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty @@ -247,6 +228,7 @@ instance sds ByteCode where instance assign ByteCode where (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v where + //This is going to include pins as well, as variables makeStore [BCSdsFetch i] = [BCSdsStore i] instance seq ByteCode where @@ -261,8 +243,11 @@ instance serial ByteCode where serialParseInt = tell` [BCSerialParseInt] instance userLed ByteCode where - ledOn (BC l) = BC $ censor (\[BCPush d]->[BCLedOn $ fromByteCode d]) l - ledOff (BC l) = BC $ censor (\[BCPush d]->[BCLedOff $ fromByteCode d]) l + ledOn (BC l) = BC $ l >>| tell [BCLedOn] + ledOff (BC l) = BC $ l >>| tell [BCLedOff] + +func :: (a -> BC) [BC] -> [BC] | mTaskType a +func f b = abort ('Text'.join "\n" (map printToString b)) instance zero BCState where zero = {freshl=[1..], freshs=[1..], sdss=[]} @@ -281,7 +266,8 @@ implGotos _ i = i computeGotos :: [BC] Int -> ([BC], 'DM'.Map Int Int) computeGotos [] _ = ([], 'DM'.newMap) 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))) +computeGotos [x:xs] i = appFst (\bc->[x:bc]) + (computeGotos xs $ i + 1 + consNum{|*|} x) readable :: BC -> String readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d] @@ -300,14 +286,15 @@ toReadableByteCode x s toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState) toMessages interval (bytes, st=:{sdss}) = ( - [MTSds s.sdsi (toString s.sdsval)\\s<-sdss] ++ + [MTSds s.sdsi (toByteCode s.sdsval)\\s<-sdss] ++ [MTTask interval bytes], st) toSDSUpdate :: Int Int -> [MTaskMSGSend] toSDSUpdate i v = [MTUpd i (to16bit v)] //Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero -Start = fst $ toReadableByteCode (unMain bc) zero +Start = let (bcs, st) = toReadableByteCode (unMain bc) zero + in (bcs, st.sdss) where // bc = {main = ledOn (lit LED1)} bc = sds \x=5 In diff --git a/miTask.icl b/miTask.icl index 47d3c8c..5a65116 100644 --- a/miTask.icl +++ b/miTask.icl @@ -62,7 +62,7 @@ mTaskManager = startupDevices >>| anyTask proc [m:ms] = (case m of // MTSDSAck i = traceValue (toString m) @! () // MTSDSDelAck i = traceValue (toString m) @! () - MTPub i val = getSDSRecord i >>= set (toInt val.[0]*256 + toInt val.[1]) o getSDSStore @! () +// MTPub i val = getSDSRecord i >>= set (toInt val.[0]*256 + toInt val.[1]) o getSDSStore @! () MTTaskAck i = deviceTaskAcked device i MTTaskDelAck i = deviceTaskDeleteAcked device i @! () MTEmpty = treturn ()