diff options
| author | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2016-08-05 10:52:56 +0200 |
|---|---|---|
| committer | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2016-08-05 10:52:56 +0200 |
| commit | 63880f58258ed84a2f2b15e5acf1dc699912d0d9 (patch) | |
| tree | e047e2b1dcff1e5cdfe95e8fb795ac166e95327e | |
| parent | 4a95e619dd206f9f3578d420500ee3824a413b33 (diff) | |
| download | events-63880f58258ed84a2f2b15e5acf1dc699912d0d9.tar events-63880f58258ed84a2f2b15e5acf1dc699912d0d9.tar.gz events-63880f58258ed84a2f2b15e5acf1dc699912d0d9.tar.bz2 events-63880f58258ed84a2f2b15e5acf1dc699912d0d9.tar.xz events-63880f58258ed84a2f2b15e5acf1dc699912d0d9.zip | |
Better variadic lifting of builtins
| -rw-r--r-- | events/src/Events/Spec/Eval.hs | 23 |
1 files changed, 12 insertions, 11 deletions
diff --git a/events/src/Events/Spec/Eval.hs b/events/src/Events/Spec/Eval.hs index 24cfeb6..ddb32e4 100644 --- a/events/src/Events/Spec/Eval.hs +++ b/events/src/Events/Spec/Eval.hs | |||
| @@ -49,21 +49,22 @@ evalExpr (EApp f a) = evalExpr $ beta a (evalExpr f) | |||
| 49 | -- bindE :: (m a -> b) -> Expr m (a ': Ctx b) (Fin b) | 49 | -- bindE :: (m a -> b) -> Expr m (a ': Ctx b) (Fin b) |
| 50 | -- bindE f = liftE $ bindE . f | 50 | -- bindE f = liftE $ bindE . f |
| 51 | 51 | ||
| 52 | type family Ctx f where | 52 | type family Ctx m f where |
| 53 | Ctx (a -> b) = (a ': Ctx b) | 53 | Ctx m (m a -> b) = (a ': Ctx m b) |
| 54 | Ctx a = '[] | 54 | Ctx m a = '[] |
| 55 | 55 | ||
| 56 | type family Fin f where | 56 | type family Fin m f where |
| 57 | Fin (a -> b) = Fin b | 57 | Fin m (m a -> b) = Fin m b |
| 58 | Fin a = a | 58 | Fin m (m a) = a |
| 59 | Fin m a = a | ||
| 59 | 60 | ||
| 60 | class Bindable m b where | 61 | class Bindable m b where |
| 61 | bindE :: (Val m a -> m b) -> Expr m (a ': Ctx b) (Fin b) | 62 | bindE :: (Val m a -> b) -> Expr m (a ': Ctx m b) (Fin m b) |
| 62 | 63 | ||
| 63 | instance {-# OVERLAPS #-} ((Val m b) ~ (m b), Applicative m, Bindable m c) => Bindable m (b -> c) where | 64 | instance ((Val m b) ~ (m b), Applicative m, Bindable m c) => Bindable m (m b -> c) where |
| 64 | bindE :: (Val m a -> m (b -> c)) -> Expr m (a ': b ': Ctx c) (Fin c) | 65 | bindE :: (Val m a -> m b -> c) -> Expr m (a ': b ': Ctx m c) (Fin m c) |
| 65 | bindE f = (EPri :: (Val m a -> Expr m (b ': Ctx c) (Fin c)) -> Expr m (a ': b ': Ctx c) (Fin c)) . ((bindE :: (Val m b -> m c) -> Expr m (b ': Ctx c) (Fin c)) . ) $ ((<*>) . f) | 66 | bindE f = (EPri :: (Val m a -> Expr m (b ': Ctx m c) (Fin m c)) -> Expr m (a ': b ': Ctx m c) (Fin m c)) . ((bindE :: (Val m b -> c) -> Expr m (b ': Ctx m c) (Fin m c)) . ) $ f |
| 66 | 67 | ||
| 67 | instance (Val m b ~ m b, Ctx b ~ '[], Fin b ~ b) => Bindable m b where | 68 | instance {-# OVERLAPPABLE #-} (Val m b ~ m b, Ctx m (m b) ~ '[], Fin m (m b) ~ b) => Bindable m (m b) where |
| 68 | bindE :: (Val m a -> Val m b) -> Expr m '[a] b | 69 | bindE :: (Val m a -> Val m b) -> Expr m '[a] b |
| 69 | bindE = EPri . (EVal .) | 70 | bindE = EPri . (EVal .) |