CarrierTest.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module CarrierTest where

import Data.Profunctor
import Data.Profunctor.Composition
import Data.Profunctor.Strong

-- This is isomorphic to Pastro (Exchange a a)
data Carrier a x y where
  Carrier :: (x -> (a, z)) -> ((a, z) -> y) -> Carrier a x y

comult :: Carrier a x y -> Procompose (Carrier a) (Carrier a) x y
comult (Carrier f g)
  = Procompose (Carrier id g) (Carrier f id)

counit :: Carrier a x y -> (x -> y)
counit (Carrier f g) = g . f

type Lens' s a = forall x y. Carrier s x y -> Carrier a x y

get :: Lens' s a -> s -> a
get l = case l (Carrier (\s -> (s, ())) (const ())) of
          Carrier f g -> fst . f

put :: Lens' s a -> s -> a -> s
put l s a = case l (Carrier (\s -> (s, ())) fst) of
              Carrier f g -> g $ (\(_, z) -> (a, z)) $ (f s)

_1 :: Lens' (a, b) a
_1 (Carrier f g) = Carrier (assoc . f) (g . unassoc)
  where assoc   ((x, y), z) = (x, (y, z))
        unassoc (x, (y, z)) = ((x, y), z)