\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

-- base
import Control.Arrow
import GHC.Generics
import Data.Data
import Data.Void

-- transformers
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader

-- essence-of-live-coding
import LiveCoding.Cell
import LiveCoding.Cell.Monad.Trans
-- import LiveCoding.CellExcept

{- | A type class for datatypes on which exception handling can branch statically.

These are exactly finite algebraic datatypes,
i.e. those defined from sums and products without recursion.
If you have a datatype with a 'Data' instance,
and there is no recursion in it,
then it is probably finite.

Let us assume your data type is:

@
data Foo = Bar | Baz { baz1 :: Bool, baz2 :: Maybe () }
@

To define the instance you need to add these two lines of boilerplate
(possibly you need to import "GHC.Generics" and enable some language extensions):

@
deriving instance Generic Foo
instance Finite Foo
@

-}
\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}