Reflecting Classes and Instances

Most of the implications we use on a day to day basis come from our class and instance declarations, but last time we only really dealt with constraint products.

For example given:

 
#if 0
class Eq a => Ord a
instance Eq a => Eq [a]
#endif
 

we could provide the following witnesses

 
ordEq :: Ord a :- Eq a
ordEq = Sub Dict
 
eqList :: Eq a :- Eq [a]
eqList = Sub Dict
 

But this would require a lot of names and become remarkably tedious.

So lets define classes to reflect the entailment provided by class definitions and instance declarations and then use them to reflect themselves.

 
class Class b h | h -> b where
  cls :: h :- b
 
infixr 9 :=>
class b :=> h | h -> b where
  ins :: b :- h
 
instance Class () (Class b a) where cls = Sub Dict
instance Class () (b :=> a) where cls = Sub Dict
 

Now we can reflect classes and instances as instances of Class and (:=>) respectively with:

 
-- class Eq a => Ord a where ...
instance Class (Eq a) (Ord a) where cls = Sub Dict
-- instance Eq a => Eq [a] where ...
instance Eq a :=> Eq [a] where ins = Sub Dict
 

That said, instances of Class and Instance should never require a context themselves, because the modules that the class and instance declarations live in can't taken one, so we can define the following instances which bootstrap the instances of (:=>) for Class and (:=>) once and for all.

 
#ifdef UNDECIDABLE
instance Class b a => () :=> Class b a where ins = Sub Dict
instance (b :=> a) => () :=> b :=> a where ins = Sub Dict
#endif
 

These two instances are both decidable, and following a recent bug fix, the current version of GHC HEAD supports them, but my local version isn't that recent, hence the #ifdef.

We can also give admissable-if-not-ever-stated instances of Class and (:=>) for () as well.

 
instance Class () () where cls = Sub Dict
instance () :=> () where ins = Sub Dict
 

Reflecting the Prelude

So now that we've written a handful of instances, lets take the plunge and just reflect the entire Prelude, and (most of) the instances for the other modules we've loaded.

 
instance Class () (Eq a) where cls = Sub Dict
instance () :=> Eq () where ins = Sub Dict
instance () :=> Eq Int where ins = Sub Dict
instance () :=> Eq Bool where ins = Sub Dict
instance () :=> Eq Integer where ins = Sub Dict
instance () :=> Eq Float where ins = Sub Dict
instance () :=> Eq Double where ins = Sub Dict
instance Eq a :=> Eq [a] where ins = Sub Dict
instance Eq a :=> Eq (Maybe a) where ins = Sub Dict
instance Eq a :=> Eq (Complex a) where ins = Sub Dict
instance Eq a :=> Eq (Ratio a) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict
instance () :=> Eq (Dict a) where ins = Sub Dict
instance () :=> Eq (a :- b) where ins = Sub Dict
 

 
instance Class (Eq a) (Ord a) where cls = Sub Dict
instance () :=> Ord () where ins = Sub Dict
instance () :=> Ord Bool where ins = Sub Dict
instance () :=> Ord Int where ins = Sub Dict
instance ():=> Ord Integer where ins = Sub Dict
instance () :=> Ord Float where ins = Sub Dict
instance ():=> Ord Double where ins = Sub Dict
instance () :=> Ord Char where ins = Sub Dict
instance Ord a :=> Ord (Maybe a) where ins = Sub Dict
instance Ord a :=> Ord [a] where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict
instance Integral a :=> Ord (Ratio a) where ins = Sub Dict
instance () :=> Ord (Dict a) where ins = Sub Dict
instance () :=> Ord (a :- b) where ins = Sub Dict
 

 
instance Class () (Show a) where cls = Sub Dict
instance () :=> Show () where ins = Sub Dict
instance () :=> Show Bool where ins = Sub Dict
instance () :=> Show Ordering where ins = Sub Dict
instance () :=> Show Char where ins = Sub Dict
instance Show a :=> Show (Complex a) where ins = Sub Dict
instance Show a :=> Show [a] where ins = Sub Dict
instance Show a :=> Show (Maybe a) where ins = Sub Dict
instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict
instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict
instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict
instance () :=> Show (Dict a) where ins = Sub Dict
instance () :=> Show (a :- b) where ins = Sub Dict
 

 
instance Class () (Read a) where cls = Sub Dict
instance () :=> Read () where ins = Sub Dict
instance () :=> Read Bool where ins = Sub Dict
instance () :=> Read Ordering where ins = Sub Dict
instance () :=> Read Char where ins = Sub Dict
instance Read a :=> Read (Complex a) where ins = Sub Dict
instance Read a :=> Read [a] where ins = Sub Dict
instance Read a :=> Read (Maybe a) where ins = Sub Dict
instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict
instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict
instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict
 

 
instance Class () (Enum a) where cls = Sub Dict
instance () :=> Enum () where ins = Sub Dict
instance () :=> Enum Bool where ins = Sub Dict
instance () :=> Enum Ordering where ins = Sub Dict
instance () :=> Enum Char where ins = Sub Dict
instance () :=> Enum Int where ins = Sub Dict
instance () :=> Enum Integer where ins = Sub Dict
instance () :=> Enum Float where ins = Sub Dict
instance () :=> Enum Double where ins = Sub Dict
instance Integral a :=> Enum (Ratio a) where ins = Sub Dict
 

 
instance Class () (Bounded a) where cls = Sub Dict
instance () :=> Bounded () where ins = Sub Dict
instance () :=> Bounded Ordering where ins = Sub Dict
instance () :=> Bounded Bool where ins = Sub Dict
instance () :=> Bounded Int where ins = Sub Dict
instance () :=> Bounded Char where ins = Sub Dict
instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict
 

 
instance Class () (Num a) where cls = Sub Dict
instance () :=> Num Int where ins = Sub Dict
instance () :=> Num Integer where ins = Sub Dict
instance () :=> Num Float where ins = Sub Dict
instance () :=> Num Double where ins = Sub Dict
instance RealFloat a :=> Num (Complex a) where ins = Sub Dict
instance Integral a :=> Num (Ratio a) where ins = Sub Dict
 

 
instance Class (Num a, Ord a) (Real a) where cls = Sub Dict
instance () :=> Real Int where ins = Sub Dict
instance () :=> Real Integer where ins = Sub Dict
instance () :=> Real Float where ins = Sub Dict
instance () :=> Real Double where ins = Sub Dict
instance Integral a :=> Real (Ratio a) where ins = Sub Dict
 

 
instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict
instance () :=> Integral Int where ins = Sub Dict
instance () :=> Integral Integer where ins = Sub Dict
 

 
instance Class (Num a) (Fractional a) where cls = Sub Dict
instance () :=> Fractional Float where ins = Sub Dict
instance () :=> Fractional Double where ins = Sub Dict
instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict
instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict
 

 
instance Class (Fractional a) (Floating a) where cls = Sub Dict
instance () :=> Floating Float where ins = Sub Dict
instance () :=> Floating Double where ins = Sub Dict
instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict
 

 
instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict
instance () :=> RealFrac Float where ins = Sub Dict
instance () :=> RealFrac Double where ins = Sub Dict
instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict
 

 
instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict
instance () :=> RealFloat Float where ins = Sub Dict
instance () :=> RealFloat Double where ins = Sub Dict
 

 
instance Class () (Monoid a) where cls = Sub Dict
instance () :=> Monoid () where ins = Sub Dict
instance () :=> Monoid Ordering where ins = Sub Dict
instance () :=> Monoid [a] where ins = Sub Dict
instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict
instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict
 

 
instance Class () (Functor f) where cls = Sub Dict
instance () :=> Functor [] where ins = Sub Dict
instance () :=> Functor Maybe where ins = Sub Dict
instance () :=> Functor (Either a) where ins = Sub Dict
instance () :=> Functor ((->) a) where ins = Sub Dict
instance () :=> Functor ((,) a) where ins = Sub Dict
instance () :=> Functor IO where ins = Sub Dict
 

 
instance Class (Functor f) (Applicative f) where cls = Sub Dict
instance () :=> Applicative [] where ins = Sub Dict
instance () :=> Applicative Maybe where ins = Sub Dict
instance () :=> Applicative (Either a) where ins = Sub Dict
instance () :=> Applicative ((->)a) where ins = Sub Dict
instance () :=> Applicative IO where ins = Sub Dict
instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict
 

 
instance Class (Applicative f) (Alternative f) where cls = Sub Dict
instance () :=> Alternative [] where ins = Sub Dict
instance () :=> Alternative Maybe where ins = Sub Dict
 

 
instance Class () (Monad f) where cls = Sub Dict
instance () :=> Monad [] where ins = Sub Dict
instance () :=> Monad ((->) a) where ins = Sub Dict
instance () :=> Monad (Either a) where ins = Sub Dict
instance () :=> Monad IO where ins = Sub Dict
 

 
instance Class (Monad f) (MonadPlus f) where cls = Sub Dict
instance () :=> MonadPlus [] where ins = Sub Dict
instance () :=> MonadPlus Maybe where ins = Sub Dict
 

