A bad implementation of Control.Arrow in Nix

arrow.nix

let
  inherit (builtins)
    add
    div
    elemAt
    isFunction
    length
    mul
    sub
    throw
    toJSON
    ;

  # id :: a -> a
  id = x: x;

  # NOTE: This is left-to-right composition, not (.), which is right-to-left.
  # compose :: (a -> b) -> (b -> c) -> a -> c
  compose =
    f: g: x:
    g (f x);

  # flip :: (a -> b -> c) -> b -> a -> c
  flip =
    f: x: y:
    f y x;

  # flipApp :: a -> (a -> b) -> b
  flipApp = flip id;

  # Data.Pair
  # Church encoding of pairs.
  # They are encoded by their catamorphism.
  # Most of the functions operating on pairs then *use* that catamorphism to produce their result.
  # Type of a pair is `(a -> b -> c) -> c`, a binary function which is provided the components of the pair
  # and produces some result.
  P = {
    # _fst :: a -> b -> a
    _fst = x: _: x;

    # _snd :: a -> b -> b
    _snd = _: y: y;

    # _dup :: a -> (a -> a -> b) -> b
    _dup = x: f: f x x;

    # pair :: a -> b -> (a -> b -> c) -> c
    pair =
      x: y: p:
      p x y;

    # fst :: ((a -> b -> c) -> c) -> a
    fst = flipApp P._fst;

    # snd :: ((a -> b -> c) -> c) -> b
    snd = flipApp P._snd;

    # swap :: ((a -> b -> c) -> c) -> (b -> a -> c) -> c
    swap = flipApp (flip P.pair);

    # dup :: a -> (a -> a -> c) -> c
    dup = x: (P._dup x) P.pair;

    # curry :: ((a -> b -> c) -> c) -> a -> b -> c
    curry =
      f: x: y:
      f (P.pair x y);

    # uncurry :: (a -> b -> c) -> (a -> b -> c) -> c
    uncurry = flipApp;

    # fromList :: [ a, b ] -> (a -> b -> c) -> c
    fromList =
      xs:
      if length xs == 2 then
        P.pair (elemAt xs 0) (elemAt xs 1)
      else
        throw "cannot turn list of length ${toJSON (length xs)} into a pair";

    # toList :: ((a -> b -> c) -> c) -> [ a, b ]
    toList = flipApp (
      x: y: [
        x
        y
      ]
    );
  };

  A = {
    # In Haskell, higher precedence value means more tightly binding operator.
    # In Nix, higher precedence value means *less* tightly binding operator.
    # https://stackoverflow.com/questions/73937521/whats-infix-in-haskell
    # https://nix.dev/manual/nix/2.32/language/operators.html
    # https://hackage.haskell.org/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Control.Category.html#Category
    # https://nix.dev/manual/nix/2.32/language/operators.html

    # In Haskell, function composition with (.) has precedence 9, the highest precedence.
    # In Nix, attribute selection (.) has precedence 1, the highest precedence.

    # Category:
    # https://hackage.haskell.org/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Control.Category.html
    # infixr 9 .
    # infixr 1 >>>, <<<
    # We use (-) for >>> for left-to-right composition.

    # Arrow:
    # https://hackage.haskell.org/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Control.Arrow.html
    # infixr 3 ***
    # infixr 3 &&&

    # Name                      Syntax           Associativity  Precedence
    # Multiplication            number * number  left           6
    # Division                  number / number  left           6
    # Subtraction               number - number  left           7
    # ...
    # Less than                 expr < expr      none           10
    # Less than or equal to     expr <= expr     none           10
    # Greater than              expr > expr      none           10
    # Greater than or equal to  expr >= expr     none           10

    # Since we're interested in only Arrow, which has associative composition, that's not a problem for us.
    # However, it is a problem for the parser: since > and < aren't associative in Nix, we can't chain them.

    # -- | Split the input between the two argument arrows and combine
    # --   their output.  Note that this is in general not a functor.
    # --
    # --   The default definition may be overridden with a more efficient
    # --   version if desired.
    # --
    # -- >   b ╭─────╮ b'
    # -- > >───┼─ f ─┼───>
    # -- > >───┼─ g ─┼───>
    # -- >   c ╰─────╯ c'
    # (***) :: a b c -> a b' c' -> a (b,b') (c,c')
    # f *** g = first f >>> arr swap >>> first g >>> arr swap
    #   where swap ~(x,y) = (y,x)

    "***" = f: g: P.uncurry (x: (y: (P.pair (f x) (g y))));

    # TODO: Do we keep paying for attribute set lookup? Do we need to do a let-in?
    # (*) as in "product" or "both"
    __mul = f: if isFunction f then A."***" f else mul f;

    # -- | Fanout: send the input to both argument arrows and combine
    # --   their output.
    # --
    # --   The default definition may be overridden with a more efficient
    # --   version if desired.
    # --
    # -- >     ╭───────╮ c
    # -- >   b │ ┌─ f ─┼───>
    # -- > >───┼─┤     │
    # -- >     │ └─ g ─┼───>
    # -- >     ╰───────╯ c'
    # (&&&) :: a b c -> a b c' -> a b (c,c')
    # f &&& g = arr (\b -> (b,b)) >>> f *** g
    "&&&" =
      f: g: x:
      P.pair (f x) (g x);

    # div, as in split.
    __div = f: if isFunction f then A."&&&" f else div f;

    # -- | Send the first component of the input through the argument
    # --   arrow, and copy the rest unchanged to the output.
    # --
    # --   The default definition may be overridden with a more efficient
    # --   version if desired.
    # --
    # -- >   b ╭─────╮ c
    # -- > >───┼─ f ─┼───>
    # -- > >───┼─────┼───>
    # -- >   d ╰─────╯ d
    # first :: a b c -> a (b,d) (c,d)
    # first = (*** id)
    first = flip A."***" id;

    # -- | Send the second component of the input through the argument
    # --   arrow, and copy the rest unchanged to the output.
    # --
    # --   The default definition may be overridden with a more efficient
    # --   version if desired.
    # --
    # -- >   d ╭─────╮ d
    # -- > >───┼─────┼───>
    # -- > >───┼─ f ─┼───>
    # -- >   b ╰─────╯ c
    # second :: a b c -> a (d,b) (d,c)
    # second = (id ***)
    second = A."***" id;

    # (-) because it looks like a chain, as in "chaining" function
    __sub = f: if isFunction f then compose f else sub f;
  };

  addOne = add 1;
  timesTwo = mul 2;

  l34 = [
    3
    4
  ];
  l54 = [
    5
    4
  ];

  p34 = P.pair 3 4;
  p54 = P.pair 5 4;

  expect =
    expected: actual:
    if expected != actual then
      throw "expected value ${toJSON expected} does not match actual value ${toJSON actual}"
    else
      actual;
