Start iTasks Simulator

1 files changed, 180 insertions, 0 deletions

diff --git a/assignment-13/uFPL/Sim.icl b/assignment-13/uFPL/Sim.icl
new file mode 100644
index 0000000..ac42046
--- /dev/null
+++ b/assignment-13/uFPL/Sim.icl
@@ -0,0 +1,180 @@
+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)