Of course, the structure of these definitions is extremely formulaic, so when template-haskell builds against HEAD again, they should be able to be generated automatically using splicing and reify, which would reduce this from a wall of text to a handful of lines with better coverage!

An alternative using Default Signatures and Type Families

Many of the above definitions could have been streamlined by using default definitions. However, MPTCs do not currently support default signatures. We can however, define Class and (:=>) using type families rather than functional dependencies. This enables us to use defaulting, whenever the superclass or context was ().

 
#if 0
class Class h where
  type Sup h :: Constraint
  type Sup h = ()
  cls :: h :- Sup h
  default cls :: h :- ()
  cls = Sub Dict
 
class Instance h where
  type Ctx h :: Constraint
  type Ctx h = ()
  ins :: Ctx h :- h
  default ins :: h => Ctx h :- h
  ins = Sub Dict
 
instance Class (Class a)
instance Class (Instance a)
 
#ifdef UNDECIDABLE
instance Class a => Instance (Class a)
instance Instance a => Instance (Instance a)
#endif
 
instance Class ()
instance Instance ()
#endif
 

This seems at first to be a promising approach. Many instances are quite small:

 
#if 0
instance Class (Eq a)
instance Instance (Eq ())
instance Instance (Eq Int)
instance Instance (Eq Bool)
instance Instance (Eq Integer)
instance Instance (Eq Float)
instance Instance (Eq Double)
#endif
 

But those that aren't are considerably more verbose and are much harder to read off than the definitions using the MPTC based Class and (:=>).

 
#if 0
instance Instance (Eq [a]) where
  type Ctx (Eq [a]) = Eq a
  ins = Sub Dict
