An "optimized" version of ElvishJerricco's free arrow type

README.md

Today I discovered⁺ that given p :: * -> *, the following weird contraption is a Category and a Strong Traversing Profunctor with Choice (ergo, also an Arrow):

data Eftee p a b where
  Pure
    :: (a -> b)
    -> Eftee p a b
  Mash
    :: Traversable f
    => Eftee p a (f i)
    -> p i j
    -> (f j -> b)
    -> Eftee p a b

(I've reordered the arguments to be more in line with other standard approaches.)

+ (or, rather, compelled said fact into being true with ample doses of sunk-cost-style mashing of the head against a metaphorical desk (that's a sort of retroactive justification for the funky constructor name)) ↩

How I came up with this

Will Fancher's really cool post defines the following free Arrow type

type Arr p = Free (FreeTraversing p)

data Free p a b where
  Hom :: (a -> b) -> Free p a b
  Comp :: p x b -> Free p a x -> Free p a b

-- | from Data.Profunctor.Traversing
data FreeTraversing p a b where
  FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b

This is our point of departure. Inlining the definition of FreeTraversing (for which we write FT), we have

data J p a b where
  Hom :: (a -> b) -> F a b
  Comp :: (FT p) x b -> J p a x -> J p a b

and Comp is amenable to further inlining (heavy rearrangement and uncurrying included):

  (FT p) x b -> J p a x -> J p a b

~   J p a x                                        , (x -> f b) , p x' y' , (f y' -> b)
~                                          (a -> x), (x -> f b) , p x' y' , (f y' -> b)
  | J p a x', (FT p) x' x,                           (x -> f b) , p x' y' , (f y' -> b)
~                                          (a -> x), (x -> f b) , p x' y' , (f y' -> b)
  | J p a x', (x' -> f x''), p x'' y'',(f y'' -> x), (x -> f b) , p x' y' , (f y' -> b)

At this point I saw that larger "trees" had lots of successive functions which could be eliminated out altogether by composing them:

(a -> x), (x -> f b) , p x' y' , (f y' -> b) ==> (a -> f b) , p x' y' , (f y' -> b)

and I decided to see what that might do: and what it gave me was the Eftee type from above.

I had no idea if the compositions would break the properties of the type in any way. It turned out that they don't.

Comparing the two

Here are a couple of cleaned-up "syntax trees" (lists, rather)for a trivial example (at the end of the code in this gist) of type (Text,Int,Int,Int,Text) -> Text (I had no idea :force and :print existed...).

Free (FreeTraversing p):

:print concatRandoms'
concatRandoms' =
  Comp
    (FreeTraversing
       (t Text -> Text)
       ConcatS
       (b -> t (Text, Text)))
    (Comp
       (FreeTraversing
          (t Text -> b)
          ConcatS
          (b -> t (Text, Text)))
       (Comp
          (FreeTraversing
             (t Text -> b)
             ConcatS
             (b -> t (Text, Text)))
          (Comp
             (FreeTraversing (t Text -> b) RandomS (b -> t Int))
             (Comp
                (FreeTraversing
                   (t Text -> b)
                   RepeatS
                   (b -> t (Text, Int)))
                (Hom ((Text, Int, Int, Int, Text) -> b))))))

And Eftee p:

:print concatRandoms
concatRandoms =
  Mash
    (Mash
       (Mash
          (Mash
             (Mash
                (Pure ((Text, Int, Int, Int, Text) -> s (Text, Int)))
                RepeatS
                (t Text -> s Int))
             RandomS
             (t Text -> s (Text, Text)))
          ConcatS
          (t Text -> s (Text, Text)))
       ConcatS
       (t Text -> s (Text, Text)))
    ConcatS
    (s Text -> Text)

Notice all the composition that's happened, at the expense of a new Traversable type (s and t).

It seems that I've flipped the order of association in some sense (or just reordered the constructor arguments, more likely)! (I wonder if the order of the arguments affects efficiency in any way, similar to how newtyping might sometimes be better than a data declaration.)

Other approaches

I tried many other encodings, including types without the Traversable constraint in the GADT (memorably, Eftee p f a b i j) and many subsets of those variables, with an existential newtype wrapper

newtype EfteeE p a b = { unwrap :: forall f i j => Traversable f. Eftee p f a b i j }

but it turns out GHC doesn't like you trying to sneakily change f to Compose g f or anything: without this, most of the Strong etc. instances are, I suspect, impossible to write (I believe one particular case, if done without changing the functor, would imply the existence of a function Either a b -> a, which is nonsense): see below.

CPS transform

In particular, a naive CPS transform

newtype EfteeCPS p a b = EfteeCPS
  { unCPS
    :: forall r f i j
     . Traversable f
    => ((a -> b) -> r)
    -> (EfteeCPS p a (f i) -> p i j -> (f j -> b) -> r)
    -> r
  }

fairly easily gives a Profunctor instance:

instance Profunctor (EfteeCPS p) where
  dimap :: (s -> a) -> (b -> t) -> EfteeCPS p a b -> EfteeCPS p s t
  dimap f g (EfteeCPS cps) =
    EfteeCPS $ \pure mash ->
      cps
        (\k -> pure (g . k . f))
        (\next pro alg -> mash (lmap f next) pro (g . alg))

but messing with the underlying Traversable for, e.g. the Choice instance

instance Choice (EfteeCPS p) where
  right' :: EfteeCPS p a b -> EfteeCPS p (Either c a) (Either c b)
  right' cps =
    EfteeCPS $ \pure mash ->
      unCPS cps
        (pure . right')
        (\next pro alg -> mash
           (rmap Compose $ right' next) pro (B.second alg . getCompose))

does not work:

    • Couldn't match type ‘f’ with ‘Compose (Either c) g0’
      ‘f’ is a rigid type variable bound by
        a type expected by the context:
          forall r (f :: * -> *) i j.
          Traversable f =>
          ((Either c a -> Either c b) -> r)
          -> (Eftee p (Either c a) (f i)
              -> p i j -> (f j -> Either c b) -> r)
          -> r
      Expected type: Eftee p (Either c a) (f i)
        Actual type: Eftee p (Either c a) (Compose (Either c) g0 i)
    • In the first argument of ‘mash’, namely
        ‘(rmap Compose $ right' next)’
      In the expression:
        mash (rmap Compose $ right' next) pro (B.second alg . getCompose)
      In the third argument of ‘unCPS’, namely
        ‘(\ next pro alg
            -> mash
                 (rmap Compose $ right' next) pro (B.second alg . getCompose))’

Is it even supposed to? Why does the existential quantification in the GADT work, but not in the newtype? (If this is supposed to work, maybe I could use unsafeCoerce (or Coercible like profunctors does)? *shudder*)

Other ideas

Can we remove the recursion in the Mash constructor altogether?

Eftee.hs

{-# LANGUAGE Arrows                 #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE InstanceSigs           #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TupleSections          #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE TypeSynonymInstances   #-}

module Eftee where

import           Control.Arrow

import           Control.Lens.Each
import qualified Data.Bifunctor             as B
import           Data.Functor.Compose
import           Data.Functor.Classes
import           Data.Functor.Identity
import           Data.Profunctor.Traversing

import           Control.Category
import           Data.Profunctor
import           Data.Text                  (Text)
import           Prelude                    hiding (id, (.))

import qualified Data.Text                  as T
import           GHC.Exts                   (Constraint)

-- | Free (FreeTraversing p) with added cuteness
data Eftee p a b where
  Pure
    :: (a -> b)
    -> Eftee p a b
  Mash
    :: Traversable f
    => Eftee p a (f i)
    -> p i j
    -> (f j -> b)
    -> Eftee p a b

instance Profunctor (Eftee p) where
  lmap :: (a -> b) -> Eftee p b c -> Eftee p a c
  lmap f (Pure g)         = Pure (g . f)
  lmap f (Mash g pro alg) = Mash (lmap f g) pro alg

  rmap :: (c -> d) -> Eftee p b c -> Eftee p b d
  rmap f (Pure g)         = Pure (f . g)
  rmap f (Mash g pro alg) = Mash g pro (f . alg)

  dimap :: (s -> a) -> (b -> t) -> Eftee p a b -> Eftee p s t
  dimap f g (Pure p)            = Pure (g . p . f)
  dimap f g (Mash next pro alg) = Mash (lmap f next) pro (g . alg)

-- | 'Strong' ('Arrow') and 'Choice' ('ArrowChoice')
-- In both these cases, we are sneakily changing the underlying 'Traversable' from 'f' to
--   * 'Compose (Either c) f' in the `right' case
--   * 'Compose (c,) f' in the `second` case
-- This took me a lot of time to figure out, especially because of "this Skolem type variable would escape its scope" errors. Most of those happened when I tried to name intermediate values in `where` clauses like a good best practices-driven programmer. Ouch.

instance Choice (Eftee p) where
  right' :: Eftee p a b -> Eftee p (Either c a) (Either c b)
  right' (Pure f) = Pure (right' f)
  right' (Mash g pro alg) = -- teetering on the brink of Skolem hell here
    Mash (rmap Compose $ right' g) pro (B.second alg . getCompose)

instance Strong (Eftee p) where
  second' :: Eftee p a b -> Eftee p (c, a) (c, b)
  second' (Pure f) = Pure (second' f)
  second' (Mash g pro alg) =
    Mash (rmap Compose $ second' g) pro (B.second alg . getCompose)

-- | Oh, Pure-"granularity of typeclasses, heck yeah"-Script...

instance Arrow (Eftee p) where
  arr :: (a -> b) -> Eftee p a b
  arr = Pure

  first :: Eftee p a b -> Eftee p (a, c) (b, c)
  first = first'

instance ArrowChoice (Eftee p) where
  left :: Eftee p a b -> Eftee p (Either a c) (Either b c)
  left = left'

-- | I should really write 'wander'.
instance Traversing (Eftee p) where
  traverse'
    :: Traversable g
    => Eftee p a b -> Eftee p (g a) (g b)
  traverse' (Pure f) = Pure (fmap f)
  traverse' (Mash g pro alg) =
    Mash (rmap Compose $ traverse' g) pro (fmap alg . getCompose)

instance Category (Eftee p) where
  id :: Eftee p a a
  id = Pure id

  (.) :: Eftee p b c -> Eftee p a b -> Eftee p a c
  t . (Pure f) = lmap f t
  (Pure g) . t = rmap g t
  (Mash g' pro' alg') . t
    = Mash (g' . t) pro' alg'

-- | More cute, anyone?
liftee :: p a b -> Eftee p a b
liftee p = Mash (Pure Identity) p runIdentity

-- | Interprets an 'Eftee' action into profunctor actions given a
-- | natural transformation-ish thing.
-- | (It's one from p to q lifted to work on a functor category, right?)
runArr
  :: (Category q, Profunctor q)
  => (forall f x y . Traversable f => p x y -> q (f x) (f y))
  -> Eftee p a b
  -> q a b
runArr _     (Pure g)         = rmap g id
runArr morph (Mash g pro alg) = rmap alg (morph pro) . runArr morph g

-- | Interpret 'Eftee p' into a 'Kleisli' profunctor
-- | (Is there an adjunction here? Maybe even ...another monad?)
runArrK'
  :: Monad m
  => p :-> Kleisli m
  -> Eftee p :-> Kleisli m
runArrK' f = runArr (Kleisli . mapM . runKleisli . f)

-- | An unwrapped version of 'runArrK''
runArrK
  :: Monad m
  => (forall x y. p x y -> x -> m y)
  -> (forall x y. Eftee p x y -> x -> m y)
runArrK f = runKleisli . runArr (Kleisli . mapM . f)

-- | In the few instances where 'Eftee p' can be interpreted into a pure function,
-- | we can use this instead.
runArrPure
  :: (forall x y. p x y -> x -> y)
  -> (forall x y. Eftee p x y -> x -> y)
runArrPure f = runIdentity .: runArrK (Identity .: f)
  where (.:) a b = (a .) . b

-- From the blog post.
each' :: (Each s t a b, Traversing p) => p a b -> p s t
each' = wander each

-- For maximum Real Life (tm)
-- (This is definitely not related to left-pad and four-line npm packages.)
data TextServiceA a b where
  ReverseS :: TextServiceA Text Text
  LengthS  :: TextServiceA Text Int
  RandomS  :: TextServiceA Int Text
  RepeatS  :: TextServiceA (Text, Int) Text
  ConcatS  :: TextServiceA (Text, Text) Text

pureService :: TextServiceA a b -> a -> b
pureService =
  \case
    ReverseS -> T.reverse
    LengthS  -> T.length
    RandomS  -> \n -> T.replicate n "a" -- lol
    RepeatS  -> \(n, t) -> T.replicate t n
    ConcatS  -> \(x, y) -> T.concat [x, y]

type TextService = Eftee TextServiceA

-- Might want to learn TH sometime.
reverseS = liftee ReverseS
repeatS = liftee RepeatS
lengthS = liftee LengthS
concatS = liftee ConcatS
randomS = liftee RandomS

concatRandoms :: TextService (Text, Int, Int, Int, Text) Text
concatRandoms = proc (repeatPre, repLen, i,j,postfix) -> do
  pre <- repeatS -< (repeatPre, repLen)
  (r1,r2) <- each' randomS -< (i,j)
  concatted <- concatS -< (r1, r2)
  concatted' <- concatS -< (concatted, postfix)
  concatted'' <- concatS -< (pre, concatted')
  returnA -< concatted''

-- | Fancher's types

type Arr p = Free (FreeTraversing p)

data Free p a b where
  Hom :: (a -> b) -> Free p a b
  Comp :: p x b -> Free p a x -> Free p a b

liftArr :: p a b -> Arr p a b
liftArr f = Comp (FreeTraversing runIdentity f Identity) (Hom id)

runArr'
  :: (Category q, Profunctor q)
  => (forall f x y . Traversable f => p x y -> q (f x) (f y))
  -> Arr p a b
  -> q a b
runArr' _ (Hom g) = rmap g id
runArr' f (Comp (FreeTraversing unpack g pack) h) =
  dimap pack unpack (f g) . runArr' f h

type TextService' = Arr TextServiceA

-- Might want to learn TH sometime.
reverseS' = liftArr ReverseS
repeatS' = liftArr RepeatS
lengthS' = liftArr LengthS
concatS' = liftArr ConcatS
randomS' = liftArr RandomS

instance Choice p => Choice (Free p) where
  left' (Hom f) = Hom (left' f)
  left' (Comp f g) = Comp (left' f) (left' g)

instance Profunctor p => Profunctor (Free p) where
  dimap l r (Hom f) = Hom (dimap l r f)
  dimap l r (Comp f g) = Comp (rmap r f) (lmap l g)

instance Profunctor p => Category (Free p) where
  id = Hom id
  Hom g . f = rmap g f
  Comp h g . f = Comp h (g . f)

instance Strong p => Strong (Free p) where
  first' (Hom f) = Hom (first' f)
  first' (Comp f g) = Comp (first' f) (first' g)

instance Traversing p => Traversing (Free p) where
  traverse' (Hom x) = Hom (traverse' x)
  traverse' (Comp f g) = Comp (traverse' f) (traverse' g)

instance Arrow (Free (FreeTraversing p)) where
  arr = Hom
  first = first'

concatRandoms' :: TextService' (Text, Int, Int, Int, Text) Text
concatRandoms' = proc (repeatPre, repLen, i,j,postfix) -> do
  pre <- repeatS' -< (repeatPre, repLen)
  (r1,r2) <- each' randomS' -< (i,j)
  concatted <- concatS' -< (r1, r2)
  concatted' <- concatS' -< (concatted, postfix)
  concatted'' <- concatS' -< (pre, concatted')
  returnA -< concatted''