Constructing compositional self-referential lenses in Haskell

Question

It's not that uncommon to have data with self-references in it. This comes up in imperative programming for sure, but it also can show up in Haskell. For example, one can have IORefs or STRefs as fields in a data type that point to the data type itself (and one can use RecursiveDo syntax or mfix to "tie the knot" on construction).

I was wondering if it is possible to do something similar using lenses.

Say I have some state of type s and a lens from s to some data contained in that state.  I'd like that contained data to itself have access to this lens, or in other words, I want the data within the state to be something like:

import Data.Lens

data Foo s = Foo
  { self :: Lens' s (Foo s)
  , fooData :: Int
  }

-- A silly `Show` instance so that we can print a few things
instance Show (Foo s) where
  show Foo{..} = "Foo <lens> "<>show fooData

This is a little challenging to use, but it can be made to work with a Fix type like:

newtype Fix f = Fix { unFix :: f (Fix f) }

fixIso :: Iso' (Fix f) (f (Fix f))
fixIso = iso unFix Fix

Now, I can make the following value:

myFoo :: Foo (Fix Foo)
myFoo = Foo fixIso 2

Here, we have a value of type Foo (Fix Foo) with a lens from its state to itself.

I can also create a pair of Foos (by using :*: from Generics):

import GHC.Generics ((:*:)(..))

pairOfFoo :: (Foo :*: Foo) (Fix (Foo :*: Foo))
pairOfFoo = Foo (fixIso . _1) 2 :*: Foo (fixIso . _2) 4

This basically works, as in:

> pairOfFoo ^. _1
Foo <lens> 2
> pairOfFoo ^. _2
Foo <lens> 4
> Fix pairOfFoo ^. (self $ pairOfFoo ^. _1)
Foo <lens> 2

The bigger issue is that it feels like I should be able to create pairOfFoo compositionally from myFoo, but I don't see how to do it.  That is, I want to write something like:

pairOf :: (Extendable x, Extendable y) => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf x y = extend x _1 :*: extend y _2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)

class Extendable x where
  extend :: Lens' s' s -> x (Fix s) -> x (Fix s')

But this is where I'm stuck.  I don't know how to make an instance Extendable Foo (or even if that's the right signature).  I also think there should be an instance for (Extendable x, Extendable y) => Extendable (x :*: y) (or similar). Or, maybe there's another strategy altogether?

---

Problem Extension

Now, let's say we have a second data type defined as such:

data Bar s = Bar
  { barSelf :: Lens' s (Bar s)
  , barFoo  :: Lens' s (Foo s)
  , barData :: String
  }

It's impossible to have a value of type Bar (Fix Bar) because Bar does not actually contain a Foo. But, it's possible to make something like:

fooBar :: (Foo :*: Bar) (Fix (Foo :*: Bar))
fooBar = Foo (fixIso . _1) 2 :*: Bar (fixIso . _2) (fixIso . _1) "bar"

Additionally, it feels like it should be possible to have an instance Extendable Bar, so that we can use fooBar as an argument in pairOf. Is this instance possible?

Answer 1

I guess maybe you want:

class Extendable a where
  extend :: Lens' (s' (Fix s')) (a (Fix s')) -> a (Fix s) -> a (Fix s')
instance Extendable Foo where
  extend l (Foo self x) = Foo (fixIso . l) x

pairOf :: (Extendable x, Extendable y)
  => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf foo1 foo2 = extend _1 foo1 :*: extend _2 foo2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)

It seems to work, and extends to more complicated compositions:

instance (Extendable x, Extendable y) => Extendable (x :*: y) where
  extend l (x :*: y) = extend (l . _1) x :*: extend (l . _2) y

example2 = pairOf (pairOf (Foo fixIso 2) (Foo fixIso 3)) (Foo fixIso 4)

Full code:

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

import GHC.Generics ((:*:)(..))
import Control.Lens

data Foo s = Foo
  { self :: Lens' s (Foo s)
  , fooData :: Int
  }

instance Show (Foo s) where
  show Foo{..} = "Foo <lens> " <> show fooData

newtype Fix f = Fix { unFix :: f (Fix f) }

fixIso :: Iso' (Fix f) (f (Fix f))
fixIso = iso unFix Fix

class Extendable a where
  extend :: Lens' (s' (Fix s')) (a (Fix s')) -> a (Fix s) -> a (Fix s')
instance Extendable Foo where
  extend l (Foo self x) = Foo (fixIso . l) x
instance (Extendable x, Extendable y) => Extendable (x :*: y) where
  extend l (x :*: y) = extend (l . _1) x :*: extend (l . _2) y

pairOf :: (Extendable x, Extendable y)
  => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf foo1 foo2 = extend _1 foo1 :*: extend _2 foo2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)
example2 = pairOf (pairOf (Foo fixIso 2) (Foo fixIso 3)) (Foo fixIso 4)