implementation module uFPL.Sim

import Data.Functor
import Data.Maybe

import iTasks

import uFPL
import uFPL.Bootstrap
import uFPL.C

derive class iTask UFPLException
instance toString UFPLException
where
	toString (LiftException s)    = "Lift exception: " +++ s
	toString (NoShareException s) = "No such share: " +++ s
	toString (WriteToROShare s)   = "Write to RO share: " +++ s

derive class iTask Signedness, CType, ReadOrWrite, ISharedInt, IShares, IExpr,
	ITrigger, IRule, INamedRule

ishares :: Shared IShares
ishares = sharedStore "ishares" gDefault{|*|}

getSharedInt :: ISharedRef -> Task ISharedInt
getSharedInt n = get ishares >>= \shrs -> case [shr \\ shr <- shrs.ishares | shr.iisname == n] of
	[]    -> throw (NoShareException n)
	[s:_] -> return s

instance lift [a] | lift a
where
	lift xs = dynamicList <$> allTasks (map lift xs)
	where
		dynamicList :: [Dynamic] -> Dynamic
		dynamicList ds = list (reverse ds) (dynamic [] :: A.a: [a])
		where
			list :: [Dynamic] Dynamic -> Dynamic
			list [(d :: t):r] (l :: [t]) = list r (dynamic [d:l])

instance unlift [a] [b] | unlift a b where unlift xs = map unlift xs

instance lift IExpr
where
	lift (ILitInt  i) = return (dynamic ELit i :: Expr Int RO)
	lift (ILitBool b) = return (dynamic ELit b :: Expr Bool RO)
	lift (ILitChar c) = return (dynamic ELit c :: Expr Char RO)
	lift (IShared s)  = getSharedInt s >>= lift >>= \s -> case s of
		(s :: UShared Int rw) -> return (dynamic EShared s)
	lift (IAdd a b)   = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int  rwa, b :: Expr Int  rwb) -> return (dynamic a +. b :: Expr Int  RO)
		(a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a +. b :: Expr Char RO)
		_ -> throw (LiftException "IAdd")
	lift (ISub a b)   = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int  rwa, b :: Expr Int  rwb) -> return (dynamic a -. b :: Expr Int  RO)
		(a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a -. b :: Expr Char RO)
		_ -> throw (LiftException "ISub")
	lift (IMul a b)   = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int rwa, b :: Expr Int rwb) -> return (dynamic a *. b :: Expr Int RO)
		_ -> throw (LiftException "IMul")
	lift (IDiv a b)   = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int rwa, b :: Expr Int rwb) -> return (dynamic a /. b :: Expr Int RO)
		_ -> throw (LiftException "IDiv")
	lift (IEq a b)    = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int  rwa, b :: Expr Int  rwb) -> return (dynamic a ==. b :: Expr Bool RO)
		(a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a ==. b :: Expr Bool RO)
		(a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a ==. b :: Expr Bool RO)
		_ -> throw (LiftException "IEq")
	lift (ILt a b)    = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Int  rwa, b :: Expr Int  rwb) -> return (dynamic a <. b :: Expr Bool RO)
		(a :: Expr Char rwa, b :: Expr Char rwb) -> return (dynamic a <. b :: Expr Bool RO)
		_ -> throw (LiftException "ILt")
	lift (IAnd a b)   = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a &&. b :: Expr Bool RO)
		_ -> throw (LiftException "IAnd")
	lift (IOr a b)    = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Expr Bool rwa, b :: Expr Bool rwb) -> return (dynamic a ||. b :: Expr Bool RO)
		_ -> throw (LiftException "IOr")
	lift (IIf b t e)  = lift b >>= \b -> lift t >>= \t -> lift e >>= \e -> case (b,t,e) of
		(b :: Expr Bool rwa, t :: Expr Int  rwb, e :: Expr Int  rwc) -> return (dynamic b ? (t,e) :: Expr Int  RO)
		(b :: Expr Bool rwa, t :: Expr Char rwb, e :: Expr Char rwc) -> return (dynamic b ? (t,e) :: Expr Char RO)
		(b :: Expr Bool rwa, t :: Expr Bool rwb, e :: Expr Bool rwc) -> return (dynamic b ? (t,e) :: Expr Bool RO)
		_ -> throw (LiftException "IIf")

instance unlift IExpr (Expr t rw) | Expr t
where
	unlift (ELit v) = case dynamic v of
		(i :: Int)  -> ILitInt  i
		(c :: Char) -> ILitChar c
		(b :: Bool) -> ILitBool b
	unlift (EShared s) = IShared s.sname
	unlift (a +. b) = IAdd (unlift a) (unlift b)
	unlift (a -. b) = ISub (unlift a) (unlift b)
	unlift (a *. b) = IMul (unlift a) (unlift b)
	unlift (a /. b) = IDiv (unlift a) (unlift b)
	unlift (EEq  _ a b) = IEq  (unlift a) (unlift b)
	unlift (ELt  _ a b) = ILt  (unlift a) (unlift b)
	unlift (EAnd _ a b) = IAnd (unlift a) (unlift b)
	unlift (EOr  _ a b) = IOr  (unlift a) (unlift b)
	unlift (EIf b t e) = IIf (unlift b) (unlift t) (unlift e)