in
{
  # Needs to be here for the REPL.
  inherit (A) __mul __div __sub;
  inherit
    l34
    l54
    p34
    p54
    ;
  inherit addOne timesTwo;
  inherit P;
  inherit expect;

  examples =
    let
      # Needs to be here for examples.
      inherit (A) __mul __div __sub;
    in
    {
      l34Pair = expect [ 3 4 ] ((P.fromList - P.toList) l34);
      l54Pair = expect [ 5 4 ] ((P.fromList - P.toList) l54);

      p34List = expect [ 3 4 ] (P.toList p34);
      p54List = expect [ 5 4 ] (P.toList p54);

      fstP34 = expect 3 (P.fst p34);
      sndP34 = expect 4 (P.snd p34);

      fstP54 = expect 5 (P.fst p54);
      sndP54 = expect 4 (P.snd p54);

      swap34 = expect [ 4 3 ] ((P.swap - P.toList) p34);
      swapswap34 = expect [ 3 4 ] ((P.swap - P.swap - P.toList) p34);

      ex1 = expect 8 ((addOne - timesTwo) 3);
      ex2 = expect 10 ((addOne - addOne - timesTwo) 3);
      ex3 = expect [ 4 4 ] ((P.dup - P.toList) 4);
      ex4a = expect [ 5 5 ] ((P.dup - (addOne * addOne) - P.toList) 4);
      ex4b = expect [ 5 5 ] (((addOne / addOne) - P.toList) 4);
      ex5a = expect [ 5 8 ] ((P.dup - (addOne * timesTwo) - P.toList) 4);
      ex5b = expect [ 5 8 ] (((addOne / timesTwo) - P.toList) 4);
      ex6a = expect [ 8 5 ] ((P.dup - (timesTwo * addOne) - P.toList) 4);
      ex6b = expect [ 8 5 ] (((timesTwo / addOne) - P.toList) 4);
      ex7a = expect [ 8 8 ] ((P.dup - (timesTwo * timesTwo) - P.toList) 4);
      ex7b = expect [ 8 8 ] (((timesTwo / timesTwo) - P.toList) 4);
      ex8a = expect 8 ((P.dup - (timesTwo * addOne) - P.fst) 4);
      ex8b = expect 8 (((timesTwo / addOne) - P.fst) 4);
      ex9a = expect 5 ((P.dup - (timesTwo * addOne) - P.snd) 4);
      ex9b = expect 5 (((timesTwo / addOne) - P.snd) 4);

      # curry
      ex10 = expect 10 ((P.uncurry (x: y: (x + 1) * y)) (P.pair 1 5));
      ex11 = expect 10 ((P.curry (p: (P.fst p + 1) * P.snd p)) 1 5);
      ex12 = expect 10 ((P.curry (flipApp (x: y: (x + 1) * y))) 1 5);

      # first
      ex13 = expect [ 4 4 ] (((A.first addOne) - P.toList) p34);
    };
}