implementation module mTaskInterpret

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

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

instance == BCValue where (==) a b = toByteCode a == toByteCode b

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"
encode (MTShutdown) = "h\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) (fromByteCode (x % (2, size 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
	toString (MTSpec) = "Spec request"
	toString (MTShutdown) = "Shutdown request"

instance toString MTaskMSGRecv where
	toString (MTTaskAck i mem) = "Task added with id: " +++ toString i
		+++ " free memory: " +++ toString mem
	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.sdsi
		(BCSdsFetch i) = to16bit i.sdsi
		(BCSdsPublish i) = to16bit i.sdsi
		(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
		, bytesMemory = from16bit $ s % (1,3)
		, stackSize  = from16bit $ s % (3,5)
		, aPins       = toInt s.[5]
		, dPins       = toInt s.[6]
		}

derive gPrint Long, UserLED, Button, AnalogPin, DigitalPin, PinMode, Pin, BC, MTaskDeviceSpec
derive class gCons BC, BCShare

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 p3
op2 (BC x) (BC y) bc = BC $ x >>| y >>| tell [bc]

op :: (ByteCode a p) BC -> ByteCode b c
op (BC x) bc = BC $ x >>| tell [bc]

tell` :: [BC] -> (ByteCode a p)
tell` x = BC $ tell x

instance arith ByteCode where
	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 =  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 = tell` [BCAnalogRead $ pin p]
	analogWrite p b = op b (BCAnalogWrite $ pin p)

instance digitalIO ByteCode where
	digitalRead p = tell` [BCDigitalRead $ pin p]
	digitalWrite p b = op b (BCDigitalWrite $ pin p)

instance aIO ByteCode where
	aIO p = tell` [BCAnalogRead $ pin p]

instance dIO ByteCode where
	dIO p = tell` [BCDigitalRead $ 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 $ 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]

freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl
freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs

instance noOp ByteCode where noOp = tell` [BCNop]

unBC :: (ByteCode a p) -> RWS () [BC] BCState ()
unBC (BC x) = x

instance sds ByteCode where
	sds f = {main = BC $ freshs
		>>= \sdsi->pure {BCShare | sdsname="", sdsi=sdsi, sdsval=BCValue 0}
		>>= \sds ->pure (f $ tell` [BCSdsFetch sds])
		>>= \(v In bdy)->modify (addSDS sds v)
		>>| unBC (unMain bdy)}
	where
		addSDS sds v s = {s & sdss=[{sds & sdsval=BCValue v}:s.sdss]}
	con f = undef

instance namedsds ByteCode where
	namedsds f = {main = BC $ freshs
		>>= \sdsi->pure {BCShare | sdsname="", sdsi=sdsi, sdsval=BCValue 0}
		>>= \sds ->pure (f $ tell` [BCSdsFetch sds])
		>>= \(v Named n In bdy)->modify (addSDS sds n v)
		>>| unBC (unMain bdy)}
	where
		addSDS sds n v s = {s & sdss=[{sds & sdsname=n, sdsval=BCValue v}:s.sdss]}

instance sdspub ByteCode where
	pub (BC x) = BC $ censor (\[BCSdsFetch s]->[BCSdsPublish s]) x

instance assign ByteCode where
	(=.) (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]
			makeStore [BCDigitalRead i] = [BCDigitalWrite i]
			makeStore [BCAnalogRead i] = [BCAnalogWrite i]

instance seq ByteCode where
	(>>=.) _ _ = abort "undef on >>=."
	(:.) (BC x) (BC y) = BC $ x >>| y

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

instance userLed ByteCode where
	ledOn  l = op l BCLedOn
	ledOff l = op l BCLedOff

instance retrn ByteCode where
  retrn = tell` [BCReturn]

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

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
= ('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 $ p0) zero
//		,'Text'.concat $ compile p0
//		]
Start = toReadableByteCode (unMain $ p0) zero
	where
		p0 :: (Main (a Int Expr)) | assign, namedsds, sds, arith a
//		p0 = sds \x = 6 In {main = x =. x *. lit 7}
		p0 = namedsds \x = 6 Named "x" In {main = x =. x *. lit 7}

		bc  = {main =
			IF (analogRead A0 >. lit 50)
			  ( digitalWrite D0 (lit True)  )
			  ( digitalWrite D0 (lit False) )
			}


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]

//derive class gCons UserLED, Long, Pin, Button, UserLED, AnalogPin, DigitalPin, PinMode