instance lift ISharedInt
where
	lift s = return case s.iisrw of
		ReadOnly  -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RO
		ReadWrite -> dynamic {sname=s.iisname, stype=CTInt Sig, sinit=s.iisinit, srepr=intmap} :: UShared Int RW

// NOTE: Compiler doesn't allow instances for both RW and RO, so we assume everything is RW here...
instance unlift ISharedInt (UShared Int rw)
where
	unlift s = {iisname=s.sname, iisinit=s.sinit, iisrw=ReadWrite}

instance lift ITrigger
where
	lift (IChange s) = getSharedInt s >>= lift >>= \s -> case s of
		(s :: UShared Int rw) -> return (dynamic Change (EShared s))
		_ -> throw (LiftException "IChange")
	lift (IBecomes s e) = getSharedInt s >>= lift >>= \s -> lift e >>= \e -> case (s,e) of
		(s :: UShared Int rwa, e :: Expr Int rwb) -> return (dynamic EShared s ?= e)
		_ -> throw (LiftException "IBecomes")
	lift (ITAnd a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Trigger, b :: Trigger) -> return (dynamic a ?& b)
		_ -> throw (LiftException "ITAnd")
	lift (ITOr a b) = lift a >>= \a -> lift b >>= \b -> case (a,b) of
		(a :: Trigger, b :: Trigger) -> return (dynamic a ?| b)
		_ -> throw (LiftException "ITOr")

instance unlift ITrigger Trigger
where
	unlift (Change (EShared s)) = IChange s.sname
	unlift (EShared s ?= e) = IBecomes s.sname (unlift e)
	unlift (a ?& b) = ITAnd (unlift a) (unlift b)
	unlift (a ?| b) = ITOr (unlift a) (unlift b)

instance lift IRule
where
	lift (IAssign s e) = getSharedInt s >>= lift >>= \s -> lift e >>= \e -> case (s,e) of
		(s :: UShared Int  RW, e :: Expr Int  rw) -> return (dynamic EShared s <# e)
		(s :: UShared Char RW, e :: Expr Char rw) -> return (dynamic EShared s <# e)
		(s :: UShared Bool RW, e :: Expr Bool rw) -> return (dynamic EShared s <# e)
		(s :: UShared t    RO, _) -> throw (WriteToROShare s.sname)
		_ -> throw (LiftException "IAssign")
	lift (IWhen e rs) = lift e >>= \e -> lift rs >>= \rs -> case (e,rs) of
		(e :: Expr Bool rw, rs :: [Rule]) -> return (dynamic When e rs)
		_ -> throw (LiftException "IWhen")
	lift (ITrigger t rs) = lift t >>= \t -> lift rs >>= \rs -> case (t,rs) of
		(t :: Trigger, rs :: [Rule]) -> return (dynamic t >>> rs)
		_ -> throw (LiftException "IWhen")
	lift (ISetCursor (c,r)) = lift c >>= \c -> lift r >>= \r -> case (c,r) of
		(c :: Expr Int rwa, r :: Expr Int rwb) -> return (dynamic SetCursor (c,r))
		_ -> throw (LiftException "ISetCursor")
	lift (IPrint e) = lift e >>= \e -> case e of
		(e :: Expr Int  rw) -> return (dynamic Print e)
		(e :: Expr Char rw) -> return (dynamic Print e)
		(e :: Expr Bool rw) -> return (dynamic Print e)
		_ -> throw (LiftException "IPrint")

instance unlift IRule Rule
where
	unlift (EShared s <# e) = IAssign s.sname (unlift e)
	unlift (When e rs) = IWhen (unlift e) (unlift rs)
	unlift (t >>> rs) = ITrigger (unlift t) (unlift rs)
	unlift (SetCursor (c,r)) = ISetCursor (unlift c, unlift r)
	unlift (Print e) = IPrint (unlift e)

instance lift INamedRule
where
	lift (Rule s rs) = lift rs >>= \rs -> case rs of
		(rs :: [Rule]) -> return (dynamic s :=: rs)

instance unlift INamedRule NamedRule
where
	unlift (s :=: rs) = case dynamic rs of
		(r  :: Rule)   -> Rule s [unlift r]
		(rs :: [Rule]) -> Rule s (unlift rs)

simulate :: [NamedRule] -> Task ()
simulate rs = update >>= \rs -> viewInformation (Title "Your rules") [] rs $> ()
where
	update :: Task [INamedRule]
	update = updateInformation (Title "Rules") [] (unlift rs)