Skip to content

Instantly share code, notes, and snippets.

@mrkgnao

mrkgnao/Eftee.hs

Last active Sep 23, 2019
Embed
What would you like to do?
An "optimized" version of ElvishJerricco's free arrow type

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?

{-# 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''
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.