Coproduct Lenses

Main.purs

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Free.Trans
import Control.Monad.Rec.Class
import Control.Monad.Trans.Class
import Data.Const
import Data.Either
import Data.Functor.Coproduct
import Data.String
    
-- Functor coproducts make the functor category into a symmetric monoidal category.
-- We can use this to form a type of optic which allows us to focus on a part
-- of a coproduct.

-- Just like in Edward Kmett's Monad Transformer Lenses talk, we proceed by forming
-- a class for strong profunctors on that category:

class FunctorProfunctor p where
  fdimap :: forall a b c d. Functor a => Functor b => Functor c => Functor d => (a ~> b) -> (c ~> d) -> p b c -> p a d
    
class FunctorProfunctor p <= FunctorStrong p where
  fleft :: forall a b c. Functor a => Functor b => Functor c => p a b -> p (Coproduct a c) (Coproduct b c)
  
swapCoproduct :: forall a b. Coproduct a b ~> Coproduct b a
swapCoproduct (Coproduct x) = Coproduct case x of
  Left x -> Right x
  Right x -> Left x

fright :: forall p a b c. FunctorStrong p => Functor a => Functor b => Functor c => p a b -> p (Coproduct c a) (Coproduct c b)
fright = fdimap swapCoproduct swapCoproduct <<< fleft

-- Our lenses are then just profunctor homomorphisms.
-- fleft and fright are the prototypical examples.
type CoproLens s t a b = forall p. FunctorStrong p => p a b -> p s t

-- One useful thing we can do with such a "coproduct lens" is to
-- switch out part of a free monad which is built out of a coproduct.
interpretOf 
  :: forall s t a b m
   . Functor a
  => Functor b
  => MonadRec m
  => CoproLens s t a b
  -> (a ~> b) 
  -> FreeT s m ~> FreeT t m
interpretOf l = runInterpret (l (Interpret interpret))

-- Another useful function, which interprets some part of a free monad
-- on a coproduct in the underlying monad.
-- Each time we interpret a summand, we replace it with (Const Void).
-- When we're done, the only effects left will be from the base monad.
runOf 
  :: forall s t a m
   . Functor a
  => MonadRec m
  => CoproLens s t a (Const Void)
  -> (a ~> m) 
  -> FreeT s m ~> FreeT t m
runOf l = runRun (l (Run (\x -> (_ >>> lift) (runFreeT x))))

----- Example -----

-- Here's the standard teletype example. 
-- We're going to split the read and write effects into different functors
-- and form the free monad on their coproduct.
-- We can then interpret the different effects individually.

data Write a = Write String a
derive instance functorWrite :: Functor Write

data Read a = Read (String -> a)
derive instance functorRead :: Functor Read

type TeletypeT = FreeT (Coproduct Write Read)

example :: TeletypeT (Eff (console :: CONSOLE)) Unit
example = do
  s <- liftFreeT (right (Read id))
  liftFreeT (left (Write s unit))

-- We can also modify part of the structure, for example by uppercasing all
-- strings written to the console.
shout :: forall m. MonadRec m => TeletypeT m ~> TeletypeT m
shout = interpretOf fleft (\(Write s a) -> Write (toUpper s) a)

-- Notice that if we forget to handle a particular effect, we get a type error.
-- This is reminiscent of Gabriel Gonzalez' totality checking using prisms,
-- only "one level up" in the functor category.
main :: Eff (console :: CONSOLE) Unit
main = 
  example
    # runOf fleft (\(Write s a) -> log s $> a)
    # runOf fright (\(Read f) -> pure (f "dummy input"))
    # runFreeT flatten

----- Implementation -----

to 
  :: forall f g m a
   . Functor f
  => Functor g
  => MonadRec m
  => FreeT f (FreeT g m) a
  -> FreeT (Coproduct f g) m a
to x = lift ((resume <<< resume) x) >>=
    case _ of
      Left (Left a) -> pure a
      Left (Right x) -> interpret left (liftFreeT x) >>= foo
      Right x -> interpret right (liftFreeT x) >>= bar
  where
    foo :: FreeT f (FreeT g m) a -> FreeT (Coproduct f g) m a
    foo x = interpret right (resume x) >>= either pure baz
    
    bar :: FreeT g m (Either a (f (FreeT f (FreeT g m) a))) -> FreeT (Coproduct f g) m a
    bar x = interpret right x >>= either pure baz
    
    baz :: f (FreeT f (FreeT g m) a) -> FreeT (Coproduct f g) m a
    baz x = interpret left (liftFreeT x) >>= to
    
from
  :: forall f g m a
   . Functor f
  => Functor g
  => Monad m
  => MonadRec m
  => FreeT (Coproduct f g) m a
  -> FreeT f (FreeT g m) a
from x = lift (lift (resume x)) >>=
  case _ of
    Left a -> pure a
    Right (Coproduct (Left x)) -> liftFreeT x >>= from
    Right (Coproduct (Right x)) -> lift (liftFreeT x) >>= from

data Interpret a b s t = Interpret (forall m. MonadRec m => (a ~> b) -> FreeT s m ~> FreeT t m)
runInterpret (Interpret x) = x

instance functorProfunctorInterpret :: FunctorProfunctor (Interpret a b) where
  fdimap f g (Interpret s) = Interpret \x -> interpret g <<< s x <<< interpret f

instance functorStrongInterpret :: FunctorStrong (Interpret a b) where
  fleft (Interpret s) = Interpret \f -> to <<< s f <<< from
  
data Run a s t = Run (forall m. MonadRec m => (a ~> m) -> FreeT s m ~> FreeT t m)
runRun (Run x) = x

instance functorProfunctorRun :: FunctorProfunctor (Run a) where
  fdimap f g (Run s) = Run \x -> interpret g <<< s x <<< interpret f

instance functorStrongRun :: FunctorStrong (Run a) where
  fleft (Run s) = Run \f -> to <<< s (lift <<< f) <<< from
  
class Flatten f where
  flatten :: forall m. Monad m => f ~> m
  
instance flattenCoproduct :: (Flatten f, Flatten g) => Flatten (Coproduct f g) where
  flatten = coproduct flatten flatten
  
instance flattenConst :: Flatten (Const Void) where
  flatten (Const v) = absurd v