Generalize cells using has-transformers

[miguel-negrao]

Attempt at #103. This is not ready for merge, it is for discussion only, for the moment.

Exceptions

Exceptions are generalized to HasExcept e m. Since there is a monad for sequencing cells with different exception types, each bind of the monad must determine the type of the exception. To help with this a new function try_ was added with the exception type specialized to (), to help Has figure out the types when we don't care about the exception type.

HandlingState

HandingStateT is generalized to (HasState (HandlingState m) t, MonadBase m t). This will work well when m has an instance MonadBase m m, as is the case with IO. If it doesn't, as is the case in some tests, then an instance has to be defined, e.g.:

instance {-# OVERLAPPING #-} MonadBase (StateT Int Identity) (StateT Int Identity) where
  liftBase = id

The difference from my IsSublayer typeclass and MonadBase is that there is always an instance Monad m => IsSublayer m m. I wonder if that approach is worth pursuing. I have the feeling though that such an instance causes problems with overlapping instances, but perhaps they can be fixed with correct use of OVERLAPPING.

Advantages

• No more need to use explicit lift when mixing cells with different monads, as long as they are compatible.

PortMidi

• I removed throwPortMidi, throwPortMidiC, liftHandlingState, since these are not needed anymore, one can just use throw, and handling directly.

[miguel-negrao]

Given that MonadBase is already being used, it seemed coherent to change uses of MonadIO to MonadBase, what do you think about that ? With that change one ends up with constraints such as (MonadBase IO m, MonadBase m t, HasState (HandlingState m) t, HasExcept EOLCPortMidiError t). So that m is a sublayer of t and IO is the base layer of m. The most obvious case is if m = IO, but other cases are possible, like StateT a IO (with an additional instance of MonadBase).

[miguel-negrao]

Another issue which arises in practice is using Cells with different exception types. I believe that using Has also makes is easier to mix Cells with different exception types. One can do the following:

mergeExceptions :: Functor m => ExceptT e1 (ExceptT e2 m) a -> ExceptT (Either e2 e1) m a
mergeExceptions em = ExceptT $ fmap mergeEithers m where
  m = runExceptT $ runExceptT em
  mergeEithers :: Either e1 (Either e2 a) -> Either (Either e1 e2) a
  mergeEithers (Left e)          = Left $ Left e
  mergeEithers (Right (Left e))  = Left $ Right e 
  mergeEithers (Right (Right a)) = Right a

cellMergeExceptions :: Monad m => Cell (ExceptT e1 (ExceptT e2 m)) a b
  -> Cell (ExceptT (Either e2 e1) m) a b
cellMergeExceptions = hoistCell mergeExceptions

t1 :: (Monad m, HasExcept Int m) => Cell m () ()
t1 = arr (const (1::Int)) >>> throwC 

t2 :: (Monad m, HasExcept () m) => Cell m () ()
t2 = arr (const ()) >>> throwC 

t3 :: (Monad m, HasExcept () m, HasExcept Int m) => Cell m () ()
t3 = t1 >>> t2

t4 :: Cell (ExceptT (Either Int ()) IO) () ()
t4 = cellMergeExceptions t3

t5 :: (Monad m, HasExcept Bool m) => Cell m () ()
t5 = arr (const True) >>> throwC 

t6 :: (Monad m, HasExcept () m, HasExcept Int m, HasExcept Bool m) => Cell m () ()
t6 = t1 >>> t2 >>> t5

t7 :: Cell (ExceptT (Either Int (Either Bool ())) IO) () ()
t7 = cellMergeExceptions $ cellMergeExceptions t6

This approach avoids having to define a data structure with a sum type of all the different exceptions.

[miguel-negrao]

Actually, one can even do better and allow throw to throw into an open sum of different exception types. In this case I'm using an open sum implementation from world-peace (that is the actual name of the package 🤷). This way we can throw different exception types and then just catch any of them without any additional code. I think I will use this approach when dealing with exceptions of different types.

To get this to work I had to define Data and Finite instances for OpenUnion xs. I don't have much experience with Data.Data, I hope I nailed the instance correctly.

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Control.Concurrent (threadDelay)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Has
import Control.Monad.Trans.Has.Except
import Control.Monad.Trans.Reader
import Data.Data
import Data.Functor.Identity (Identity (Identity))
import Data.WorldPeace.Union
import GHC.Generics
import LiveCoding

main :: IO ()
main = test6

class CanMergeExceptions m xs n where
  mergeAllExceptions :: m a -> ExceptT (OpenUnion xs) n a

instance {-# OVERLAPPING #-} (Monad m, IsMember e xs) => CanMergeExceptions (ExceptT e m) xs m where
  mergeAllExceptions :: ExceptT e m a -> ExceptT (OpenUnion xs) m a
  mergeAllExceptions me = ExceptT $ do
    e <- runExceptT me
    return $ case e of
      Left e' -> Left $ openUnionLift e'
      Right a -> Right a

instance
  {-# OVERLAPPABLE #-}
  (Functor n, IsMember e xs, CanMergeExceptions m xs n) =>
  CanMergeExceptions (ExceptT e m) xs n
  where
  mergeAllExceptions :: ExceptT e m a -> ExceptT (OpenUnion xs) n a
  mergeAllExceptions me = ExceptT $ fmap mergeEithers m'
    where
      m = runExceptT me
      m' = runExceptT $ mergeAllExceptions @m m
      mergeEithers :: Either (OpenUnion xs) (Either e a) -> Either (OpenUnion xs) a
      mergeEithers (Left e) = Left e
      mergeEithers (Right (Left e)) = Left $ openUnionLift e
      mergeEithers (Right (Right a)) = Right a

instance (Monad m, IsMember e xs) => Has (ExceptT e) (ExceptT (OpenUnion xs) m) where
  liftH :: forall a. (forall (n :: * -> *). Monad n => ExceptT e n a) -> ExceptT (OpenUnion xs) m a
  liftH me = mergeAllExceptions (liftH me :: ExceptT e m a)

test1 :: ExceptT Int (ExceptT Bool (ExceptT () IO)) ()
test1 = throw (1 :: Int) >> throw True >> throw ()

test2 :: ExceptT (OpenUnion '[Int, Bool, ()]) IO ()
test2 = mergeAllExceptions test1

test3 :: ExceptT (OpenUnion '[Int, Bool, ()]) IO ()
test3 = throw (1 :: Int) >> throw True >> throw ()

loopPrintExceptions ::
  (Data e, Finite e, MonadIO m, Show e) =>
  Cell (ExceptT e m) a b ->
  Cell m a b
loopPrintExceptions cell = foreverC $
  runCellExcept $ do
    e <- try cell
    once_ $
      liftIO $ do
        putStrLn "Encountered exception:"
        print e
        threadDelay 1000000
    return e

tUnion :: DataType
tUnion = mkDataType "Union" [cThis, cThat]

cThis :: Constr
cThis = mkConstr tUnion "This" [] Data.Data.Prefix

cThat :: Constr
cThat = mkConstr tUnion "That" [] Data.Data.Prefix

instance
  (Typeable a, Data a) =>
  Data.Data.Data
    (Data.WorldPeace.Union.OpenUnion '[a])
  where
  gfoldl k_a5JZ z_a5K0 (Data.WorldPeace.Union.This a1_a5K1) =
    z_a5K0 Data.WorldPeace.Union.This `k_a5JZ` a1_a5K1
  gunfold k_a5K5 z_a5K6 c_a5K7 =
    case Data.Data.constrIndex c_a5K7 of
      1 -> k_a5K5 (z_a5K6 Data.WorldPeace.Union.This)
      _ -> error "gfoldl OpenUnion can't be a That"
  toConstr (Data.WorldPeace.Union.This _) = cThis
  dataTypeOf _ = tUnion

deriving instance {-# OVERLAPPABLE #-} (Data x, Data (Union Identity xs), Typeable xs) => Data (Union Identity (x ': xs))

instance (Finite e) => Finite (OpenUnion '[e]) where
  commute handler = hoistCell (withReaderT (\(This (Identity x)) -> x)) $ commute $ handler . This . Identity

instance Finite e => Finite (Identity e)
instance {-# OVERLAPPABLE #-} (Finite e, Finite (OpenUnion es)) => Finite (OpenUnion (e ': es)) where
  commute handler =
    let 
        cellLeft = runReaderC' $ commute $ handler . This
        cellRight = runReaderC' $ commute $ handler . That
        distribute :: OpenUnion (e : es) -> a -> Either (Identity e, a) (OpenUnion es, a)
        distribute (This eR) a = Left (eR, a)
        distribute (That eL) a = Right (eL, a)
     in proc a -> do
          x <- constM ask -< ()
          liftCell (cellLeft ||| cellRight) -< distribute x a

data MyA = A1 | A2 | A3 deriving (Data, Generic, Finite, Show)

data MyB = B1 | B2 | B3 deriving (Data, Generic, Finite, Show)

data MyC = C1 | C2 | C3 deriving (Data, Generic, Finite, Show)

-- The goal of all that is above is to allow calling throwC below without any additional lifts or merge functions
test4 :: Cell (ExceptT (OpenUnion '[MyA, MyB, MyC]) IO) Int ()
test4 = proc n -> do
  case n of
    1 -> throwC -< A1
    2 -> throwC -< B2
    _ -> throwC -< C3

test5 :: Cell IO Int ()
test5 = loopPrintExceptions test4

test6 :: IO ()
test6 = void $ fst <$> steps test5 [10]

{-- 
Encountered exception:
Identity C3
Encountered exception:
Identity C3
--}

[turion]

Scanning through the changes I don't get the feeling that the code becomes easier. Especially the parts with MonadBase seem to make everything slightly more complicated. 🤔

[miguel-negrao]

With this change the library code has more general types, which are a bit more complicated, granted. I think user code would become simpler with less, or no use of lift, but with the requirement that some types cannot be inferred, so that some type signatures are needed where before they weren't needed. Perhaps I should provide some user code examples with the current approach vs this approach.

[miguel-negrao]

I've created two repositories with two concrete examples of using eolc from a user standpoint with and without using Has.

Without Has. Repo here.

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}

module Main where

import Control.Monad.Trans.Reader
import LiveCoding
import LiveCoding.PortMidi
import LiveCoding.Vivid
import Vivid

main :: IO ()
main = putStrLn "hello"

sineDef :: SDBody' '["freq", "gate", "fadeSecs"] [Signal]
sineDef = do
  s <- sinOsc (freq_ (V :: V "freq"))
  s' <- envGate ~* s ~* 0.1
  out 0 [s', s']

sineCell ::
  Cell
    (HandlingStateT IO)
    Float
    ()
sineCell = proc frequency -> do
  liveSynth
    -<
      ( (realToFrac frequency :: I "freq", 1 :: I "gate", 2 :: I "fadeSecs"),
        sineDef,
        Started
      )
  returnA -< ()

portMidiCell1 :: Cell (HandlingStateT IO) () ()
portMidiCell1 = loopPortMidiC $ proc () -> do
  readEventsC "name" -< ()
  liftHandlingState sineCell -< 440  -- <-------------------------

portMidiCell2 :: Cell (HandlingStateT IO) () ()
portMidiCell2 = loopPortMidiC $
  foreverE True $ proc () -> do
    b <- arrM (const ask) -< ()
    if b
      then liftCell $ liftCell $ readEventsC "name" -< () -- <-------------------------
      else returnA -< []
    liftCell $ liftCell $ liftHandlingState sineCell -< 440 -- <-------------------------
    liftCell throwC -< False -- <-------------------------
    returnA -< ()

With Has. Repo here

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Control.Monad.Trans.Has.Reader
import LiveCoding
import LiveCoding.HandlingState
import LiveCoding.PortMidi
import LiveCoding.Vivid
import Vivid hiding (sync)

main :: IO ()
main = putStrLn "hello"

sineDef :: SDBody' '["freq", "gate", "fadeSecs"] [Signal]
sineDef = do
  s <- sinOsc (freq_ (V :: V "freq"))
  s' <- envGate ~* s ~* 0.1
  out 0 [s', s']

sineCell :: (VividAction m, HasHandlingState m t) => Cell t Float ()
sineCell = proc frequency -> do
  liveSynth
    -<
      ( (realToFrac frequency :: I "freq", 1 :: I "gate", 2 :: I "fadeSecs"),
        sineDef,
        Started
      )
  returnA -< ()

portMidiCell1 :: Cell (HandlingStateT IO) () ()
portMidiCell1 = loopPortMidiC $ proc () -> do
  readEventsC "name" -< ()
  sineCell -< 440 -- this would require liftHandlingState

portMidiCell2 :: Cell (HandlingStateT IO) () ()
portMidiCell2 = loopPortMidiC $
  foreverE True $ proc () -> do
    b <- arrM (const ask) -< ()
    if b
      then readEventsC "name" -< () -- this would require liftCell $ liftCell
      else returnA -< []
    sineCell -< 440 -- this would require liftCell $ liftCell $  liftHandlingState
    throwC -< False -- this would require liftCell
    returnA -< ()

In this particular case no additional type annotations were required and I think the user code becomes quite a bit simpler, without all the noise of the lifts. The type in portMidiCell2 is Cell (ReaderT Bool (ExceptT Bool (PortMidiT IO))) () () which has already quite a number of layers, there is one ReaderT, two ExceptTs and one StateT. Hopefully this gives a better perspective of the change from a user view point.