\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 x. ReaderT (Rep e Any) m x -> ReaderT e m x)
-> Cell (ReaderT (Rep e Any) m) a b -> Cell (ReaderT e m) a b
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell ((e -> Rep e Any) -> ReaderT (Rep e Any) m x -> ReaderT e m x
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT e -> Rep e Any
forall a x. Generic a => a -> Rep a x
from) (Cell (ReaderT (Rep e Any) m) a b -> Cell (ReaderT e m) a b)
-> Cell (ReaderT (Rep e Any) m) a b -> Cell (ReaderT e m) a b
forall a b. (a -> b) -> a -> b
$ (Rep e Any -> Cell m a b) -> Cell (ReaderT (Rep e Any) m) 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 ((Rep e Any -> Cell m a b) -> Cell (ReaderT (Rep e Any) m) a b)
-> (Rep e Any -> Cell m a b) -> Cell (ReaderT (Rep e Any) m) a b
forall a b. (a -> b) -> a -> b
$ e -> Cell m a b
handler (e -> Cell m a b) -> (Rep e Any -> e) -> Rep e Any -> Cell m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep e Any -> e
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 :: (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 x. ReaderT (f e) m x -> ReaderT (M1 a b f e) m x)
-> Cell (ReaderT (f e) m) a b -> Cell (ReaderT (M1 a b f e) m) a b
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell ((M1 a b f e -> f e)
-> ReaderT (f e) m x -> ReaderT (M1 a b f e) m x
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT M1 a b f e -> f e
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (Cell (ReaderT (f e) m) a b -> Cell (ReaderT (M1 a b f e) m) a b)
-> Cell (ReaderT (f e) m) a b -> Cell (ReaderT (M1 a b f e) m) a b
forall a b. (a -> b) -> a -> b
$ (f e -> Cell m a b) -> Cell (ReaderT (f e) m) 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 ((f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b)
-> (f e -> Cell m a b) -> Cell (ReaderT (f e) m) a b
forall a b. (a -> b) -> a -> b
$ M1 a b f e -> Cell m a b
handler (M1 a b f e -> Cell m a b)
-> (f e -> M1 a b f e) -> f e -> Cell m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f e -> M1 a b f e
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 :: (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 x. ReaderT e m x -> ReaderT (K1 a e e) m x)
-> Cell (ReaderT e m) a b -> Cell (ReaderT (K1 a e e) m) a b
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell ((K1 a e e -> e) -> ReaderT e m x -> ReaderT (K1 a e e) m x
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT K1 a e e -> e
forall i c k (p :: k). K1 i c p -> c
unK1) (Cell (ReaderT e m) a b -> Cell (ReaderT (K1 a e e) m) a b)
-> Cell (ReaderT e m) a b -> Cell (ReaderT (K1 a e e) m) a b
forall a b. (a -> b) -> a -> b
$ (e -> Cell m a b) -> Cell (ReaderT e m) a b
forall e (m :: * -> *) a b.
(Finite e, Monad m) =>
(e -> Cell m a b) -> Cell (ReaderT e m) a b
commute ((e -> Cell m a b) -> Cell (ReaderT e m) a b)
-> (e -> Cell m a b) -> Cell (ReaderT e m) a b
forall a b. (a -> b) -> a -> b
$ K1 a e e -> Cell m a b
handler (K1 a e e -> Cell m a b) -> (e -> K1 a e e) -> e -> Cell m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> K1 a e e
forall k i c (p :: k). c -> K1 i c p
K1

instance GFinite V1 where
  gcommute :: (V1 e -> Cell m a b) -> Cell (ReaderT (V1 e) m) a b
gcommute V1 e -> Cell m a b
_ = [Char] -> Cell (ReaderT (V1 e) m) a b
forall a. HasCallStack => [Char] -> a
error [Char]
"gcommute: Can't commute with an empty type"

instance Finite Void where
  commute :: (Void -> Cell m a b) -> Cell (ReaderT Void m) a b
commute Void -> Cell m a b
_ = [Char] -> Cell (ReaderT Void m) a b
forall a. HasCallStack => [Char] -> a
error [Char]
"Nope"

instance GFinite U1 where
  gcommute :: (U1 e -> Cell m a b) -> Cell (ReaderT (U1 e) m) a b
gcommute U1 e -> Cell m a b
handler = Cell m a b -> Cell (ReaderT (U1 e) m) a b
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell (Cell m a b -> Cell (ReaderT (U1 e) m) a b)
-> Cell m a b -> Cell (ReaderT (U1 e) m) a b
forall a b. (a -> b) -> a -> b
$ U1 e -> Cell m a b
handler U1 e
forall k (p :: k). U1 p
U1

instance Finite () where

instance Finite Bool where
  commute :: (Bool -> Cell m a b) -> Cell (ReaderT Bool m) a b
commute Bool -> Cell m a b
handler = proc a
a -> do
    Bool
bool <- ReaderT Bool m Bool -> Cell (ReaderT Bool m) () Bool
forall (m :: * -> *) b a. m b -> Cell m a b
constM ReaderT Bool m Bool
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
    if Bool
bool
    then Cell m a b -> Cell (ReaderT Bool m) a b
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell (Cell m a b -> Cell (ReaderT Bool m) a b)
-> Cell m a b -> Cell (ReaderT Bool m) a b
forall a b. (a -> b) -> a -> b
$ Bool -> Cell m a b
handler Bool
True  -< a
a
    else Cell m a b -> Cell (ReaderT Bool m) a b
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell (Cell m a b -> Cell (ReaderT Bool m) a b)
-> Cell m a b -> Cell (ReaderT Bool m) a b
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 :: ((:+:) 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  = Cell (ReaderT (eL e) m) a b -> Cell m (eL e, a) b
forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' (Cell (ReaderT (eL e) m) a b -> Cell m (eL e, a) b)
-> Cell (ReaderT (eL e) m) a b -> Cell m (eL e, a) b
forall a b. (a -> b) -> a -> b
$ (eL e -> Cell m a b) -> Cell (ReaderT (eL e) m) 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 ((eL e -> Cell m a b) -> Cell (ReaderT (eL e) m) a b)
-> (eL e -> Cell m a b) -> Cell (ReaderT (eL e) m) a b
forall a b. (a -> b) -> a -> b
$ (:+:) eL eR e -> Cell m a b
handler ((:+:) eL eR e -> Cell m a b)
-> (eL e -> (:+:) eL eR e) -> eL e -> Cell m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. eL e -> (:+:) eL eR e
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1
          cellRight :: Cell m (eR e, a) b
cellRight = Cell (ReaderT (eR e) m) a b -> Cell m (eR e, a) b
forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' (Cell (ReaderT (eR e) m) a b -> Cell m (eR e, a) b)
-> Cell (ReaderT (eR e) m) a b -> Cell m (eR e, a) b
forall a b. (a -> b) -> a -> b
$ (eR e -> Cell m a b) -> Cell (ReaderT (eR e) m) 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 ((eR e -> Cell m a b) -> Cell (ReaderT (eR e) m) a b)
-> (eR e -> Cell m a b) -> Cell (ReaderT (eR e) m) a b
forall a b. (a -> b) -> a -> b
$ (:+:) eL eR e -> Cell m a b
handler ((:+:) eL eR e -> Cell m a b)
-> (eR e -> (:+:) eL eR e) -> eR e -> Cell m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. eR e -> (:+:) eL eR e
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 = (f p, b) -> Either (f p, b) (g p, b)
forall a b. a -> Either a b
Left  (f p
eR, b
a)
          gdistribute (R1 g p
eL) b
a = (g p, b) -> Either (f p, b) (g p, b)
forall a b. b -> Either a b
Right (g p
eL, b
a)
    in
      proc a
a -> do
        (:+:) eL eR e
either12 <- ReaderT ((:+:) eL eR e) m ((:+:) eL eR e)
-> Cell (ReaderT ((:+:) eL eR e) m) () ((:+:) eL eR e)
forall (m :: * -> *) b a. m b -> Cell m a b
constM ReaderT ((:+:) eL eR e) m ((:+:) eL eR e)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
        Cell m (Either (eL e, a) (eR e, a)) b
-> Cell (ReaderT ((:+:) eL eR e) m) (Either (eL e, a) (eR e, a)) b
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 Cell m (eL e, a) b
-> Cell m (eR e, a) b -> Cell m (Either (eL e, a) (eR e, a)) b
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) -< (:+:) eL eR e -> a -> Either (eL e, a) (eR e, a)
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 :: ((:*:) 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 x.
 ReaderT (e1 e) (ReaderT (e2 e) m) x -> ReaderT ((:*:) e1 e2 e) m x)
-> Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) a b
-> Cell (ReaderT ((:*:) e1 e2 e) m) a b
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(forall x. m1 x -> m2 x) -> Cell m1 a b -> Cell m2 a b
hoistCell forall x.
ReaderT (e1 e) (ReaderT (e2 e) m) x -> ReaderT ((:*:) e1 e2 e) m x
forall (f :: * -> *) p (g :: * -> *) (m :: * -> *) a.
ReaderT (f p) (ReaderT (g p) m) a -> ReaderT ((:*:) f g p) m a
guncurryReader (Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) a b
 -> Cell (ReaderT ((:*:) e1 e2 e) m) a b)
-> Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) a b
-> Cell (ReaderT ((:*:) e1 e2 e) m) a b
forall a b. (a -> b) -> a -> b
$ (e1 e -> Cell (ReaderT (e2 e) m) a b)
-> Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) 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 ((e1 e -> Cell (ReaderT (e2 e) m) a b)
 -> Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) a b)
-> (e1 e -> Cell (ReaderT (e2 e) m) a b)
-> Cell (ReaderT (e1 e) (ReaderT (e2 e) m)) a b
forall a b. (a -> b) -> a -> b
$ (e2 e -> Cell m a b) -> Cell (ReaderT (e2 e) m) 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 ((e2 e -> Cell m a b) -> Cell (ReaderT (e2 e) m) a b)
-> (e1 e -> e2 e -> Cell m a b)
-> e1 e
-> Cell (ReaderT (e2 e) m) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((:*:) e1 e2 e -> Cell m a b) -> e1 e -> e2 e -> Cell m a b
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 f p -> g p -> (:*:) f g p
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 = ((:*:) f g p -> m a) -> ReaderT ((:*:) f g p) m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((:*:) f g p -> m a) -> ReaderT ((:*:) f g p) m a)
-> ((:*:) f g p -> m a) -> ReaderT ((:*:) f g p) m a
forall a b. (a -> b) -> a -> b
$ \(f p
r1 :*: g p
r2) -> ReaderT (g p) m a -> g p -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT (f p) (ReaderT (g p) m) a -> f p -> ReaderT (g p) m a
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}