A DRY idiom with monadic profunctors

P.hs

{-# LANGUAGE RankNTypes, QuantifiedConstraints, PolyKinds, TypeFamilies #-}

module P where

import Data.Kind (Type)

bar :: forall g. Reflective g => g String Int Int
bar = undefined

baz :: forall g. Reflective g => Int -> g String Int Int
baz = undefined

-- Normal foo
foo :: forall g. Reflective g => g String (Int, Int) (Int, Int)
foo = do
  x <- bar `at` _1
  y <- baz x `at` _2
  return (x, y)

-- DRY foo
-- Use identity prism idP because output is already a tuple
-- In general, if you want to construct (g String s s) for some ADT s,
-- you would use a prism Prism' s (x1,...,xn) instead of idP
foo' :: forall g. Reflective g => g String (Int, Int) (Int, Int)
foo' = idP `biap` (
  bar >>=+ \x ->
  baz x >>=+ \y ->
  done)  -- No need to tuple x and y together
         -- biap takes care of both construction and destruction with the prism.

-- Implementation (on top of the profunctor monad framework, stubbed below)

idP :: Prism' a a
idP = undefined

-- Turn tuples into a uniform representation
class Tuple t where
  type Untuple t :: Type
  toTuple :: Untuple t -> t
  fromTuple :: t -> Untuple t

instance Tuple (a,b) where
  type Untuple (a,b) = (a,(b,()))
  toTuple (a,(b,())) = (a,b)
  fromTuple (a,b) = (a,(b,()))
-- Derive this up to big enough tuples

-- Secret sauce: biap, (>>=+), done

biap :: (Tuple t, ProfMonad p) => Prism' s t -> Join p (Untuple t) -> p s s
biap prism
  = comap (fmap fromTuple . preview prism)
  . fmap (review prism . toTuple)
  . unJoin

newtype Join p t = Join { unJoin :: p t t }

(>>=+) :: ProfMonad p => p a a -> (a -> Join p b) -> Join p (a,b)
u >>=+ k = Join (do
  a <- comap (Just . fst) u
  b <- comap (Just . snd) (unJoin (k a))
  pure (a, b))

done :: ProfMonad p => Join p ()
done = Join (pure ())

-- Stubs

data Prism' s a

preview :: Prism' s a -> s -> Maybe a
preview = undefined

review :: Prism' s a -> a -> s
review = undefined

data Getter_ s a

class ({- Profunctor p, -} forall a. Monad (p a)) => ProfMonad p where
  comap :: (a -> Maybe a') -> p a' b -> p a b

class (forall x. ProfMonad (g x)) => Reflective g where
  -- ...

at :: ProfMonad p => p u' v -> Getter_ u u' -> p u v
at x y = undefined -- (comap . preview) y x

_1 :: Getter_ (a, b) a
_2 :: Getter_ (a, b) b

_1 = undefined
_2 = undefined