remove traces

[mTask.git] / mTaskInterpret.icl

diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl
index fff57e4..7a2559f 100644 (file)
--- a/mTaskInterpret.icl
+++ b/mTaskInterpret.icl
@@ -3,24 +3,80 @@ implementation module mTaskInterpret
 //import iTasks
 import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
 import GenPrint
 //import iTasks
 import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
 import GenPrint

+import StdEnum

 import mTask
 
 import StdFile
 import StdString
 
 import mTask
 
 import StdFile
 import StdString
 

-from StdFunc import o
+from StdFunc import o, const

 import StdBool
 import StdTuple
 import Data.Tuple
 import StdBool
 import StdTuple
 import Data.Tuple

+import Data.Monoid
+import Data.Functor

 import StdList
 from Data.Func import $
 from Text import class Text(concat,join,toUpperCase), instance Text String
 
 import StdList
 from Data.Func import $
 from Text import class Text(concat,join,toUpperCase), instance Text String
 

+import qualified Data.Map as DM
+import Text.Encodings.Base64
+
+encode :: MTaskMSGSend -> String
+encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
+encode (MTTask to data) = "t" +++ to16bit to +++ to16bit (size data) +++ data +++ "\n"
+encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"
+
+import StdDebug
+decode :: String -> MTaskMSGRecv
+decode x
+| size x == 0 = MTEmpty
+= case x.[0] of
+       '\0' = MTEmpty
+       '\n' = MTEmpty
+       'm' = MTMessage x
+       'u' = MTPub (from16bit (x % (1,3))) (x % (3,5))
+       _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n")
+
+safePrint :== toString o toJSON
+
+instance toString MTaskMSGSend where
+       toString (MTSds i v) = "Sds id: " +++ toString i
+               +++ " value " +++ safePrint v
+       toString (MTTask to data) = "Task timeout: " +++ toString to
+               +++ " data " +++ safePrint data
+       toString (MTUpd i v) = "Update id: " +++ toString i
+               +++ " value " +++ safePrint v
+
+instance toString MTaskMSGRecv where
+       toString (MTPub i v) = "Publish id: " +++ toString i
+               +++ " value " +++ safePrint v
+       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 (BCJmp i) = 2
+bclength (BCJmpT i) = 2
+bclength (BCJmpF i) = 2
+bclength _ = 1
+

 toByteVal :: BC -> [Char]
 toByteVal b
 toByteVal :: BC -> [Char]
 toByteVal b

-# bt = toByteCode b
+# bt = toChar $ consIndex{|*|} b

 = [bt:case b of
 = [bt:case b of

-               (BCPush i) = [toChar i]
+               (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]
                (BCAnalogRead i) = [toChar i]
                (BCAnalogWrite i) = [toChar i]
                (BCDigitalRead i) = [toChar i]


@@ -29,31 +85,45 @@ toByteVal b
                (BCJmpT i) = [toChar i]
                (BCJmpF i) = [toChar i]
                _ = []]
                (BCJmpT i) = [toChar i]
                (BCJmpF i) = [toChar i]
                _ = []]

