IndexedLenses.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}

import Data.Kind
import Data.Coerce

-- type synonyms
--------------------------------------------------------------------------------
infixr 5 ~>
infixr 5 .~>
infixr 5 ~>.

type f ~>  g = forall i. f i -> g i  -- Natural transformation
type f .~> g = forall i. f -> g i   -- Constant on the left
type f ~>. g = forall i. f i -> g   -- Constant on the right

-- K and I
--------------------------------------------------------------------------------
newtype K a b = K a deriving
  (Eq, Show, Functor, Foldable, Traversable)

newtype I a = I a deriving
  (Eq, Show, Functor, Foldable, Traversable)

instance Applicative I where
  pure = I
  I f <*> I a = I (f a)

instance Monoid a => Applicative (K a) where
  pure _ = K mempty
  K a <*> K a' = K (mappend a a')

getK (K a) = a
getI (I a) = a

class IxFunctor (f :: (k -> *) -> (k -> *)) where
  imap :: (a ~> b) -> (f a ~> f b)

class IxFunctor t => IxTraversable t where
  -- the type would be "(a ~> (f . b)) -> (t a ~> (f . t b))" if we had the composition
  -- function on type level.
  itraverse :: Applicative f => (forall i. a i -> f (b i)) -> (forall i. t a i -> f (t b i))

class IxFoldable t where
  iFoldMap :: Monoid m => (a ~>. m) -> (t a ~>. m)

imapDefault :: IxTraversable t => (a ~> b) -> (t a ~> t b)
imapDefault f = getI . itraverse (I . f)

iFoldMapDefault :: (IxTraversable t, Monoid m) => (a ~>. m) -> (t a ~>. m)
iFoldMapDefault f = getK . itraverse (K . f)

newtype Fun a b i = Fun (a i -> b i)

class IxFunctor f => IxApplicative (f :: (k -> *) -> (k -> *)) where
  ipure :: forall a i. a i -> f a i
  iap   :: forall a b i. f (Fun a b) i -> f a i -> f b i

type IxLens s t a b =
  forall foo. Functor foo
  => (forall i. a i -> foo (b i)) -> forall i. s i -> foo (t i)  

type IxTraversal s t a b =
  forall foo. Applicative foo
  => (forall i. a i -> foo (b i)) -> forall i. s i -> foo (t i)

data Foo f = Foo (f Int) (f Bool)

deriving instance (Show (f Int), Show (f Bool)) => Show (Foo f)

fooTrav :: IxTraversal (K (Foo f)) (K (Foo g)) f g
fooTrav f (K (Foo a b)) = K <$> (Foo <$> f a <*> f b)

type Setter s t a b = (forall i. a i -> I (b i))   -> forall i. s i -> I (t i)
type Getter r s a   = (forall i. a i -> K r (a i)) -> forall i. s i -> K r (s i)
type SimpleGetter s a = forall r. Getter r s a

over :: Setter s t a b -> (a ~> b) -> (s ~> t)
over l f = getI . l (I . f)

overK :: Setter (K s) (K t) a b -> (a ~> b) -> s -> t
overK l f = getK . over l f . K

data Some f where
  Some :: f x -> Some f

view :: SimpleGetter s a -> s i -> Some a
view l = getK . l (K . Some)