rewrite generation to rws

diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl
index 661c701..71c6ee2 100644 (file)
--- a/Devices/mTaskDevice.icl
+++ b/Devices/mTaskDevice.icl
@@ -109,12 +109,13 @@ sendToDevice wta mTask (device, timeout) =
                toSDSRecords st = [{MTaskShare |
                        withTask=wta,
                        identifier=sdsi,
                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]
 
                        //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]}
 
                addTask :: MTaskTask MTaskDevice -> MTaskDevice
                addTask task device = {device & deviceTasks=[task:device.deviceTasks]}

diff --git a/Makefile b/Makefile
index ab55386..cbc1ea9 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -19,9 +19,9 @@ CLMLIBS:=\
        -I $(CLEAN_HOME)/lib/TCPIP\
        -I ./CleanSerial
 
        -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/ \;
 
        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 (file)
--- a/Shares/mTaskShare.dcl
+++ b/Shares/mTaskShare.dcl
@@ -5,6 +5,7 @@ import iTasks
 :: MTaskShare = {
                withTask :: String,
                identifier :: Int,
 :: MTaskShare = {
                withTask :: String,
                identifier :: Int,

+               initVal :: String,

                realShare :: String
        }
 
                realShare :: String
        }
 

diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl
index 70d1014..eb799df 100644 (file)
--- 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
        //<<@ 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 (file)
--- a/Tasks/Examples.icl
+++ b/Tasks/Examples.icl
@@ -6,8 +6,6 @@ import mTask
 import Devices.mTaskDevice
 import iTasks._Framework.Serialization
 
 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) (
 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) (
                noOp
        ) :.
        IF (pinnetje ==. lit 1) (

-               ledOn LED1
+               ledOn (lit LED1)

        ) (
                IF (pinnetje ==. lit 2) (
        ) (
                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
        }
 
        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 :: UserLED -> Main (ByteCode () Stmt)

-ledtOn d = {main = ledOn d}
+ledtOn d = {main = ledOn (lit d) :. noOp}

 
 ledtOff :: UserLED -> Main (ByteCode () Stmt)
 
 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)))
 
 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 (file)
--- a/Tasks/mTaskTask.dcl
+++ b/Tasks/mTaskTask.dcl
@@ -4,7 +4,7 @@ import Devices.mTaskDevice
 import mTask
 import iTasks
 
 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,
 
 :: MTaskTask = {
                name :: String,

diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl
index 18ad5b1..9cc5a98 100644 (file)
--- a/Tasks/mTaskTask.icl
+++ b/Tasks/mTaskTask.icl
@@ -5,7 +5,7 @@ import iTasks
 
 import iTasks._Framework.Serialization
 
 
 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 
 
 makeTask :: String Int -> Task MTaskTask
 makeTask name ident = get currentDateTime 

diff --git a/Utils/SDS.icl b/Utils/SDS.icl
index d67ba6e..3d8e3a0 100644 (file)
--- 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
 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]
 
 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 (file)
--- a/mTask.dcl
+++ b/mTask.dcl
@@ -18,10 +18,10 @@ import GenPrint
 import Generics.gCons
 import Generics.gdynamic
 
 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
 
 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 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
 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
   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
   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
   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
 
 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 MTask
 instance type2string DigitalPin
 instance type2string AnalogPin

+instance type2string UserLED

 instance type2string String
 instance type2string ()
 class varName a :: a -> String
 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 == DigitalPin
 instance == AnalogPin

+instance == UserLED

 
 tab =: toString (repeatn tabSize ' ')
 tabSize :== 2
 
 tab =: toString (repeatn tabSize ' ')
 tabSize :== 2

diff --git a/mTask.icl b/mTask.icl
index 9d42d2f..b92b1fc 100644 (file)
--- 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 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 _ = ""
 
 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 == 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 gPrint Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
 derive class gCons Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode
 

-

 tab =: toString (repeatn tabSize ' ')
 tabSize :== 2
 
 tab =: toString (repeatn tabSize ' ')
 tabSize :== 2
 

diff --git a/mTaskCode.dcl b/mTaskCode.dcl
index 47aff54..91c7038 100644 (file)
--- a/mTaskCode.dcl
+++ b/mTaskCode.dcl
@@ -14,6 +14,7 @@ instance toCode Char
 instance toCode String
 instance toCode DigitalPin
 instance toCode AnalogPin
 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
 
 
 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 (file)
--- 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 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 (file)
--- 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.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
 import mTask
 
 :: MTaskMSGRecv


@@ -80,9 +81,7 @@ decode :: String -> MTaskMSGRecv
 derive gPrint BC
 derive class gCons BC
 
 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,
 
 :: BCShare = {
                sdsi :: Int,


@@ -99,7 +98,7 @@ instance zero BCState
 
 class toByteCode a :: a -> String
 class fromByteCode a :: String -> a
 
 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
 
 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
 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)
 toRealByteCode :: (ByteCode a b) BCState -> (String, BCState)

diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl
index 615aa10..1caa4ba 100644 (file)
--- a/mTaskInterpret.icl
+++ b/mTaskInterpret.icl
@@ -1,6 +1,5 @@
 implementation module mTaskInterpret
 
 implementation module mTaskInterpret
 

-//import iTasks

 import Generics.gCons
 
 import GenEq, StdMisc, StdArray, GenBimap
 import Generics.gCons
 
 import GenEq, StdMisc, StdArray, GenBimap


@@ -20,10 +19,20 @@ import Data.Monoid
 import Data.Functor
 import StdList
 from Data.Func import $
 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 Data.Array
 import qualified Data.Map as DM

+import qualified Data.List as DL

 import Text.Encodings.Base64
 
 encode :: MTaskMSGSend -> String
 import Text.Encodings.Base64
 
 encode :: MTaskMSGSend -> String


@@ -113,30 +122,27 @@ toByteVal b = {toChar $ consIndex{|*|} b} +++
                (BCJmpF 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)
-
-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 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
 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 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
 instance fromByteCode MTaskInterval
        where
                fromByteCode s


@@ -169,31 +175,41 @@ instance toChar Pin where
 derive gPrint BC
 derive class gCons BC
 
 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
 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
 
 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
 
 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
 
 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
 
 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
 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
 
 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
        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
                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
 
 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 >>=."
 
 instance seq ByteCode where
        (>>=.) _ _ = abort "undef on >>=."

-       (:.) x y = x <++> y
+       (:.) (BC x) (BC y) = BC $ x >>| y

 
 instance serial ByteCode where
 
 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
 
 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
 
 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
 # (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)
 
 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
 
                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
 # (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}) = (
 
 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)]
 
 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
        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)}
                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 (file)
--- a/mTaskSimulation.dcl
+++ b/mTaskSimulation.dcl
@@ -1,6 +1,6 @@
 definition module mTaskSimulation
 
 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
 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
 
 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 ==   ()
 instance ==   ()

diff --git a/mTaskSimulation.icl b/mTaskSimulation.icl
index e158002..f4835be 100644 (file)
--- 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
 
 
 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
 
 
 instance ==   () where (==) _ _ = True
 
 

diff --git a/miTask.icl b/miTask.icl
index 71b8911..47d3c8c 100644 (file)
--- a/miTask.icl
+++ b/miTask.icl
@@ -24,8 +24,6 @@ import iTasks._Framework.Serialization
 
 import TTY, iTasksTTY
 
 
 import TTY, iTasksTTY
 

-derive class iTask UserLED
-

 Start :: *World -> *World
 Start world = startEngine (mTaskManager
        >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world
 Start :: *World -> *World
 Start world = startEngine (mTaskManager
        >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world