\begin{comment}
\begin{code}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
module LiveCoding.Exceptions.Finite where
import Control.Arrow
import GHC.Generics
import Data.Data
import Data.Void
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import LiveCoding.Cell
import LiveCoding.Cell.Monad.Trans
\end{code}
\end{comment}
\begin{code}
class Finite e where
commute :: Monad m => (e -> Cell m a b) -> Cell (ReaderT e m) a b
default commute :: (Generic e, GFinite (Rep e), Monad m) => (e -> Cell m a b) -> Cell (ReaderT e m) a b
commute e -> Cell m a b
handler = forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall a x. Generic a => a -> Rep a x
from) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall a b. (a -> b) -> a -> b
$ e -> Cell m a b
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to
class GFinite f where
gcommute :: Monad m => (f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
instance GFinite f => GFinite (M1 a b f) where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
(M1 a b f e -> Cell m a b) -> Cell (ReaderT (M1 a b f e) m) a b
gcommute M1 a b f e -> Cell m a b
handler = forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall a b. (a -> b) -> a -> b
$ M1 a b f e -> Cell m a b
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1
instance Finite e => GFinite (K1 a e) where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
(K1 a e e -> Cell m a b) -> Cell (ReaderT (K1 a e e) m) a b
gcommute K1 a e e -> Cell m a b
handler = forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall k i c (p :: k). K1 i c p -> c
unK1) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a b.
(Finite e, Monad m) =>
(e -> Cell m a b) -> Cell (ReaderT e m) a b
commute forall a b. (a -> b) -> a -> b
$ K1 a e e -> Cell m a b
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1
instance GFinite V1 where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
(V1 e -> Cell m a b) -> Cell (ReaderT (V1 e) m) a b
gcommute V1 e -> Cell m a b
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"gcommute: Can't commute with an empty type"
instance Finite Void where
commute :: forall (m :: * -> *) a b.
Monad m =>
(Void -> Cell m a b) -> Cell (ReaderT Void m) a b
commute Void -> Cell m a b
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Nope"
instance GFinite U1 where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
(U1 e -> Cell m a b) -> Cell (ReaderT (U1 e) m) a b
gcommute U1 e -> Cell m a b
handler = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell forall a b. (a -> b) -> a -> b
$ U1 e -> Cell m a b
handler forall k (p :: k). U1 p
U1
instance Finite () where
instance Finite Bool where
commute :: forall (m :: * -> *) a b.
Monad m =>
(Bool -> Cell m a b) -> Cell (ReaderT Bool m) a b
commute Bool -> Cell m a b
handler = proc a
a -> do
Bool
bool <- forall (m :: * -> *) b a. m b -> Cell m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
if Bool
bool
then forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell forall a b. (a -> b) -> a -> b
$ Bool -> Cell m a b
handler Bool
True -< a
a
else forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell forall a b. (a -> b) -> a -> b
$ Bool -> Cell m a b
handler Bool
False -< a
a
instance (GFinite eL, GFinite eR) => GFinite (eL :+: eR) where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
((:+:) eL eR e -> Cell m a b)
-> Cell (ReaderT ((:+:) eL eR e) m) a b
gcommute (:+:) eL eR e -> Cell m a b
handler
= let
cellLeft :: Cell m (eL e, a) b
cellLeft = forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall a b. (a -> b) -> a -> b
$ (:+:) eL eR e -> Cell m a b
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1
cellRight :: Cell m (eR e, a) b
cellRight = forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall a b. (a -> b) -> a -> b
$ (:+:) eL eR e -> Cell m a b
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
gdistribute :: (:+:) f g p -> b -> Either (f p, b) (g p, b)
gdistribute (L1 f p
eR) b
a = forall a b. a -> Either a b
Left (f p
eR, b
a)
gdistribute (R1 g p
eL) b
a = forall a b. b -> Either a b
Right (g p
eL, b
a)
in
proc a
a -> do
(:+:) eL eR e
either12 <- forall (m :: * -> *) b a. m b -> Cell m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell (Cell m (eL e, a) b
cellLeft forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Cell m (eR e, a) b
cellRight) -< forall {f :: * -> *} {g :: * -> *} {p} {b}.
(:+:) f g p -> b -> Either (f p, b) (g p, b)
gdistribute (:+:) eL eR e
either12 a
a
instance (Finite e1, Finite e2) => Finite (Either e1 e2) where
instance (GFinite e1, GFinite e2) => GFinite (e1 :*: e2) where
gcommute :: forall (m :: * -> *) e a b.
Monad m =>
((:*:) e1 e2 e -> Cell m a b)
-> Cell (ReaderT ((:*:) e1 e2 e) m) a b
gcommute (:*:) e1 e2 e -> Cell m a b
handler = forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell forall {f :: * -> *} {p} {g :: * -> *} {m :: * -> *} {a}.
ReaderT (f p) (ReaderT (g p) m) a -> ReaderT ((:*:) f g p) m a
guncurryReader forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) e a b.
(GFinite f, Monad m) =>
(f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
gcommute forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *} {g :: * -> *} {p} {t}.
((:*:) f g p -> t) -> f p -> g p -> t
gcurry (:*:) e1 e2 e -> Cell m a b
handler
where
gcurry :: ((:*:) f g p -> t) -> f p -> g p -> t
gcurry (:*:) f g p -> t
f f p
e1 g p
e2 = (:*:) f g p -> t
f (f p
e1 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
e2)
guncurryReader :: ReaderT (f p) (ReaderT (g p) m) a -> ReaderT ((:*:) f g p) m a
guncurryReader ReaderT (f p) (ReaderT (g p) m) a
a = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \(f p
r1 :*: g p
r2) -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (f p) (ReaderT (g p) m) a
a f p
r1) g p
r2
\end{code}