X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=mTaskInterpret.icl;h=ef75b9a1bf7c3c58e599d1c01e441099d5371dcf;hb=88ecd686ff62986cde139abb65ab52b9e93d3035;hp=ab86aedc5ab19b704d4c19473d879592f2a640db;hpb=2d88e6e829ace95755ad099e074bbba1ee47bffa;p=mTask.git diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index ab86aed..ef75b9a 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -1,11 +1,16 @@ implementation module mTaskInterpret -//import iTasks -import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap +import Generics.gCons + +import iTasks.UI.Editor.Common +import iTasks.UI.Editor + +import GenEq, StdMisc, StdArray, GenBimap import GenPrint import StdEnum import mTask +import StdInt import StdFile import StdString @@ -17,166 +22,342 @@ import Data.Monoid import Data.Functor import StdList from Data.Func import $ -from Text import class Text(concat,join,toUpperCase), instance Text String - -toByteVal :: BC -> [Char] -toByteVal b -# bt = toChar $ consIndex{|*|} b + 1 -= [bt:case b of - (BCPush i) = i - (BCAnalogRead i) = [toChar i] - (BCAnalogWrite i) = [toChar i] - (BCDigitalRead i) = [toChar i] - (BCDigitalWrite i) = [toChar i] - (BCJmp i) = [toChar i] - (BCJmpT 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 - -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] -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 - -derive gPrint BC, AnalogPin, Pin, DigitalPin, BCState -derive consIndex BC, Pin, Button -derive consName BC, Pin, Button +from Text import class Text(subString,lpad,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 + +import Tasks.Examples + +encode :: MTaskMSGSend -> String +encode (MTTask to data) = "t" +++ toByteCode to +++ to16bit (size data) +++ data +++ "\n" +encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n" +encode (MTSds i v) = "s" +++ to16bit i +++ toByteCode v +++ "\n" +encode (MTUpd i v) = "u" +++ to16bit i +++ toByteCode v +++ "\n" +encode (MTSpec) = "c\n" + +import StdDebug +decode :: String -> MTaskMSGRecv +decode x +| not (trace_tn ("decoding: " +++ toString (toJSON x))) = undef +| size x == 0 = MTEmpty += case x.[0] of + 't' = MTTaskAck $ fromByteCode x + 'd' = MTTaskDelAck $ fromByteCode x + 'm' = MTMessage x + 's' = MTSDSAck $ fromByteCode x + 'a' = MTSDSDelAck $ fromByteCode x + 'p' = MTPub (fromByteCode x) $ fromByteCode $ x % (3,size x) + 'c' = MTDevSpec $ fromByteCode (x % (1, size x)) + '\0' = MTEmpty + '\n' = MTEmpty + _ = MTMessage x//abort ("Didn't understand message: " +++ join " " [toString (toInt c)\\c<-: x] +++ "\n") + +safePrint :== toString o toJSON + +instance toString MTaskInterval where + toString OneShot = "One shot" + toString (OnInterrupt i) = "Interrupt: " +++ toString i + toString (OnInterval i) = "Every " +++ toString i +++ "ms" + +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 (MTTaskDel i) = "Task delete request: " +++ toString i + toString (MTUpd i v) = "Update id: " +++ toString i + +++ " value " +++ safePrint v + +instance toString MTaskMSGRecv where + toString (MTTaskAck i) = "Task added with id: " +++ toString i + toString (MTTaskDelAck i) = "Task deleted with id: " +++ toString i + toString (MTSDSAck i) = "SDS added with id: " +++ toString i + toString (MTSDSDelAck i) = "SDS deleted with id: " +++ toString i + toString (MTPub i v) = "Publish id: " +++ toString i + +++ " value " +++ safePrint v + toString (MTDevSpec mt) = "Specification: " +++ printToString mt + toString (MTMessage m) = m + toString MTEmpty = "Empty message" + +toByteVal :: BC -> String +toByteVal b = {toChar $ consIndex{|*|} b} +++ + case b of + (BCPush (BCValue i)) = toByteCode i + (BCLab i) = {toChar i} + (BCSdsStore i) = to16bit i + (BCSdsFetch i) = to16bit i + (BCSdsPublish i) = to16bit i + (BCAnalogRead i) = {toChar $ consIndex{|*|} i} + (BCAnalogWrite i) = {toChar $ consIndex{|*|} i} + (BCDigitalRead i) = {toChar $ consIndex{|*|} i} + (BCDigitalWrite i) = {toChar $ consIndex{|*|} i} + (BCJmp i) = {toChar i} + (BCJmpT i) = {toChar i} + (BCJmpF i) = {toChar i} + _ = "" + +parseBCValue :: Char String -> BCValue +parseBCValue c s = case c of + 'b' = BCValue $ castfbc True s + 'i' = BCValue $ castfbc 0 s + 'l' = BCValue $ castfbc (L 0) s + 'c' = BCValue $ castfbc ('0') s + 'B' = BCValue $ castfbc (NoButton) s + 'L' = BCValue $ castfbc (LED1) s + +castfbc :: a -> (String -> a) | mTaskType a +castfbc _ = fromByteCode + +instance toByteCode Bool where toByteCode b = {#'b',if b '\x01' '\0'} +instance toByteCode Int where toByteCode n = {'i',toChar $ n/256,toChar $ n rem 256} +instance toByteCode Long where toByteCode (L n) = {'l',toChar $ n/256,toChar $ n rem 256} +instance toByteCode Char where toByteCode c = {'c',c} +instance toByteCode String where toByteCode s = abort $ "Undef on toBytecode String" +++ s +instance toByteCode Button where toByteCode s = {'B',toChar $ consIndex{|*|} s} +instance toByteCode UserLED where toByteCode s = {'L',toChar $ consIndex{|*|} s} +instance toByteCode BCValue where toByteCode (BCValue v) = toByteCode v + +instance fromByteCode Bool where fromByteCode s = s.[1] == '\x01' +instance fromByteCode Int where fromByteCode s = (toInt s.[1])*256 + toInt s.[2] +instance fromByteCode Long where fromByteCode s = L $ fromByteCode s +instance fromByteCode Char where fromByteCode s = s.[1] +instance fromByteCode String where fromByteCode s = abort $ "Undef on fromBytecode String" +++ s +instance fromByteCode Button where fromByteCode s = conses{|*|} !! toInt s.[1] +instance fromByteCode UserLED where fromByteCode s = conses{|*|} !! toInt s.[1] +instance fromByteCode BCValue where fromByteCode s = parseBCValue s.[0] s + +instance toByteCode MTaskInterval where + toByteCode OneShot = toByteCode (OnInterval 0) + //Intervals have the first bit 0 and the rest is a 15 bit unsigned int + toByteCode (OnInterval i) = {toChar $ i/256 bitand 127, toChar $ i rem 256} + //Intervals have the first bit 1 and the rest is a 15 bit unsigned int + toByteCode (OnInterrupt i) = {toChar $ i/256 bitor 127, toChar $ i rem 256} +instance fromByteCode MTaskInterval + where + fromByteCode s + //Interval + | (toInt s.[0]) bitand 128 == 0 = case fromByteCode s of + 0 = OneShot + i = OnInterval i + = OnInterrupt $ fromByteCode s bitand 127 +instance fromByteCode MTaskDeviceSpec where + fromByteCode s = let c = toInt s.[0] in + {MTaskDeviceSpec + |haveLed=(c bitand 1) > 0 + ,haveAio=(c bitand 2) > 0 + ,haveDio=(c bitand 4) > 0 + ,maxTask=from16bit $ s % (1,3) + ,maxSDS=from16bit $ s % (3,5) + } + +derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec +derive class gCons BC + +consIndex{|BCValue|} _ = 0 +consName{|BCValue|} _ = "BCValue" +conses{|BCValue|} = [BCValue 0] +consNum{|BCValue|} _ = 1 +gPrint{|BCValue|} v ps = gPrint{|*|} (readable $ BCPush v) ps + +gEditor{|BCValue|} = {Editor|genUI=genUI`,onEdit=onEdit`,onRefresh=onRefresh`} + where + genUI` dp (BCValue a) vst = (castEditor a).Editor.genUI dp a vst + onEdit` dp jsn (BCValue a) em vst = appSnd3 BCValue $ (castEditor a).Editor.onEdit dp jsn a em vst + onRefresh` dp (BCValue a) (BCValue a`) em vst = appSnd3 BCValue $ (castEditor a).Editor.onRefresh dp a (fromByteCode $ toByteCode a`) em vst + + castEditor :: a -> (Editor a) | mTaskType a + castEditor _ = gEditor{|*|} + +gText{|BCValue|} fm Nothing = [] +gText{|BCValue|} fm (Just (BCValue e)) = gText{|*|} fm (Just e) +JSONEncode{|BCValue|} b (BCValue e) = JSONEncode{|*|} b (toByteCode e) +JSONDecode{|BCValue|} b n = appFst (fmap fromByteCode) $ JSS b n + where + JSS :: (Bool [JSONNode] -> (Maybe String, [JSONNode])) + JSS = JSONDecode{|*|} +gDefault{|BCValue|} = BCValue 0 +gEq{|BCValue|} (BCValue e) (BCValue f) = toByteCode e == toByteCode f + +derive class gCons Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin +derive class iTask UserLED, Long, Pin, Button, AnalogPin, DigitalPin, PinMode, MTaskDeviceSpec + +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 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 $ BCValue 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 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 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->retrn [BCJmpF else] <++> t - <++> retrn [BCJmp endif] <++> 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 = mempty +freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr +freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr +instance noOp ByteCode where noOp = tell` [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} - -withSDS :: (Int -> (ByteCode b q)) -> ByteCode b q -withSDS f = BC \s->let [fresh:fs] = s.freshs - in runBC (f fresh) {s & freshs=fs} +unBC (BC x) = x instance sds ByteCode where - sds f = {main = withSDS \sds-> - let (v In body) = f $ retrn [BCSdsStore sds] - in unMain body <++> retrn [BCSdsStore sds] - } + 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=(BCValue v)}:s.sdss]} + con f = undef + pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) + (listen x >>= \(_, [BCSdsFetch s])->modify (publish s)) >>| tell mempty + where + publish i st = {st & sdss=[if (i == s.sdsi) {s & sdspub=True} s \\s<-st.sdss]} instance assign ByteCode where - (=.) v e = e <++> abort (printToString $ fst $ runBC v zero) + (=.) (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 (>>=.) _ _ = 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 zero BCState where - zero = {freshl=[1..], freshs=[1..]} +instance userLed ByteCode where + ledOn (BC l) = BC $ l >>| tell [BCLedOn] + ledOff (BC l) = BC $ l >>| tell [BCLedOff] -toRealByteCode :: (ByteCode a Expr) -> String -toRealByteCode x -# (bc, st) = runBC x zero -= concat $ map (toString o toByteVal) bc +instance zero BCState where + zero = {freshl=[1..], freshs=[1..], sdss=[]} + +toRealByteCode :: (ByteCode a b) BCState -> (String, BCState) +toRealByteCode x s +# (s, bc) = runBC x s +# (bc, gtmap) = computeGotos bc 1 += (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 (BCJmpF t) = BCJmpF $ fromJust ('DM'.get t map) +implGotos _ i = i + +bclength :: BC -> Int +bclength (BCPush s) = 1 + size (toByteCode s) +bclength (BCSdsStore _) = 3 +bclength (BCSdsFetch _) = 3 +bclength (BCSdsPublish _) = 3 +bclength x = 1 + consNum{|*|} x + +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 [safe c\\c<-:toByteCode d] + where + safe c = if (isControl c) ("\\d" +++ toString (toInt c)) (toString c) +readable b = printToString b -toReadableByteCode :: (ByteCode a Expr) -> String -toReadableByteCode x -# (bc, st) = runBC x zero -= join "\n" $ map printToString bc +runBC :: (ByteCode a b) -> (BCState -> (BCState, [BC])) +runBC (BC x) = execRWS x () -toReadableByteVal :: BC -> String -toReadableByteVal a = printToString a +toReadableByteCode :: (ByteCode a b) BCState -> (String, BCState) +toReadableByteCode x s +# (s, bc) = runBC x s +# (bc, gtmap) = computeGotos bc 0 += ('Text'.join "\n" $ lineNumbers numbers (map (implGotos gtmap) bc), s) + where + numbers = map (\n->lpad (toString n) 3 ' ' +++ ". ") [0..] + lineNumbers ls [] = [] + lineNumbers [l:ls] [b:bc] = [l +++ readable b:ex ++ lineNumbers newls bc] + where + (ex, newls) = splitAt (bclength b - 1) ls + +derive gPrint BCShare + +toMessages :: MTaskInterval (Main (ByteCode a b)) BCState -> ([MTaskMSGSend], BCState) +toMessages interval x s +# (bc, newstate) = toRealByteCode (unMain x) s +# newsdss = 'DL'.difference newstate.sdss s.sdss +| not (trace_tn $ printToString s.sdss) = undef +| not (trace_tn $ printToString newstate.sdss) = undef +| not (trace_tn $ printToString newsdss) = undef += ([MTSds sdsi e\\{sdsi,sdsval=e}<-newsdss] ++ + [MTTask interval bc], newstate) + +instance == BCShare where (==) a b = a.sdsi == b.sdsi + +//Start = toMessages (OnInterval 500) $ toRealByteCode (unMain bc) zero +Start = fst $ toReadableByteCode (unMain $ countAndLed) zero +//Start = fst $ toReadableByteCode (unMain $ blink LED1) zero +//Start = let (bcs, st) = toReadableByteCode (unMain bc) zero +// in (bcs, st.sdss) + 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)} +to16bit :: Int -> String +to16bit i = toString (toChar (i/256)) +++ toString (toChar (i rem 256)) -//Start :: String -//Start = toReadableByteCode bc -// where -// bc :: ByteCode Int Expr -// bc = (lit 36 +. lit 42) +. lit 44 +from16bit :: String -> Int +from16bit s = toInt s.[0] * 256 + toInt s.[1] -Start :: String -Start = toReadableByteCode $ unMain bc - where - bc :: Main (ByteCode Int Expr) - bc = sds \x=46 In - sds \y=46 In - {main = y =. x +. y} - -//to16bit :: Int -> String -//to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265)) -// -////Run test programma en pretty print -////Start :: String -////Start = "t" +++ to16bit (size b) +++ b -//Start :: Main (ByteCode Int Expr) -//Start = bc -// 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) +//derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode