<<@ 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 $
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]}
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
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,(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),{},{!},[],[! ],[ !],[!!]
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 [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
-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
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
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
countAndLed :: Main (ByteCode () Stmt)
blink :: UserLED -> Main (ByteCode () Stmt)
+blinkShare :: Main (ByteCode () Stmt)
ledtOn :: UserLED -> Main (ByteCode () Stmt)
ledtOff :: UserLED -> Main (ByteCode () Stmt)
bcStateStore :: Shared BCState
mTaskTaskStore :: Shared [String]
-getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a
getSDSRecord :: Int -> Task MTaskShare
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]
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");
| BCJmpT Int
| BCJmpF Int
//UserLED
- | BCLedOn UserLED
- | BCLedOff UserLED
+ | BCLedOn
+ | BCLedOff
//Serial
| BCSerialAvail
| BCSerialPrint
| BCDigitalWrite Pin
| BCTest AnalogPin
-derive gPrint BC
derive class gCons BC
:: ByteCode a p = BC (RWS () [BC] BCState ())
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
(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 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
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
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=[]}
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]
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
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 ()