-       where
-               toByteCode b = toChar $ consIndex{|*|} b + 1
+
+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`)

 
 instance toByteCode Bool where
 
 instance toByteCode Bool where

-       toByteCode True = [toChar 1]
-       toByteCode False = [toChar 0]
-instance toByteCode Int where toByteCode n = map toChar [n/(2<<7),n rem 265]
+       toByteCode True = [toChar 0, toChar 1]
+       toByteCode False = [toChar 0, toChar 0]
+instance toByteCode Int where toByteCode n = map toChar [n/256,n rem 256]

 instance toByteCode Long where toByteCode (L n) = toByteCode n
 instance toByteCode Char where toByteCode c = [c]
 instance toByteCode String where toByteCode s = undef
 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
 
 instance toChar Pin where
 instance toByteCode Long where toByteCode (L n) = toByteCode n
 instance toByteCode Char where toByteCode c = [c]
 instance toByteCode String where toByteCode s = undef
 instance toByteCode Button where toByteCode s = [toChar $ consIndex{|*|} s]
 
 instance toChar Pin where

-       toChar (Digital p) = toChar $ consIndex{|*|} p + 1
-       toChar (Analog p) = toChar $ consIndex{|*|} p + 1
+       toChar (Digital p) = toChar $ consIndex{|*|} p
+       toChar (Analog p) = toChar $ consIndex{|*|} p

 
 derive gPrint BC, AnalogPin, Pin, DigitalPin
 derive consIndex BC, Pin, Button
 derive consName BC, Pin, Button
 
 
 derive gPrint BC, AnalogPin, Pin, DigitalPin
 derive consIndex BC, Pin, Button
 derive consName BC, Pin, Button
 

-toReadableByteVal :: BC -> String
-toReadableByteVal a = printToString a
-

 instance arith ByteCode where
 instance arith ByteCode where

-       lit x = BC [BCPush 1]
+       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 <+-> [BCAdd]
        (-.) x y = x <++> y <+-> [BCSub]
        (*.) x y = x <++> y <+-> [BCMul]


@@ -71,70 +141,128 @@ instance boolExpr ByteCode where
        (>=.) x y = x <++> y <+-> [BCGeq]
 
 instance analogIO ByteCode where
        (>=.) x y = x <++> y <+-> [BCGeq]
 
 instance analogIO ByteCode where

-       analogRead p = BC [BCAnalogRead $ pin p]
+       analogRead p = retrn [BCAnalogRead $ pin p]

        analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
 
 instance digitalIO ByteCode where
        analogWrite p b = b <+-> [BCAnalogWrite $ pin p]
 
 instance digitalIO ByteCode where

-       digitalRead p = BC [BCDigitalRead $ pin p]
+       digitalRead p = retrn [BCDigitalRead $ pin p]

        digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
 
        digitalWrite p b = b <+-> [BCDigitalWrite $ pin p]
 

-instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e
-instance If ByteCode Stmt e Stmt where If b t e = BCIfStmt b t e
-instance If ByteCode Stmt Stmt e where If b t e = BCIfStmt b t e
-instance If ByteCode x y Expr 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
+//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 where
        IF b t e = BCIfStmt b t e

-       (?) b t = BCIfStmt b t $ BC []
-BCIfStmt b t e = b <+-> [BCJmpF $ length <$> t + 1] <++> t
-       <+-> [BCJmp $ length <$> e] <++> 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]
+
+instance noOp ByteCode where noOp = retrn [BCNop]
+
+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 = BC []
+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 = [(ident, toByteCode val):s.sdss]})

 
 instance sds ByteCode where
 
 instance sds ByteCode where

-       sds f = undef/*{main = 
-                       let var = 42
-                           (v In body) = f var
-                       in unMain body
-               }*/
+       sds f = {main = withSDS \sds->
+                       let (v In body) = f $ retrn [BCSdsFetch sds]
+                       in setSDS sds v <++> unMain body
+               }

        con f = undef
        con f = undef

+       pub x = fmp makePub x
+//     pub _ = undef
+
+instance assign ByteCode where
+       (=.) v e = e <++> fmp makeStore v
+
+makePub [] = []
+makePub [x:xs] = case x of
+       BCSdsFetch i = [BCSdsPublish i:xs]
+       y = [y:xs]
+
+makeStore [] = []
+makeStore [x:xs] = case x of
+       BCSdsFetch i = [BCSdsStore i:xs]
+       y = [y:xs]
+
+instance seq ByteCode where
+       (>>=.) _ _ = abort "undef on >>=."
+       (:.) x y = x <++> y

 
 instance serial ByteCode where
 
 instance serial ByteCode where

-       serialAvailable = BC [BCSerialAvail]
-       serialPrint s = BC [BCSerialPrint]
-       serialPrintln s = BC [BCSerialPrintln]
-       serialRead = BC [BCSerialRead]
-       serialParseInt = BC [BCSerialParseInt]
-
-(<++>) infixl 7
-(<++>) (BC x) (BC y) = BC $ x ++ y
-(<+->) infixl 7
-(<+->) (BC x) y = BC $ x ++ y
-(<-+>) infixl 7
-(<-+>) x (BC y) = BC $ x ++ y
-
-(<$>) infixl 9
-(<$>) f (BC x) = f x
+       serialAvailable = retrn [BCSerialAvail]
+       serialPrint s = retrn [BCSerialPrint]
+       serialPrintln s = retrn [BCSerialPrintln]
+       serialRead = retrn [BCSerialRead]
+       serialParseInt = retrn [BCSerialParseInt]

 
 instance zero BCState where
 
 instance zero BCState where

-       zero = {a=()}
+       zero = {freshl=[1..], freshs=[1..], sdss=[]}

 
 

-toRealByteCode :: (ByteCode a Expr) -> String
-toRealByteCode (BC x) = concat $ map (toString o toByteVal) x

 
 

-//Start :: ByteCode Int Expr
-//Start = (lit 36 +. lit 42) +. lit 84
+toRealByteCode :: (ByteCode a b) -> (String, BCState)
+toRealByteCode x
+# (bc, st) = runBC x zero
+# (bc, gtmap) = computeGotos bc 1
+= (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st)

 
 

-to16bit :: Int -> String
-to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265))
+implGotos map (BCJmp t) = BCJmp $ fromJust ('DM'.get t map)
+implGotos map (BCJmpT t) = BCJmpT $ fromJust ('DM'.get t map)
+implGotos map (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map)
+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)))
+
+readable :: BC -> String
+readable (BCPush d) = "BCPush " +++ concat (map safe d)
+       where
+               safe c
+               | 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
+# (bc, gtmap) = computeGotos bc 0
+= (join "\n" $ map readable (map (implGotos gtmap) bc), st)

 
 

-//Run test programma en pretty print

 //Start :: String
 //Start :: String

-//Start = "t" +++ to16bit (size b) +++ b
-Start :: Main (ByteCode Int Expr)
-Start = bc
+//Start = toReadableByteCode bc
+//     where
+//             bc :: ByteCode Int Expr
+//             bc = (lit 36 +. lit 42) +. lit 44
+toMessages :: Int (String, BCState) -> ([MTaskMSGSend], BCState)
+toMessages interval (bytes, st=:{sdss}) = ([MTSds i (toString b)\\(i,b)<-sdss] ++ [MTTask interval bytes], st)
+
+toSDSUpdate :: Int Int -> [MTaskMSGSend]
+toSDSUpdate i v = [MTUpd i (to16bit v)]
+
+Start = toMessages 500 $ toRealByteCode (unMain bc)
+//Start = fst $ toReadableByteCode $ unMain bc

        where
        where

-               bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)}
-               b = toRealByteCode bc
-//Start :: ByteCode Int Expr
-//Start = If (lit True) (analogRead A1) (analogRead A0)
-//Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)
+               bc = sds \x=5 In 
+                       sds \y=4 In
+                       {main = If (y ==. lit 0) (pub x) (x =. x *. y :. y =. y -. lit 1)}
+
+//pub :: (ByteCode a b) -> ByteCode a b
+//pub x = fmp makePub x
+
+to16bit :: Int -> String
+to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256))
+
+from16bit :: String -> Int
+from16bit s = toInt s.[0] * 256 + toInt s.[1]