diff options
Diffstat (limited to 'assignment-13/uFPL/Sim.icl')
| -rw-r--r-- | assignment-13/uFPL/Sim.icl | 180 |
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) |