implementation module mTaskInterpret

//import iTasks
import Generics.gCons

import GenEq, StdMisc, StdArray, GenBimap
import GenPrint
import StdEnum
import mTask

import StdInt
import StdFile
import StdString

from StdFunc import o, const
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 Data.Array
import qualified Data.Map as DM
import Text.Encodings.Base64

encode :: MTaskMSGSend -> String
encode (MTTask to data) = "t" +++ tob +++ to16bit (size data) +++ data +++ "\n"
	where 
		tob = case to of
			OneShot = to16bit 0
			OnInterval i = to16bit i
			OnInterrupt _ = abort "Interrupts not implemented yet"
encode (MTTaskDel i) = "d" +++ to16bit i +++ "\n"
encode (MTSds i v) = "s" +++ to16bit i +++ v +++ "\n"
encode (MTUpd i v) = "u" +++ to16bit i +++ v +++ "\n"

decode :: String -> MTaskMSGRecv
decode x
| size x == 0 = MTEmpty
= case x.[0] of
	't' = MTTaskAck (from16bit (x % (1,3)))
	'd' = MTTaskDelAck (from16bit (x % (1,3)))
	'm' = MTMessage x
	's' = MTSDSAck (from16bit (x % (1,3)))
	'a' = MTSDSDelAck (from16bit (x % (1,3)))
	'p' = MTPub (from16bit (x % (1,3))) (x % (3,5))
	'\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 (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
		(BCPush i) = i
		(BCLab i) = {toChar i}
		(BCSdsStore i) = to16bit i
		(BCSdsFetch i) = to16bit i
		(BCSdsPublish i) = to16bit i
		(BCAnalogRead i) = {toChar i}
		(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 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 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 Button where toByteCode s = {toChar $ consIndex{|*|} s}
instance toByteCode UserLED where toByteCode s = {toChar $ consIndex{|*|} s}
instance toByteCode MTaskInterval where
	toByteCode OneShot = toByteCode 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 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 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 toChar Pin where
	toChar (Digital p) = toChar $ consIndex{|*|} p
	toChar (Analog p) = toChar $ consIndex{|*|} p

derive gPrint BC
derive class gCons BC

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]

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]

instance analogIO ByteCode where
	analogRead p = retrn [BCAnalogRead $ pin p]
	analogWrite p b = b <+-> [BCAnalogWrite $ pin p]

instance digitalIO ByteCode where
	digitalRead p = retrn [BCDigitalRead $ 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 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
	(?) 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}

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]})

instance sds ByteCode where
	sds f = {main = withSDS \sds->
			let (v In body) = f $ retrn [BCSdsFetch sds]
			in setSDS sds v <++> unMain body
		}
	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})
		where
			publish i s = if (i == s.sdsi) {s & sdspub=True} s
			makePub [BCSdsFetch i:xs] = (i, [BCSdsPublish i:xs])

instance assign ByteCode where
	(=.) v e = e <++> fmp makeStore v
		where makeStore [BCSdsFetch i:xs] = [BCSdsStore i:xs]

instance seq ByteCode where
	(>>=.) _ _ = abort "undef on >>=."
	(:.) x y = x <++> y

instance serial ByteCode where
	serialAvailable = retrn [BCSerialAvail]
	serialPrint s = retrn [BCSerialPrint]
	serialPrintln s = retrn [BCSerialPrintln]
	serialRead = retrn [BCSerialRead]
	serialParseInt = retrn [BCSerialParseInt]

instance userLed ByteCode where
	ledOn l = retrn [BCLedOn l]
	ledOff l = retrn [BCLedOff 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
# (bc, gtmap) = computeGotos bc 1
= (concat $ map (toString o toByteVal) (map (implGotos gtmap) bc), st)

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 [safe c\\c<-:d]
	where
		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
# (bc, gtmap) = computeGotos bc 0
= (join "\n" $ map readable (map (implGotos gtmap) bc), st)

toMessages :: MTaskInterval (String, BCState) -> ([MTaskMSGSend], BCState)
toMessages interval (bytes, st=:{sdss}) = (
	[MTSds s.sdsi (toString 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
	where
		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))

from16bit :: String -> Int
from16bit s = toInt s.[0] * 256 + toInt s.[1]