From: Mart Lubbers Date: Tue, 7 Mar 2017 13:30:15 +0000 (+0100) Subject: rewrite generation to rws X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=28f4e19f893889e6d19d8c0653a643ae1580fd6d;p=mTask.git rewrite generation to rws --- diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 661c701..71c6ee2 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -109,12 +109,13 @@ sendToDevice wta mTask (device, timeout) = 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 = undef //foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) + makeShares :: [MTaskShare] -> Task () + makeShares shs = treturn () //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/Makefile b/Makefile index ab55386..cbc1ea9 100644 --- a/Makefile +++ b/Makefile @@ -19,9 +19,9 @@ CLMLIBS:=\ -I $(CLEAN_HOME)/lib/TCPIP\ -I ./CleanSerial -BINARIES:= miTask mTaskExamples mTaskInterpret +BINARIES:= mTaskInterpret miTask mTaskExamples -all: CleanSerial/Clean\ System\ Files/TTY.o $(BINARIES) client/mTaskSymbols.h +all: CleanSerial/Clean\ System\ Files/TTY.o $(BINARIES) #client/mTaskSymbols.h mkdir -p miTask-www find $(CLEAN_HOME)/lib -path '*/WebPublic/*' -not -path '*/CodeMirror/*' -execdir cp -nR {} "$$PWD"/miTask-www/ \; diff --git a/Shares/mTaskShare.dcl b/Shares/mTaskShare.dcl index bb6ec46..6b39448 100644 --- a/Shares/mTaskShare.dcl +++ b/Shares/mTaskShare.dcl @@ -5,6 +5,7 @@ import iTasks :: MTaskShare = { withTask :: String, identifier :: Int, + initVal :: String, realShare :: String } diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index 70d1014..eb799df 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -38,5 +38,5 @@ viewShare m = treturn ()//viewSharedInformation "" [] (getSDSStore m) //<<@ Title ("SDS: " +++ toString m.identifier) @! () instance zero MTaskShare where - zero = {withTask="",identifier=0,realShare=""} + zero = {withTask="",identifier=0,realShare="",initVal=""} diff --git a/Tasks/Examples.icl b/Tasks/Examples.icl index b2a79de..d82a767 100644 --- a/Tasks/Examples.icl +++ b/Tasks/Examples.icl @@ -6,8 +6,6 @@ import mTask import Devices.mTaskDevice import iTasks._Framework.Serialization -derive class iTask UserLED - countAndLed :: Main (ByteCode () Stmt) countAndLed = sds \x=1 In sds \pinnetje=1 In {main = IF (digitalRead D3) ( @@ -17,35 +15,45 @@ countAndLed = sds \x=1 In sds \pinnetje=1 In {main = noOp ) :. IF (pinnetje ==. lit 1) ( - ledOn LED1 + ledOn (lit LED1) ) ( IF (pinnetje ==. lit 2) ( - ledOn LED2 + ledOn (lit LED2) ) ( - ledOn LED3 + ledOn (lit LED3) ) )} -blink :: UserLED -> Main (ByteCode () Stmt) -blink led = sds \x=1 In {main = +blinkShare :: Main (ByteCode () Stmt) +blinkShare = sds \x=1 In sds \led=LED1 In {main = IF (x ==. lit 1) ( ledOn led ) ( ledOff led ) :. x =. lit 1 -. x :. noOp } +blink :: UserLED -> Main (ByteCode () Stmt) +blink l = sds \x=1 In {main = + IF (x ==. lit 1) ( + ledOn (lit l) ) ( + ledOff (lit l) ) :. + x =. lit 1 -. x :. noOp + } + ledtOn :: UserLED -> Main (ByteCode () Stmt) -ledtOn d = {main = ledOn d} +ledtOn d = {main = ledOn (lit d) :. noOp} ledtOff :: UserLED -> Main (ByteCode () Stmt) -ledtOff d = {main = ledOff d} +ledtOff d = {main = ledOff (lit d) :. noOp} ledSelection :: Task UserLED ledSelection = enterInformation "Select LED" [] allmTasks :: Map String (Task (Main (ByteCode () Stmt))) -allmTasks = 'DM'.fromList [ - ("countAndLed", treturn countAndLed), - ("ledOn", ledSelection @ ledtOn), - ("ledOff", ledSelection @ ledtOff), - ("blink", ledSelection @ blink)] +allmTasks = 'DM'.fromList + [("countAndLed", treturn countAndLed) + ,("ledOn", ledSelection @ ledtOn) + ,("ledOff", ledSelection @ ledtOff) + ,("blink", ledSelection @ blink) + ,("blinkShare", treturn blinkShare) + ] diff --git a/Tasks/mTaskTask.dcl b/Tasks/mTaskTask.dcl index 94bcc8a..b27bb73 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 +derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, UserLED, RWST :: MTaskTask = { name :: String, diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl index 18ad5b1..9cc5a98 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 +derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCState, UserLED, RWST, Identity makeTask :: String Int -> Task MTaskTask makeTask name ident = get currentDateTime diff --git a/Utils/SDS.icl b/Utils/SDS.icl index d67ba6e..3d8e3a0 100644 --- a/Utils/SDS.icl +++ b/Utils/SDS.icl @@ -26,7 +26,7 @@ mTaskTaskStore :: Shared [String] mTaskTaskStore = memoryShare "mTaskTasks" $ 'DM'.keys allmTasks getSDSStore :: MTaskShare -> Shared a | iTask, mTaskType a -getSDSStore sh = memoryShare sh.realShare zero +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/mTask.dcl b/mTask.dcl index e8f62f2..9b82478 100644 --- a/mTask.dcl +++ b/mTask.dcl @@ -18,10 +18,10 @@ import GenPrint import Generics.gCons import Generics.gdynamic -import iTasks - -import iTasks._Framework.Generic -from iTasks._Framework.Task import :: Task +//import iTasks +// +//import iTasks._Framework.Generic +//from iTasks._Framework.Task import :: Task import StdClass import GenEq, StdMisc, StdArray @@ -70,7 +70,7 @@ class arith v where (+.) 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 - (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, / t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q + (/.) infixl 7 :: (v t p) (v t q) -> v t Expr | type, /, zero t & isExpr p & isExpr q //& toExpr2 p & toExpr2 q class boolExpr v where (&.) infixr 3 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q (|.) infixr 2 :: (v Bool p) (v Bool q) -> v Bool Expr | isExpr p & isExpr q //& toExpr2 p & toExpr2 q @@ -91,7 +91,7 @@ class var2 v where var2 :: t ((v t Upd)->(Main (v c s))) -> (Main (v c s)) | type, toCode t con2 :: t ((v t Expr) ->(Main (v c s))) -> (Main (v c s)) | type t class sds v where - sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, toByteCode, toCode t + sds :: ((v t Upd)->In t (Main (v c s))) -> (Main (v c s)) | type, mTaskType, toCode t con :: ((v t Expr) ->In t (Main (v c s))) -> (Main (v c s)) | type t pub :: (v t Upd) -> v t Expr | type t class seq v where @@ -133,8 +133,8 @@ class time v where millis :: (v Long Expr) class userLed v where - ledOn :: UserLED -> (v () Stmt) - ledOff :: UserLED -> (v () Stmt) + ledOn :: (v UserLED q) -> (v () Stmt) + ledOff :: (v UserLED q) -> (v () Stmt) class pio p t where pio :: p -> v t Upd | aIO v & dIO v instance pio AnalogPin Int @@ -155,6 +155,7 @@ instance type2string Char instance type2string MTask instance type2string DigitalPin instance type2string AnalogPin +instance type2string UserLED instance type2string String instance type2string () class varName a :: a -> String @@ -218,6 +219,7 @@ derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode instance == DigitalPin instance == AnalogPin +instance == UserLED tab =: toString (repeatn tabSize ' ') tabSize :== 2 diff --git a/mTask.icl b/mTask.icl index 9d42d2f..b92b1fc 100644 --- a/mTask.icl +++ b/mTask.icl @@ -59,6 +59,7 @@ instance type2string Char where type2string _ = "char" instance type2string MTask where type2string _ = "task" instance type2string DigitalPin where type2string _ = "int" instance type2string AnalogPin where type2string _ = "int" +instance type2string UserLED where type2string _ = "int" instance type2string String where type2string _ = "Char []" instance type2string () where type2string _ = "" @@ -120,11 +121,12 @@ instance long Eval Long where 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 - tab =: toString (repeatn tabSize ' ') tabSize :== 2 diff --git a/mTaskCode.dcl b/mTaskCode.dcl index 47aff54..91c7038 100644 --- a/mTaskCode.dcl +++ b/mTaskCode.dcl @@ -14,6 +14,7 @@ instance toCode Char instance toCode String instance toCode DigitalPin instance toCode AnalogPin +instance toCode UserLED argType :: (((Code a p)->Code b q)->In ((Code a p)->Code b q) (Code c s)) -> a | type a diff --git a/mTaskCode.icl b/mTaskCode.icl index f1da0d8..7ac8aa6 100644 --- a/mTaskCode.icl +++ b/mTaskCode.icl @@ -622,4 +622,8 @@ instance toCode AnalogPin where toCode x = consName{|*|} x instance toCode Pin where toCode (Digital p) = toCode p toCode (Analog p) = toCode p +instance toCode UserLED where + toCode LED1 = toCode 1 + toCode LED2 = toCode 2 + toCode LED3 = toCode 3 diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl index f853c65..24dc6a6 100644 --- a/mTaskInterpret.dcl +++ b/mTaskInterpret.dcl @@ -2,7 +2,8 @@ definition module mTaskInterpret from Data.Functor.Identity import :: Identity from Control.Monad.State import :: State, :: StateT -from Data.Monoid import class Semigroup, class Monoid +from Control.Monad.RWST import :: RWST, :: RWS +from Data.Either import :: Either import mTask :: MTaskMSGRecv @@ -80,9 +81,7 @@ decode :: String -> MTaskMSGRecv derive gPrint BC derive class gCons BC -:: ByteCode a p = BC (BCState -> ([BC], BCState)) -instance Semigroup (ByteCode a p) -instance Monoid (ByteCode a p) +:: ByteCode a p = BC (RWS () [BC] BCState ()) :: BCShare = { sdsi :: Int, @@ -99,7 +98,7 @@ instance zero BCState class toByteCode a :: a -> String class fromByteCode a :: String -> a -class mTaskType a | toByteCode, fromByteCode, zero a +class mTaskType a | toByteCode, fromByteCode a instance toByteCode Int, Bool, Char, Long, String, Button, UserLED instance fromByteCode Int, Bool, Char, Long, String, Button, UserLED @@ -128,5 +127,5 @@ toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState) toSDSUpdate :: Int Int -> [MTaskMSGSend] toByteVal :: BC -> String -toReadableByteCode :: (ByteCode a b) -> (String, BCState) +toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState) toRealByteCode :: (ByteCode a b) BCState -> (String, BCState) diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index 615aa10..1caa4ba 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -1,6 +1,5 @@ implementation module mTaskInterpret -//import iTasks import Generics.gCons import GenEq, StdMisc, StdArray, GenBimap @@ -20,10 +19,20 @@ import Data.Monoid import Data.Functor import StdList from Data.Func import $ -from Text import class Text(concat,join,toUpperCase), instance Text String +from Text import class Text(concat,toUpperCase), instance Text String +import qualified Text +import Text.JSON + +import Control.Monad.RWST +import Control.Monad.Identity +import Control.Monad +import Control.Applicative +import Data.Functor +import Data.Either import Data.Array import qualified Data.Map as DM +import qualified Data.List as DL import Text.Encodings.Base64 encode :: MTaskMSGSend -> String @@ -113,30 +122,27 @@ toByteVal b = {toChar $ consIndex{|*|} b} +++ (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) - -instance Monoid (ByteCode a p) where - mempty = retrn [] - -(<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r -(<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t) - -(<+->) infixr 1 -(<+->) m n :== m <++> retrn n - -runBC (BC m) = m - -retrn :: ([BC] -> ByteCode a p) -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`) +//(>>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode b q +//(>>) m n = BC \s->(let (_, s1) = runBC m s in +// let (a, s2) = runBC n s1 +// in (a, {s2 & bytecode=(s2.BCState.bytecode ++ s1.BCState.bytecode)})) +// +//(<+->) infixr 1 +//(<+->) m n :== m >> tell n +// +//runBC (BC m) = m +// +//tell :: [BC] -> ByteCode a p | mTaskType a +//tell b = BC \s->(zero, {s & bytecode=b++s.bytecode}) +// +//fmp :: (a -> BC) (ByteCode a p) -> ByteCode a q +//fmp f b = BC \s->let (a, s`) = runBC b s in (a, {s` & code=[f a:s`.code]}) 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 s = toString s -instance toByteCode String where toByteCode s = undef +instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s instance toByteCode Button where toByteCode s = {toChar $ consIndex{|*|} s} instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s} instance toByteCode MTaskInterval where @@ -150,9 +156,9 @@ 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 String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s +instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[0] +instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[0] instance fromByteCode MTaskInterval where fromByteCode s @@ -169,31 +175,41 @@ instance toChar Pin where derive gPrint BC derive class gCons BC +op2 :: (ByteCode a p1) (ByteCode a p2) BC -> ByteCode b Expr +op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc] + +op :: (ByteCode a p) BC -> ByteCode a Expr +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 = retrn [BCPush $ toByteCode x] - (+.) x y = x <++> y <+-> [BCAdd] - (-.) x y = x <++> y <+-> [BCSub] - (*.) x y = x <++> y <+-> [BCMul] - (/.) x y = x <++> y <+-> [BCDiv] + lit x = tell` [BCPush $ toByteCode x] + (+.) x y = op2 x y BCAdd + (-.) x y = op2 x y BCSub + (*.) x y = op2 x y BCMul + (/.) x y = op2 x y BCDiv instance boolExpr ByteCode where - (&.) x y = x <++> y <+-> [BCAnd] - (|.) x y = x <++> y <+-> [BCOr] - Not x = x <+-> [BCNot] - (==.) x y = x <++> y <+-> [BCEq] - (!=.) x y = x <++> y <+-> [BCNeq] - (<.) x y = x <++> y <+-> [ BCLes] - (>.) x y = x <++> y <+-> [BCGre] - (<=.) x y = x <++> y <+-> [BCLeq] - (>=.) x y = x <++> y <+-> [BCGeq] + (&.) x y = op2 x y BCAnd + (|.) x y = op2 x y BCOr + Not x = op x BCNot + (==.) x y = op2 x y BCEq + (!=.) x y = op2 x y BCNeq + (<.) x y = op2 x y BCLes + (>.) x y = op2 x y BCGre + (<=.) x y = op2 x y BCLeq + (>=.) x y = op2 x y BCGeq instance analogIO ByteCode where - analogRead p = retrn [BCAnalogRead $ pin p] - analogWrite p b = b <+-> [BCAnalogWrite $ pin p] + analogRead p = tell` [BCAnalogRead $ pin p] + analogWrite p b = op b (BCAnalogWrite $ pin p) instance digitalIO ByteCode where - digitalRead p = retrn [BCDigitalRead $ pin p] - digitalWrite p b = b <+-> [BCDigitalWrite $ pin p] + digitalRead p = tell` [BCDigitalRead $ pin p] + digitalWrite p b = op b (BCDigitalWrite $ pin p) instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e instance If ByteCode e Stmt Stmt where If b t e = BCIfStmt b t e @@ -201,65 +217,61 @@ instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e instance If ByteCode x y Stmt where If b t e = BCIfStmt b t e instance IF ByteCode where IF b t e = BCIfStmt b t e - (?) b t = BCIfStmt b t $ retrn [] -BCIfStmt b t e = - withLabel \else->withLabel \endif-> - b <++> retrn [BCJmpF else] <++> t - <++> retrn [BCJmp endif,BCLab else] <++> e <++> retrn [BCLab endif] + (?) b t = BCIfStmt b t $ tell` mempty +BCIfStmt (BC b) (BC t) (BC e) = BC $ + freshl >>= \else->freshl >>= \endif-> + b >>| tell [BCJmpF else] >>| + t >>| tell [BCJmp endif, BCLab else] >>| + e >>| tell [BCLab endif] -instance noOp ByteCode where noOp = retrn [BCNop] +freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr +freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr -withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q -withLabel f = BC \s->let [fresh:fs] = s.freshl - in runBC (f fresh) {s & freshl=fs} +instance noOp ByteCode where noOp = tell` [BCNop] -withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q -withSDS f = BC \s->let [fresh:fs] = s.freshs - in runBC (f fresh) {s & freshs=fs} - -setSDS :: Int v -> ByteCode b q | toByteCode v -setSDS ident val = BC \s->([], {s & sdss=[ - {BCShare|sdsi=ident,sdspub=False,sdsval=toByteCode val}:s.sdss]}) +unBC (BC x) = x instance sds ByteCode where - sds f = {main = withSDS \sds-> - let (v In body) = f $ retrn [BCSdsFetch sds] - in setSDS sds v <++> unMain body - } + sds f = {main = BC $ freshs + >>= \sds->pure (f (tell` [BCSdsFetch sds])) + >>= \(v In bdy)->modify (addSDS sds v) >>| unBC (unMain bdy)} + where + addSDS i v s = {s & sdss=[ + {sdsi=i,sdspub=False,sdsval=toByteCode v}:s.sdss]} con f = undef - pub x = BC \s-> let ((i, bc), s`) = appFst makePub $ runBC x s - in (bc, {s` & sdss=map (publish i) s`.sdss}) + pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) + (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty where - publish i s = if (i == s.sdsi) {s & sdspub=True} s - makePub [BCSdsFetch i:xs] = (i, [BCSdsPublish i:xs]) + publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]} instance assign ByteCode where - (=.) v e = e <++> fmp makeStore v - where makeStore [BCSdsFetch i:xs] = [BCSdsStore i:xs] + (=.) (BC v) (BC e) = BC $ e >>| censor makeStore v + where + makeStore [BCSdsFetch i] = [BCSdsStore i] instance seq ByteCode where (>>=.) _ _ = abort "undef on >>=." - (:.) x y = x <++> y + (:.) (BC x) (BC y) = BC $ x >>| y instance serial ByteCode where - serialAvailable = retrn [BCSerialAvail] - serialPrint s = retrn [BCSerialPrint] - serialPrintln s = retrn [BCSerialPrintln] - serialRead = retrn [BCSerialRead] - serialParseInt = retrn [BCSerialParseInt] + serialAvailable = tell` [BCSerialAvail] + serialPrint s = tell` [BCSerialPrint] + serialPrintln s = tell` [BCSerialPrintln] + serialRead = tell` [BCSerialRead] + serialParseInt = tell` [BCSerialParseInt] instance userLed ByteCode where - ledOn l = retrn [BCLedOn l] - ledOff l = retrn [BCLedOff l] + ledOn (BC l) = BC $ censor (\[BCPush d]->[BCLedOn $ fromByteCode d]) l + ledOff (BC l) = BC $ censor (\[BCPush d]->[BCLedOff $ fromByteCode d]) l instance zero BCState where zero = {freshl=[1..], freshs=[1..], sdss=[]} toRealByteCode :: (ByteCode a b) BCState -> (String, BCState) toRealByteCode x s -# (bc, st) = runBC x s +# (s, bc) = runBC x s # (bc, gtmap) = computeGotos bc 1 -= (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st) += (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), s) implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map) implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map) @@ -277,11 +289,14 @@ readable (BCPush d) = "BCPush " +++ concat [safe c\\c<-:d] safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c) readable b = printToString b -toReadableByteCode :: (ByteCode a b) -> (String, BCState) -toReadableByteCode x -# (bc, st) = runBC x zero +runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC])) +runBC (BC x) = execRWS x () + +toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState) +toReadableByteCode x s +# (s, bc) = runBC x s # (bc, gtmap) = computeGotos bc 0 -= (join "\n" $ map readable (map (implGotos gtmap) bc), st) += ('Text'.join "\n" $ map readable (map (implGotos gtmap) bc), s) toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState) toMessages interval (bytes, st=:{sdss}) = ( @@ -291,8 +306,10 @@ toMessages interval (bytes, st=:{sdss}) = ( toSDSUpdate :: Int Int -> [MTaskMSGSend] toSDSUpdate i v = [MTUpd i (to16bit v)] -Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero +//Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero +Start = fst $ toReadableByteCode (unMain bc) zero where +// bc = {main = ledOn (lit LED1)} bc = sds \x=5 In sds \y=4 In {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)} diff --git a/mTaskSimulation.dcl b/mTaskSimulation.dcl index 1669f23..ed86068 100644 --- a/mTaskSimulation.dcl +++ b/mTaskSimulation.dcl @@ -1,6 +1,6 @@ definition module mTaskSimulation -import iTasks.API.Core.Types +from iTasks.API.Core.Types import class iTask, :: Task, generic gEditor, generic gText, generic JSONEncode, generic JSONDecode, generic gDefault, :: Editor, :: TextFormat, :: JSONNode import mTask :: Display a = Display a @@ -111,6 +111,6 @@ class stringQuotes t | type t :: (Code t p) -> Code t p instance stringQuotes String instance stringQuotes t -derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo -derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long //, Servo +derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED //, Servo +derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED //, Servo instance == () diff --git a/mTaskSimulation.icl b/mTaskSimulation.icl index e158002..f4835be 100644 --- a/mTaskSimulation.icl +++ b/mTaskSimulation.icl @@ -255,8 +255,8 @@ instance stringQuotes String where stringQuotes x = c "\"" +.+ x +.+ c "\"" instance stringQuotes t where stringQuotes x = x -derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo -derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long//, Servo +derive toGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo +derive fromGenDynamic (), MTask, DigitalPin, AnalogPin, Pin, [], Long, UserLED//, Servo instance == () where (==) _ _ = True diff --git a/miTask.icl b/miTask.icl index 71b8911..47d3c8c 100644 --- a/miTask.icl +++ b/miTask.icl @@ -24,8 +24,6 @@ import iTasks._Framework.Serialization import TTY, iTasksTTY -derive class iTask UserLED - Start :: *World -> *World Start world = startEngine (mTaskManager >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world