instance Instance (Eq (Maybe a)) where
  type Ctx (Eq (Maybe a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (Complex a)) where
  type Ctx (Eq (Complex a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (Ratio a)) where
  type Ctx (Eq (Ratio a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (a, b)) where
  type Ctx (Eq (a,b)) = (Eq a, Eq b)
  ins = Sub Dict
instance Instance (Eq (Either a b)) where
  type Ctx (Eq (Either a b)) = (Eq a, Eq b)
  ins = Sub Dict
#endif
 

Having tested both approaches, the type family approach led to a ~10% larger file size, and was harder to read, so I remained with MPTCs even though it meant repeating "where ins = Sub Dict" over and over.

In a perfect world, we'd gain the ability to use default signatures with multiparameter type classes, and the result would be considerably shorter and easier to read!

Fake Superclasses

Now, that we have all this machinery, it'd be nice to get something useful out of it. Even if we could derive it by other means, it'd let us know we weren't completely wasting our time.

Let's define a rather horrid helper, which we'll only use where a and b are the same constraint being applied to a newtype wrapper of the same type, so we can rely on the fact that the dictionaries have the same representation.

 
evil :: a :- b
evil = unsafeCoerce refl
 

We often bemoan the fact that we can't use Applicative sugar given just a Monad, since Applicative wasn't made a superclass of Monad due to the inability of the Haskell 98 report to foresee the future invention of Applicative.

There are rather verbose options to get Applicative sugar for your Monad, or to pass it to something that expects an Applicative. For instance you can use WrappedMonad from Applicative. We reflect the relevant instance here.

 
instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict
 

Using that instance and the combinators defined previously, we can obtain the following

 
applicative :: forall m a. Monad m => (Applicative m => m a) -> m a
applicative m =
  m \\ trans (evil :: Applicative (WrappedMonad m) :- Applicative m) ins
 

Here ins is instantiated to the instance of (:=>) above, so we use trans to compose ins :: Monad m :- Applicative (WrappedMonad m) with evil :: Applicative (WrappedMonad m) :- Applicative m to obtain an entailment of type Monad m :- Applicative m in local scope, and then apply that transformation to discharge the Applicative obligation on m.

Now, we can use this to write definitions. [Note: Frustratingly, my blog software inserts spaces after <'s in code]

 
(< &>) :: Monad m => m a -> m b -> m (a, b)
m < &> n = applicative $ (,) < $> m < *> n
 

Which compares rather favorably to the more correct

 
(< &>) :: Monad m => m a -> m b -> m (a, b)
m < &> n = unwrapMonad $ (,) < $> WrapMonad m < *> WrapMonad n
 

especially considering you still have access to any other instances on m you might want to bring into scope without having to use deriving to lift them onto the newtype!

Similarly you can borrow < |> and empty locally for use by your MonadPlus with:

 
instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict
 
alternative :: forall m a. MonadPlus m => (Alternative m => m a) -> m a
alternative m =
  m \\ trans (evil :: Alternative (WrappedMonad m) :- Alternative m) ins
 

The correctness of this of course relies upon the convention that any Applicative and Alternative your Monad may have should agree with its Monad instance, so even if you use Alternative or Applicative in a context where the actual Applicative or Alternative instance for your particular type m is in scope, it shouldn't matter beyond a little bit of efficiency which instance the compiler picks to discharge the Applicative or Alternative obligation.

Note: It isn't that the Constraint kind is invalid, but rather that using unsafeCoerce judiciously we can bring into scope instances that don't exist for a given type by substituting those from a different type which have the right representation.

[Source]

Constraint Kinds adds a new kind Constraint, such that Eq :: * -> Constraint, Monad :: (* -> *) -> Constraint, but since it is a kind, we can make type families for constraints, and even parameterize constraints on constraints.

So, let's play with them and see what we can come up with!

A Few Extensions

First, we'll need a few language features:

 
{-# LANGUAGE
  CPP,
  ScopedTypeVariables,
  FlexibleInstances,
  FlexibleContexts,
  ConstraintKinds,
  KindSignatures,
  TypeOperators,
  FunctionalDependencies,
  Rank2Types,
  StandaloneDeriving,
  GADTs
  #-}
 

Because of the particular version of GHC I'm using I'll also need

 
{-# LANGUAGE UndecidableInstances #-}
#define UNDECIDABLE
 

but this bug has been fixed in the current version of GHC Head. I'll be explicit about any instances that need UndecidableInstances by surrounding them in an #ifdef UNDECIDABLE block.

Explicit Dictionaries

So with that out of the way, let's import some definitions

 
import Control.Monad
import Control.Monad.Instances
import Control.Applicative
import Data.Monoid
import Data.Complex
import Data.Ratio
import Unsafe.Coerce
 

and make one of our own that shows what we get out of making Constraints into a kind we can manipulate like any other.

 
data Dict a where
  Dict :: a => Dict a
 

Previously, we coud make a Dict like data type for any one particular class constraint that we wanted to capture, but now we can write this type once and for all. The act of pattern matching on the Dict constructor will bring the constraint 'a' into scope.

Of course, in the absence of incoherent and overlapping instances there is at most one dictionary of a given type, so we could make instances, like we can for any other data type, but standalone deriving is smart enough to figure these out for me. (Thanks copumpkin!)

 
deriving instance Eq (Dict a)
deriving instance Ord (Dict a)
deriving instance Show (Dict a)
 

If we're willing to turn on UndecidableInstances to enable the polymorphic constraint we can even add:

 
#ifdef UNDECIDABLE
deriving instance a => Read (Dict a)
instance a => Monoid (Dict a) where
  mappend Dict Dict = Dict
  mempty = Dict
#endif
 

and similar polymorphically constrained instances for Enum, Bounded, etc.

Entailment

For that we'll need a notion of entailment.

 
infixr 9 :-
newtype a :- b = Sub (a => Dict b)
 
instance Eq (a :- b) where
  _ == _ = True
 
instance Ord (a :- b) where
  compare _ _ = EQ
 
instance Show (a :- b) where
  showsPrec d _ = showParen (d > 10) $
    showString "Sub Dict"
 

Here we're saying that Sub takes one argument, which is a computation that when implicitly given a constraint of type a, can give me back a dictionary for the type b. Moreover, as a newtype it adds no overhead that isn't aleady present in manipulating terms of type (a => Dict b) directly.

The simplest thing we can define with this is that entailment is reflexive.

 
refl :: a :- a
refl = Sub Dict
 

Max has already written up a nice restricted monad example using these, but what I want to play with today is the category of substitutability of constraints, but there are a few observations I need to make, first.

ConstraintKinds overloads () and (a,b) to represent the trivial constraint and the product of two constraints respectively.

The latter is done with a bit of a hack, which we'll talk about in a minute, but we can use the former as a terminal object for our category of entailments.

 
weaken1 :: (a, b) :- a
weaken1 = Sub Dict
 
weaken2 :: (a, b) :- b
weaken2 = Sub Dict
 

Constraints are idempotent, so we can duplicate one, perhaps as a prelude to transforming one of them into something else.

 
contract :: a :- (a, a)
contract = Sub Dict
 

But to do much more complicated, we're going to need a notion of substitution, letting us use our entailment relation to satisfy obligations.

 
infixl 1 \\ -- required comment
(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r
 

The type says that given that a constraint a can be satisfied, a computation that needs a constraint of type b to be satisfied in order to obtain a result, and the fact that a entails b, we can compute the result.

The constraint a is satisfied by the type signature, and the fact that we get quietly passed whatever dictionary is needed. Pattern matching on Sub brings into scope a computation of type (a => Dict b), and we are able to discharge the a obligation, using the dictionary we were passed, Pattern matching on Dict forces that computation to happen and brings b into scope, allowing us to meet the obligation of the computation of r. All of this happens for us behind the scenes just by pattern matching.

So what can we do with this?

We can use \\ to compose constraints.

 
trans :: (b :- c) -> (a :- b) -> a :- c
trans f g = Sub $ Dict \\ f \\ g
 

In fact, the way the dictionaries get plumbed around inside the argument to Sub is rather nice, because we can give that same definition different type signatures, letting us make (,) more product-like, giving us the canonical product morphism to go with the weakenings/projections we defined above.

 
(&&&) :: (a :- b) -> (a :- c) -> a :- (b, c)
f &&& g = Sub $ Dict \\ f \\ g
 

And since we're using it as a product, we can make it act like a bifunctor also using the same definition.

 
(***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d)
f *** g = Sub $ Dict \\ f \\ g
 

Limited Sub-Superkinding?

Ideally we'd be able to capture something like that bifunctoriality using a type like

 
#if 0
class BifunctorS (p :: Constraint -> Constraint -> Constraint) where
  bimapS :: (a :- b) -> (c :- d) -> p a c :- p b d
#endif
 

In an even more ideal world, it would be enriched using something like

 
#ifdef POLYMORPHIC_KINDS
class Category (k :: x -> x -> *) where
  id :: k a a
  (.) :: k b c -> k a b -> k a c
instance Category (:-) where
  id = refl
  (.) = trans
#endif
 

where x is a kind variable, then we could obtain a more baroque and admittedly far less thought-out bifunctor class like:

 
#if 0
class Bifunctor (p :: x -> y -> z) where
  type Left p :: x -> x -> *
  type Left p = (->)
  type Right p :: y -> y -> *
  type Right p = (->)
  type Cod p :: z -> z -> *
  type Cod p = (->)
  bimap :: Left p a b -> Right p c d -> Cod p (p a c) (p b d)
#endif
 

Or even more more ideally, you could use the fact that we can directly define product categories!

Since they are talking about kind-indexing for classes and type families, we could have separate bifunctors for (,) for both kinds * and Constraint.

The current constraint kind code uses a hack to let (a,b) be used as a type inhabiting * and as the syntax for constraints. This hack is limited however. It only works when the type (,) is fully applied to its arguments. Otherwise you'd wind up with the fact that the type (,) needs to have both of these kinds:

 
-- (,) :: Constraint -> Constraint -> Constraint and
-- (,) :: * -> * -> *
 

What is currently done is that the kind magically switches for () and (,) in certain circumstances. GHC already had some support for this because it parses (Foo a, Bar b) as a type in (Foo a, Bar b) => Baz a b before transforming it into a bunch of constraints.

Since we already have a notion of sub-kinding at the kind level, we could solve this for () by making up a new kind, say, ??? which is the subkind of both * and Constraint, but this would break the nice join lattice properties of the current system.

[Edit: in the initial draft, I had said superkind]

 
--    ?
--   / \
-- (#)  ??
--     /  \
--    #    *  Constraint
--          \ /
--          ???
 

But this doesn't address the kind of (,) above. With the new polymorphic kinds that Brent Yorgey and company have been working on and a limited notion of sub-superkinding, this could be resolved by making a new super-kind @ that is the super-kind of both * and Constraint, and which is a sub-superkind of the usual unnamed Box superkind.

 
-- Box
--  |
--  @
 

Then we can have:

 
-- (,) :: forall (k :: @). k -> k -> k
-- () :: forall (k :: @). k
 

and kind checking/inference will do the right thing about keeping the kind ambiguous for types like (,) () :: forall (k :: @). k

This would get rid of the hack and let me make a proper bifunctor for (,) in the category of entailments.

The version of GHC head I'm working with right now doesn't support polymorphic kinds, so I've only been playing with these in a toy type checker, but I'm really looking forward to being able to have product categories!

Stay Tuned

Next, we'll go over how to reflect the class and instance declarations so we can derive entailment of a superclass for a class, and the entailment of instances.

[Source]

This time I intend to implement packrat directly on top of Parsec 3.

One of the main topics of discussion when it comes to packrat parsing since Bryan Ford's initial release of Pappy has been the fact that in general you shouldn't use packrat to memoize every rule, and that instead you should apply Amdahl's law to look for the cases where the lookup time is paid back in terms of repetitive evaluation, computation time and the hit rate. This is great news for us, since, we only want to memoize a handful of expensive combinators.

First, we'll need to import enough of Parsec to do something interesting.

 
{-# LANGUAGE RecordWildCards, ViewPatterns, FlexibleInstances, MultiParamTypeClasses #-}
 
import Text.Parsec
import qualified Text.Parsec.Token as T
import Text.Parsec.Token
    (GenLanguageDef(..), GenTokenParser(TokenParser))
import Text.Parsec.Pos (initialPos, updatePosChar)
import Data.Functor.Identity (Identity(..))
import Control.Applicative hiding ((< |>))
import Control.Monad.Fix (fix)
 

Then as before, we'll define PEG-style backtracking:

 
(< />) :: Monad m => ParsecT s u m a -> ParsecT s u m a ->
    ParsecT s u m a
p < /> q = try p < |> q
infixl 3 < />
 

Now we need an analogue to our Result type from last time, which recalled whether or not we had consumed input, and what the current cursor location is. Fortunately, we can recycle the definitions from Parsec to this end.

 
type Result d a = Consumed (Reply d () a)
 

We'll define a combinator to build a parser directly from a field accessor. Last time, this was just the use of the "Rat" constructor. Now it is a bit trickier, because we need to turn Consumed (Reply d () a) into m (Consumed (m (Reply d u a))) by wrapping it in the appropriate monad, and giving the user back his state unmolested.

 
rat :: Monad m => (d -> Result d a) -> ParsecT d u m a
rat f   = mkPT $ \s0 -> return $
    return . patch s0 < $> f (stateInput s0) where
  patch (State _ _ u) (Ok a (State s p _) err) = Ok a (State s p u) err
  patch _             (Error e)                = Error e
 

Last time we could go from a parser to a result just by applying the user stream type, but with parsec we also have to supply their notion of a position. This leads to the following combinator. By running in the Identity monad with no user state it should be obvious that we've duplicated the functionality of the previous 'Rat' parser (with the addition of a source position).

 
womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a
womp d pos p = fmap runIdentity . runIdentity $
    runParsecT p (State d pos ())
 

The combinator is so named because we needed a big space-rat rather than a little pack-rat to keep with the theme.

It's not impossible. I used to bullseye womp rats in my T-16 back home, they're not much bigger than two meters.

Now we'll write a bit of annoyingly verbose boilerplate to convince Parsec that we really want a LanguageDef for some monad other than Identity. (As an aside, why Text.Parsec.Language doesn't contain GenLanguageDefs that are parametric in their choice of Monad is beyond me.)

 
myLanguageDef :: Monad m => T.GenLanguageDef D u m
myLanguageDef = T.LanguageDef
  { commentStart    = "{-"
  , commentEnd      = "-}"
  , commentLine     = "--"
  , nestedComments  = True
  , identStart      = letter < |> char '_'
  , identLetter     = alphaNum < |> oneOf "_'"
  , opStart         = opLetter myLanguageDef
  , opLetter        = oneOf ":!#$%&*+./< =>?@\\^|-~"
  , reservedOpNames = []
  , reservedNames   = []
  , caseSensitive   = True
  }
 

As a shameless plug, trifecta offers a particularly nice solution to this problem, breaking up the monolithic Token type into separate concerns and letting you layer parser transformers that enrich the parser to deal with things like Haskell-style layout, literate comments, parsing comments in whitespace, etc.

And as one last bit of boilerplate, we'll abuse RecordWildcards once again to avoid the usual 20 lines of boilerplate that are expected of us, so we can get access to parsec's token parsers.

 
TokenParser {..} = T.makeTokenParser myLanguageDef
 

Now we're ready to define our incredibly straightforward stream type:

 
data D = D
  { _add        :: Result D Integer
  , _mult       :: Result D Integer
  , _primary    :: Result D Integer
  , _dec        :: Result D Integer
  , _uncons     :: Maybe (Char, D)
  }
 
instance Monad m => Stream D m Char where
  uncons = return . _uncons
 

And using the general purpose rat combinator from earlier, we can write some memoized parsers:

 
add, mult, primary, dec :: Parsec D u Integer
add     = rat _add
mult    = rat _mult
primary = rat _primary
dec     = rat _dec
 

And finally, we write the code to tie the knot and build the stream:

 
parse :: SourceName -> String -> D
parse n = go (initialPos n) where
  go p s = fix $ \d -> let
    (womp d p -> _add) =
            (+) < $> mult < * reservedOp "+" <*> add
        < /> mult < ?> "summand"
    (womp d p -> _mult) =
            (*) < $> primary < * reservedOp "*" <*> mult
        < /> primary < ?> "factor"
    (womp d p -> _primary) =
            parens add
        < /> dec < ?> "number"
    (womp d p -> _dec) = natural
    _uncons = case s of
      (x:xs) -> Just (x, go (updatePosChar p x) xs)
      []     -> Nothing
    in D { .. }
 
runD :: Parsec D u a -> u -> SourceName -> String -> Either ParseError a
runD p u fn s = runParser p u fn (prep fn s)
 

and finally, let it rip:

 
eval :: String -> Integer
eval s = either (error . show) id $
    runD (whiteSpace *> add < * eof) () "-" s
 

While this approach tends to encourage memoizing fewer combinators than libraries such as frisby, this is exactly what current research suggests you probably should do with packrat parsing!

The other purported advantage of packrat parsers is that they can deal with left recursion in the grammar. However, that is not the case, hidden left recursion in the presence of the algorithm used in the scala parsing combinator libraries leads to incorrect non-left-most parses as shown by Tratt.

I leave it as an exercise for the reader to extend this material with the parsec+iteratees approach from my original talk on trifecta to get packrat parsing of streaming input. Either that or you can wait until it is integrated into trifecta.

You can download the source to this (without the spurious spaces inserted by wordpress) here.

If I can find the time, I hope to spend some time addressing Scott and Johnstone's GLL parsers, which actually achieve the O(n^3) worst case bounds touted for Tomita's GLR algorithm (which is actually O(n^4) as it was originally defined despite the author's claims), and how to encode them in Haskell with an eye towards building a memoizing parser combinator library that can parse LL(1) fragments in O(1), deal with arbitrary context-free grammars in O(n^3), and degrade reasonably gracefully in the presence of context-sensitivity, while supporting hidden left recursion as long as such recursion passes through at least one memoized rule. This is important because CFGs are closed under extensions to the grammar, which is a nice property to have if you want to have a language where you can add new statement types easily without concerning yourself overmuch with the order in which you insert the rules or load the different extensions.

You never heard of the Millenium Falcon? It's the ship that made the Kessel Run in 12 parsecs.

I've been working on a parser combinator library called trifecta, and so I decided I'd share some thoughts on parsing.

Packrat parsing (as provided by frisby, pappy, rats! and the Scala parsing combinators) and more traditional recursive descent parsers (like Parsec) are often held up as somehow different.

Today I'll show that you can add monadic parsing to a packrat parser, sacrificing asymptotic guarantees in exchange for the convenient context sensitivity, and conversely how you can easily add packrat parsing to a traditional monadic parser combinator library.

To keep this post self-contained, I'm going to start by defining a small packrat parsing library by hand, which acts rather like parsec in its backtracking behavior. First, some imports:

 
{-# LANGUAGE RecordWildCards, ViewPatterns, DeriveFunctor #-}
import Control.Applicative
import Control.Monad (MonadPlus(..), guard)
import Control.Monad.Fix (fix)
import Data.Char (isDigit, digitToInt, isSpace)
 

Second, we'll define a bog simple parser, which consumes an input stream of type d, yielding a possible answer and telling us whether or not it has actually consumed any input as it went.

 
newtype Rat d a = Rat { runRat :: d -> Result d a }
  deriving Functor
 
data Result d a
  = Pure a             -- didn't consume anything, can backtrack
  | Commit d a      -- consumed input
  | Fail String Bool -- failed, flagged if consumed
  deriving Functor
 

Now, we can finally implement some type classes:

 
instance Applicative (Rat d) where
  pure a = Rat $ \ _ -> Pure a
  Rat mf < *> Rat ma = Rat $ \ d -> case mf d of
    Pure f      -> fmap f (ma d)
    Fail s c    -> Fail s c
    Commit d' f -> case ma d' of
      Pure a       -> Commit d' (f a)
      Fail s _     -> Fail s True
      Commit d'' a -> Commit d'' (f a)
 

including an instance of Alternative that behaves like parsec, only backtracking on failure if no input was unconsumed.

 
instance Alternative (Rat d) where
  Rat ma < |> Rat mb = Rat $ \ d -> case ma d of
    Fail _ False -> mb d
    x            -> x
  empty = Rat $ \ _ -> Fail "empty" False
 

For those willing to forego the asymptotic guarantees of packrat, we'll offer a monad.

 
instance Monad (Rat d) where
  return a = Rat $ \_ -> Pure a
  Rat m >>= k = Rat $ \d -> case m d of
    Pure a -> runRat (k a) d
    Commit d' a -> case runRat (k a) d' of
      Pure b -> Commit d' b
      Fail s _ -> Fail s True
      commit -> commit
    Fail s c -> Fail s c
  fail s = Rat $ \ _ -> Fail s False
 
instance MonadPlus (Rat d) where
  mplus = (< |>)
  mzero = empty
 

and a Parsec-style "try", which rewinds on failure, so that < |> can try again.

 
try :: Rat d a -> Rat d a
try (Rat m) = Rat $ \d -> case m d of
  Fail s _ -> Fail s False
  x        -> x
 

Since we've consumed < |> with parsec semantics. Let's give a PEG-style backtracking (< />).

 
(< />) :: Rat d a -> Rat d a -> Rat d a
p < /> q = try p < |> q
infixl 3 < />
 

So far nothing we have done involves packrat at all. These are all general purpose recursive descent combinators.

We can define an input stream and a number of combinators to read input.

 
class Stream d where
  anyChar :: Rat d Char
 
whiteSpace :: Stream d => Rat d ()
whiteSpace = () < $ many (satisfy isSpace)
phrase :: Stream d => Rat d a -> Rat d a
phrase m = whiteSpace *> m < * eof
 
notFollowedBy :: Rat d a -> Rat d ()
notFollowedBy (Rat m) = Rat $ \d -> case m d of
  Fail{} -> Pure ()
  _      -> Fail "unexpected" False
 
eof :: Stream d => Rat d ()
eof = notFollowedBy anyChar
 
satisfy :: Stream d => (Char -> Bool) -> Rat d Char
satisfy p = try $ do
  x < - anyChar
  x <$ guard (p x)
 
char :: Stream d => Char -> Rat d Char
char c = satisfy (c ==)
 
lexeme :: Stream d => Rat d a -> Rat d a
lexeme m = m < * whiteSpace
 
symbol :: Stream d => Char -> Rat d Char
symbol c = lexeme (char c)
 
digit :: Stream d => Rat d Int
digit = digitToInt < $> satisfy isDigit
 

And we can of course use a string as our input stream:

 
instance Stream [Char] where
  anyChar = Rat $ \s -> case s of
    (x:xs) -> Commit xs x
    [] -> Fail "EOF" False
 

Now that we've built a poor man's Parsec, let's do something more interesting. Instead of just using String as out input stream, let's include slots for use in memoizing the results from our various parsers at each location. To keep things concrete, we'll memoize the ArithPackrat.hs example that Bryan Ford used in his initial packrat presentation enriched with some whitespace handling.

 
data D = D
  { _add        :: Result D Int
  , _mult       :: Result D Int
  , _primary    :: Result D Int
  , _decimal    :: Result D Int
  , anyCharD    :: Result D Char
  }
 

If you look at the type of each of those functions you'll see that _add :: D -> Result D Int, which is exactly our Rat newtype expects as its argument, we we can bundle them directly:

 
 
add, mult, primary, decimal :: Rat D Int
add     = Rat _add
mult    = Rat _mult
primary = Rat _primary
decimal = Rat _decimal
 

We can similarly juse use the character parse result.

 
instance Stream D where
  anyChar = Rat anyCharD
 

Now we just need to build a D from a String. I'm using view patterns and record wildcards to shrink the amount of repetitive naming.

 
parse :: String -> D
parse s = fix $ \d -> let
  Rat (dv d -> _add) =
        (+) < $> mult < * symbol '+' <*> add
     < /> mult
  Rat (dv d -> _mult) =
        (*) < $> primary < * symbol '*' <*> mult
    < /> primary
  Rat (dv d -> _primary) =
        symbol '(' *> add < * symbol ')'
    </> decimal
  Rat (dv d -> _decimal) =
     foldl' (\b a -> b * 10 + a) 0 < $> lexeme (some digit)
  anyCharD = case s of
    (x:xs) -> Commit (parse xs) x
    []     -> Fail "EOF" False
  in D { .. }
 
dv :: d -> (d -> b) -> b
dv d f = f d
 

Note that we didn't really bother factoring the grammar, since packrat will take care of memoizing the redundant calls!

And with that, we can define an evaluator.

 
eval :: String -> Int
eval s = case runRat (whiteSpace *> add < * eof) (parse s) of
  Pure a -> a
  Commit _ a -> a
  Fail s _ -> error s
 

Note that because the input stream D contains the result directly and parse is the only thing that ever generates a D, and it does so when we start up, it should be obvious that the parse results for each location can't depend on any additional information smuggled in via our monad.

Next time, we'll add a packratted Stream type directly to Parsec, which will necessitate some delicate handling of user state.

The small parser implemented here can be found on my github account, where it hasn't been adulterated with unnecessary spaces by my blog software.

P.S. To explain the quote, had I thought of it earlier, I could have named my parsing combinator library "Kessel Run" as by the time I'm done with it "it will contain at least 12 parsecs" between its different parser implementations.

But, I thought I should point out that the pointed set that he posted also has a comonadic structure, which may be exploited since it is just a variation on the "zipper comonad," a structure that is perhaps more correctly called a "pointing comonad."

But first, a little background:

With combinatorial species you point a data structure by marking a single element in it as special. We can represent that with the product of an element and the derivative of the original type.

F*[A] = A * F'[A]

So, then looking at Shan's pointed set, we can ask what combinatorial species has a list as its derivative?

The answer is a cycle, not a set.

This fact doesn't matter to the monad, since the only way a monadic action interacts with that extra structure is safely through bind, but does for the comonad where every comonadic action has access to that structure, but no control over the shape of the result.

However, we don't really have a way to represent an unordered set in Haskell, so if you are treating a list as a set, the derivative of a set is another set then we can also view the a * [a] as a pointed set, so long as we don't depend on the order of the elements in the list in any way in obtaining the result of our comonadic actions.

I've changed the name of his data type to PointedSet to avoid conflicting with the definitions of Pointed and Copointed functors in category extras.

 
module PointedSet where
 
import Control.Comonad -- from my category-extras library
import Data.List (inits,tails) -- used much later below
 
data PointedSet a = PointedSet a [a] deriving (Eq, Ord, Show, Read)
 
instance Functor PointedSet where
    fmap f (PointedSet x xs) = PointedSet (f x) $ fmap f xs
 

The definition for extract is obvious, since you have already selected a point, just return it.

 
instance Copointed PointedSet where
    extract (PointedSet x _) = x
 

On the other hand, for duplicate we have a couple of options. An obvious and correct, but boring implementation transforms a value as follows:

 
boring_duplicate :: PointedSet a -> PointedSet (PointedSet a)
boring_duplicate xxs@(PointedSet x xs) =
    PointedSet xxs $ fmap (flip PointedSet []) xs
 

 
*PointedSet> boring_duplicate $ PointedSet 0 [1..3]
PointedSet (PointedSet 0 [1..3]) [
    PointedSet 1 [],
    PointedSet 2 [],
    PointedSet 3 []
]
 

but that just abuses the fact that we can always return an empty list.

Another fairly boring interpretation is to just use the guts of the definition of the Stream comonad, but that doesn't model a set with a single memory singled out.

A more interesting version refocuses on each element of the list in turn, which makes the connection to the zipper comonad much more obvious. Since we want a pointed set and not a pointed cycle, we can focus on an element just by swapping out the element in the list in that position for the focus.

Again, since we can't specify general species in Haskell, this is as close as we can come to the correct comonadic structure for a pointed set. Due to the limitations of our type system, the comonadic action can still see the order of elements in the set, but it shouldn't use that information.

Since we don't care to preserve the order of the miscellaneous set elements, the refocus helper function below can just accumulate preceding elements in an accumulating parameter in reverse order.

 
instance Comonad PointedSet where
    duplicate xxs@(PointedSet x xs) = PointedSet xxs $ refocus [] x xs
      where
        refocus :: [a] -> a -> [a] -> [PointedSet a]
        refocus acc x (y:ys) =
            PointedSet y (acc ++ (x:ys)) : refocus (y:acc) x ys
        refocus acc x [] = []
 

Now,

 
*PointedSet> duplicate $ PointedSet 0 [1..3] =
PointedSet (PointedSet 0 [1,2,3]) [
    PointedSet 1 [0,2,3],
    PointedSet 2 [1,0,3],
    PointedSet 3 [2,1,0]
]
 

With that in hand we can define comonadic actions that can look at an entire PointedSet and return a value, then extend them comonadically to generate new pointed sets.

For instance, if we had a numerical pointed set and wanted to blur our focus somewhat we could weight an average between the focused and unfocused elements:

smooth :: Fractional a => a -> PointedSet a -> a
smooth w (PointedSet a as) =
    w * a +
    (1 - w) * sum as / fromIntegral (length as)

Smoothing is a safe pointed-set comonadic operation because it doesn't care about the order of the elements in the list.

And so now we can blur the distinction between the focused element and the rest of the set:

 
*PointedSet> extend (smooth 0.5) $ PointedSet 10 [1..5]
PointedSet 6.5 [2.9,3.3,3.7,4.1,4.5]
 

A quick pass over the comonad laws shows that they all check out.

As noted above, if your comonadic action uses the order of the elements in the list beyond the selection of the focus, then it isn't really a valid pointed set comonadic operation. This is because we are abusing a list to approximate a (multi)set.

The Pointed-Cycle Comonad

A slight variation on this theme keeps the order of the elements the same in exchange for a more expensive refocusing operation and just rotates them through the focus.

 
data PointedCycle a = PointedCycle a [a] deriving (Eq, Ord, Show,Read)
 
instance Functor PointedCycle where
    fmap f (PointedCycle x xs) = PointedCycle (f x) $ fmap f xs
 
instance Copointed PointedCycle where
    extract (PointedCycle x _) = x
 
instance Comonad PointedCycle where
   duplicate xxs@(PointedCycle x xs) =
        PointedCycle xxs . fmap listToCycle . tail $ rotations (x:xs)
     where
        rotations :: [a] -> [[a]]
        rotations xs = init $ zipWith (++) (tails xs) (inits xs)
        listToCycle (x:xs) = PointedCycle x xs
 

With that you acknowledge that you really have a pointed cycle and the writer of the comonadic action can safely use the ordering information intrinsic to the list as a natural consequence of having taken the derivative of a cycle.

 
*PointedSet> duplicate $ PointedCycle 0 [1..3]
PointedCycle (PointedCycle 0 [1,2,3]) [
    PointedCycle 1 [2,3,0],
    PointedCycle 2 [3,0,1],
    PointedCycle 3 [0,1,2]
]
 

I had to restore the blog database from a backup and so I lost a few posts, including the index for the various recursion schemes entries. Fortunately, before that happened I had replicated the catamorphism post as a knol.

Should I find myself with a copious glut of free time, I shall happily re-scribe and finish the rest, but I've been very busy.

The basic idea being that for each thunk instead of overwriting it with the answer as usual in call-by-need, you'd just write a forwarding pointer, and allow GC to collect the answers over time.

This results in recalculation and may be subject to thrashing, so the obvious fix would be either

1. a 'forget at most once' policy, which would only mitigate the kind of memory leaks you get from laziness under limited conditions, but which has a worst case payout of doubling the workload or
2. an exponential backoff on how often you'll try to recollect a given value, which should preserve for practical purposes the asymptotic behavior of any algorithm, but with a much larger constant for pathological access patterns. [Edit: it may affect asymptotic behavior, because you could lose sharing]

This would allow the recollection of large CAFs, etc. eventually once they had bitrotted long enough.

Not sure if its worth the cost of recalculating and of storing any backoff counter, but most of the horror stories you hear about Haskell center around its occasional horrific memory usage profile.

Tuning points might include studying average thunk lifetimes to construct thunk access profiles rather than use a naive exponential backoff.

It also may exascerbate the opposite problem where naive code often builds up a tower of thunks it needs to evaluate all at once in order to provide an answer (i.e. when working with a lazy accumulating parameter).

Transcoding the category theory mumbo-jumbo into Haskell, so I can have a larger audience, we get the following 'frat combinator' -- you can blame Jules Bean from #haskell for that.

 
hyloEta :: Functor f =>
     (g b -> b) ->
     (forall a. f a -> g a) ->
     (a -> f a)
hyloEta phi eta psi = phi . eta . fmap (hyloEta phi eta psi) . psi
 

We placed eta in the middle of the argument list because it is evocative of the fact that it occurs between phi and psi, and because that seems to be where everyone else puts it.

Now, clearly, we could roll eta into phi and get the more traditional hylo where f = g. Less obviously we could roll it into psi because it is a natural transformation and so the following diagram commutes:

This 'Hylo Shift' property (mentioned in that same paper) allows us to move the 'eta' term into the phi term or into the psi term as we see fit. Since we can move the eta term around and it adds no value to the combinator, it quietly returned to the void from whence it came. hyloEta offers us no more power than hylo, so out it goes.

So, if its dead, why talk about it?

Well, when we move to a generalized hylomorphism we have a design decision that has some performance effects, and my initial pass at a generalized hylomorphism isn't as general as it could be. When we open up the generalized hylomorphism and look at its guts (check the slightly updated source code from yesterday) we see:

 
g_hylo' w m f g = liftW f . w . fmap duplicate . fmap (g_hylo' w m f g) . fmap join . m . liftM g
 

expanding that to include the eta term gives us 4 candidate locations where we can abuse its status as a natural transformation to slot it in.

 
g_hylo'1 w m f eta g =
    liftW f .
    w . eta . fmap duplicate . fmap (g_hylo' w m f g) . fmap join . m .
    liftM g
g_hylo'2 w m f eta g =
    liftW f .
    w . fmap duplicate . eta . fmap (g_hylo' w m f g) . fmap join . m .
    liftM g
g_hylo'3 w m f eta g =
    liftW f .
    w . fmap duplicate . fmap (g_hylo' w m f g) . eta . fmap join . m .
    liftM g
g_hylo'4 w m f eta g =
    liftW f .
    w . fmap duplicate . fmap (g_hylo' w m f g) . fmap join . eta . m .
    liftM g
 

g-hylo'1 and g_hylo'4 are particularly interesting because we have functions sitting right next to them that we can fuse it into by generalizing the type signatures only slightly and because that leaves a run of 3 fmaps in a row that we can fuse together. If we generalize the signatures of both w and m we get the following definition that allows you to place it on the left or the right, and for g_hylo to not have to care about it.

-- new and improved!
g_hylo :: (Comonad w, Functor f, Monad m) =>
          (forall a. f (w a) -> w (g a)) ->
          (forall a. m (e a) -> f (m a)) ->
          (g (w b) -> b) ->
          (a -> e (m a)) ->
          (a -> b)
g_hylo w m f g = extract . g_hylo' w m f g . return

-- | the kernel of the generalized hylomorphism
g_hylo' :: (Comonad w, Functor f, Monad m) =>
           (forall a. f (w a) -> w (g a)) ->
           (forall a. m (e a) -> f (m a)) ->
           (g (w b) -> b) ->
           (a -> e (m a)) ->
           (m a -> w b)
g_hylo' w m f g = liftW f . w . fmap (duplicate . g_hylo' w m f g . join) . m . liftM g

The slightly generalized signatures for our two distributive laws now allow them to change functors on the way through, but we shed a superfluous argument.

Note that while 3 'Functors' e, f and g are involved, only f needs to be a Functor in Hask because we do the duplication, hylomorphism and join all inside f in either case. And most of the time e = f = g. For instance e or g could be exponential or contravariant.

So now that we've generalized our generalized hylomorphism we're done right?

Not quite. Unfortunately the same trick doesn't work for the generalized chronomorphism defined last night.

To see why, we have open up chrono and peek at its guts.

 
chrono = g_chrono id id
 

Well, that was boring. Digging deeper we find:

 
g_chrono :: (Functor f, Functor g, Functor m, Functor w) =>
            (forall b. f (w b) -> w (f b)) ->
            (forall b. m (f b) -> f (m b)) ->
            (f (Cofree w b) -> b) ->
            (a -> f (Free m a)) ->
            a -> b
g_chrono w m = g_hylo (distCofree w) (distFree m)
 

Sticking in hylo's vestigial natural transformation, we get:

 
g_chronoEta :: (Functor f, Functor g, Functor m, Functor w) =>
            (forall b. g (w b) -> w (g b)) ->
            (forall b. m (f b) -> f (m b)) ->
            (g (Cofree w b) -> b) ->
            (forall c. f a -> g a) ->
            (a -> f (Free m a)) ->
            a -> b
g_chronoEta w m f eta g = g_hylo (distCofree w . eta) (distFree m) f g
-- g_chronoEta w m f eta g = g_hylo (distCofree w) (eta . distFree m) f g
 

And so, we roll up our sleeves ready to merge it into something, be it f, g, w, m, anything, but it seems the only places eta can go is to merge into one of the distributive laws, because f and g are executed lifted.

Unfortunately, the user passed us rules for distributing the base functor of the cofree comonad and free monad, not for distributing the whole cofree comonad. And my efforts to generalize distFree and distCofree have thus far met with some frustration, there isn't much to grab onto there to write the more general signature.

Ideally, I'd just be able to merge it into one of the distributive laws. Since the HYLO guys liked to put it on the left of the recursive call to the hylomorphism, we'll look at distCofree. The desired signature for distCofree' would be:

 
distCofree' ::   (Functor f, Functor g, Functor h) =>
                (forall a. f (h a) -> h (g a)) ->
                f (Cofree h a) -> Cofree h (g a)
 

and it should have the property that:

 
distCofree' (f . eta) == distCofree' f . eta
 

Without that, g_chronoEta is more powerful than g_chrono. Naturally.

Source Code

Here is the actual content.

O.K. it was more of a polite request, but I did update it.