implementation module mTaskInterpret

//import iTasks
import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap
import GenPrint
import StdEnum
import mTask

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 Text.Encodings.Base64

encode :: MTaskMessage -> String
encode (MTSds i v) = "s" +++ to16bit i +++ v
encode (MTTask to data) = "t" +++ to16bit to +++ toString (size data) +++ data
encode (MTPub i v) = "u" +++ to16bit i +++ v
encode (MTUpd i v) = "u" +++ to16bit i +++ v

decode :: String -> MTaskMessage
decode x = case x.[0] of
	'u' = MTUpd (toInt x.[1]) (x % (2,4))
	_ = abort ("Didn't understand message: " +++ x)

safePrint :: String -> String
safePrint s = join " " [saf c\\c<-:s]
	where
		saf c = "\x" +++ toString (toInt c)

derive gPrint MTaskMessage
instance toString MTaskMessage where
	toString (MTSds i v) = "Sds id: " +++ toString i
		+++ " value " +++ safePrint v
	toString (MTTask to data) = "Task timeout: " +++ toString to
		+++ " data " +++ safePrint data
	toString (MTPub i v) = "Publish id: " +++ toString i
		+++ " value " +++ safePrint v
	toString (MTUpd i v) = "Update id: " +++ toString i
		+++ " value " +++ safePrint v

toByteVal :: BC -> [Char]
toByteVal b
# bt = toChar $ consIndex{|*|} b + 1
= [bt:case b of
		(BCPush i) = i
		(BCSdsStore i) = [toChar i]
		(BCSdsFetch i) = [toChar i]
		(BCSdsPublish i) = [toChar 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
fmp :: ([BC] -> [BC]) (ByteCode a p) -> ByteCode a p
fmp f b = BC \s->let (bc, s`) = runBC b s in (f bc, s`)

instance toByteCode Bool where
	toByteCode True = [toChar 1]
	toByteCode False = [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
	toChar (Digital p) = toChar $ consIndex{|*|} p + 1
	toChar (Analog p) = toChar $ consIndex{|*|} p + 1

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

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

instance noOp ByteCode where noOp = mempty

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 = [(ident, 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 _ = 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
	serialAvailable = retrn [BCSerialAvail]
	serialPrint s = retrn [BCSerialPrint]
	serialPrintln s = retrn [BCSerialPrintln]
	serialRead = retrn [BCSerialRead]
	serialParseInt = retrn [BCSerialParseInt]

instance zero BCState where
	zero = {freshl=[1..], freshs=[1..], sdss=[]}

makeSafe :: Char -> Char
makeSafe c = c//toChar $ toInt c + 31

toRealByteCode :: (ByteCode a b) -> (String, BCState)
toRealByteCode x
# (bc, st) = runBC x zero
= (concat $ map (toString o map makeSafe o toByteVal) bc, st)

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
= (join "\n" $ map readable bc, st)

//Start :: String
//Start = toReadableByteCode bc
//	where
//		bc :: ByteCode Int Expr
//		bc = (lit 36 +. lit 42) +. lit 44
toMessages :: Int (String, BCState) -> [MTaskMessage]
toMessages interval (bytes, {sdss}) = [MTSds i (toString b)\\(i,b)<-sdss] ++ [MTTask interval bytes]

Start = toMessages 500 $ toRealByteCode (unMain bc)
//Start = fst $ toReadableByteCode $ unMain bc
	where
		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/265)) +++ toString (toChar (i rem 265))

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