From 850dcf615b3c0a453e17bddf37dd7e59d70b7e58 Mon Sep 17 00:00:00 2001
From: Profpatsch <mail@profpatsch.de>
Date: Sun, 8 Aug 2021 18:25:16 +0200
Subject: feat(users/Profpatsch/lens): lens library for nix

Profunctor lenses for nix.

Implemented Profunctor and Strong instances for `(->)`,
and some simple setters.
Next step would be getters, which will need the `Forget` profunctor.

Fairly straightforward implementation of
https://github.com/purescript-contrib/purescript-profunctor-lenses
(with all the types erased and instance dicts passed manually).

```
> :p set (optic [_2 (field "foo") _1]) 42 (tuple 1 { foo = (tuple 1 2); })
{ fst = 1; snd = { foo = { fst = 42; snd = 2; }; }; }
```

Change-Id: Iad145523d1c035187b8b2db9302b840c282d427a
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3295
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
---
 users/Profpatsch/lens.nix | 131 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 131 insertions(+)
 create mode 100644 users/Profpatsch/lens.nix

diff --git a/users/Profpatsch/lens.nix b/users/Profpatsch/lens.nix
new file mode 100644
index 000000000000..3c429bbdb14e
--- /dev/null
+++ b/users/Profpatsch/lens.nix
@@ -0,0 +1,131 @@
+{ ... }:
+let
+  id = x: x;
+
+  const = x: y: x;
+
+  comp = f: g: x: f (g x);
+
+  # Profunctor (p :: Type -> Type -> Type)
+  Profunctor = rec {
+    # dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
+    dimap = f: g: x: lmap f (rmap g x);
+    # lmap :: (a -> b) -> p b c -> p a c
+    lmap = f: dimap f id;
+    # rmap :: (c -> d) -> p b c -> p b d
+    rmap = g: dimap id g;
+  };
+
+  # Profunctor (->)
+  profunctorFun = Profunctor // {
+    # dimap :: (a -> b) -> (c -> d) -> (b -> c) -> a -> d
+    dimap = ab: cd: bc: a: cd (bc (ab a));
+    # lmap :: (a -> b) -> (b -> c) -> (a -> c)
+    lmap = ab: bc: a: bc (ab a);
+    # rmap :: (c -> d) -> (b -> c) -> (b -> d)
+    rmap = cd: bc: b: cd (bc b);
+  };
+
+  tuple = fst: snd: {
+    inherit fst snd;
+  };
+
+  swap = {fst, snd}: {
+    fst = snd;
+    snd = fst;
+  };
+
+  # Profunctor p => Strong (p :: Type -> Type -> Type)
+  Strong = pro: pro // rec {
+    # firstP :: p a b -> p (a, c) (b, c)
+    firstP = pab: pro.dimap swap swap (pro.secondP pab);
+    # secondP :: p a b -> p (c, a) (c, b)
+    secondP = pab: pro.dimap swap swap (pro.firstP pab);
+  };
+
+  # Strong (->)
+  strongFun = Strong profunctorFun // {
+    # firstP :: (a -> b) -> (a, c) -> (b, c)
+    firstP = f: { fst, snd }: { fst = f fst; inherit snd; };
+    # secondP :: (a -> b) -> (c, a) -> (c, b)
+    secondP = f: { snd, fst }: { snd = f snd; inherit fst; };
+  };
+
+  # Iso s t a b :: forall p. Profunctor p -> p a b -> p s t
+
+  # iso :: (s -> a) -> (b -> t) -> Iso s t a b
+  iso = pro: pro.dimap;
+
+  # Lens s t a b :: forall p. Strong p -> p a b -> p s t
+
+  # lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+  lens = strong: get: set: pab:
+    lensP
+      strong
+      (s: tuple (get s) (b: set s b))
+      pab;
+
+  # lensP :: (s -> (a, b -> t)) -> Lens s t a b
+  lensP = strong: to: pab:
+    strong.dimap
+      to
+      ({fst,snd}: snd fst)
+      (strong.firstP pab);
+
+  # first element of a tuple
+  # _1 :: Lens (a, c) (b, c) a b
+  _1 = strong: strong.firstP;
+
+  # second element of a tuple
+  # _2 :: Lens (c, a) (c, b) a b
+  _2 = strong: strong.secondP;
+
+  # a the given field in the record
+  # field :: (f :: String) -> Lens { f :: a; ... } { f :: b; ... } a b
+  field = name: strong:
+    lens
+      strong
+      (attrs: attrs.${name})
+      (attrs: a: attrs // { ${name} = a; });
+
+  # Setter :: (->) a b -> (->) s t
+
+  # Subclasses of profunctor for (->).
+  # We only have Strong for now, but when we implement Choice we need to add it here.
+  profunctorSubclassesFun = strongFun;
+
+  # over :: Setter s t a b -> (a -> b) -> s -> t
+  over = setter:
+    # A setter needs to be instanced to the profunctor-subclass instances of (->).
+    (setter profunctorSubclassesFun);
+
+  # set :: Setter s t a b -> b -> s -> t
+  set = setter: b: over setter (const b);
+
+  # combine a bunch of optics, for the subclass instance of profunctor you give it.
+  optic = accessors: profunctorSubclass:
+    builtins.foldl' comp id
+      (map (accessor: accessor profunctorSubclass) accessors);
+
+
+in {
+  inherit
+    id
+    const
+    comp
+    Profunctor
+    profunctorFun
+    Strong
+    strongFun
+    iso
+    lens
+    optic
+    _1
+    _2
+    field
+    tuple
+    swap
+    over
+    set
+    ;
+}
-- 
cgit 1.4.1