Last active
June 4, 2016 19:01
-
-
Save robrix/b0a82c2a85c94edacd98ffcdaa2baf8c to your computer and use it in GitHub Desktop.
Recursive functors with some fiddling for type parameter order
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Old friends. | |
newtype Fix f = Fix { unFix :: f (Fix f) } | |
data Free f a = Free (f (Free f a)) | Pure a | |
data Cofree f a = a :< f (Cofree f a) | |
-- A recursive functor. We can’t define a Functor instance for e.g. `Fix` because: | |
-- 1. Its type parameter is of kind (* -> *). Maybe PolyKinds could hack around this, I’ve not tried. | |
-- 2. Following from that, its type parameter is applied to `Fix f` itself, and thus `(f (Fix f) -> g (Fix g)) -> Fix f -> Fix g` would probably be a mistake too; we want to ensure that `Fix` recursively maps its parameter functor into the new type, and not leave that map the responsibility of the function argument. | |
class RFunctor f | |
where rmap :: Functor a => (a (f b) -> b (f b)) -> f a -> f b | |
-- Free and Cofree both take a second type parameter applied after the recursive one we want to swap out. I’m too tired to figure out a better way of dealing with this, so we just define a second typeclass for them. | |
class RFunctor' f | |
where rmap' :: Functor a => (a (f b c) -> b (f b c)) -> f a c -> f b c | |
instance RFunctor Fix | |
where rmap f = Fix . f . fmap (rmap f) . unFix | |
instance RFunctor' Free | |
where rmap' f free = case free of | |
Free g -> Free (f (rmap' f <$> g)) | |
Pure a -> Pure a | |
instance RFunctor' Cofree | |
where rmap' f (a :< g) = a :< f (rmap' f <$> g) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TypeFamilies, TypeOperators, TypeSynonymInstances #-} | |
import Control.Comonad.Trans.Cofree -- from the `free` package | |
import Control.Monad.Trans.Free -- from the `free` package | |
import Data.Functor.Foldable -- from the `recursion-schemes` package | |
import Data.Text (Text, pack, unpack) -- from the `text` package | |
import Prelude hiding (Foldable) | |
-- | Natural transformations between functors f and g. | |
type (~>) f g = (forall a. f a -> g a) | |
-- | What a nice little functor. | |
data REPLF s rest | |
= Write s rest | |
| Read (s -> rest) | |
| Exit | |
-- | A REPL. | |
type REPL s = Fix (REPLF s) | |
-- | A more composable REPL. | |
type REPL' s = Free (REPLF s) s | |
-- REPLF embeds a value of its first type parameter, but also uses it as the domain in a functional. That makes it both co- and contra-variant, and therefore invariant, so we need to be able to map in both directions. | |
-- | |
-- I was going to make this into a nice Isofunctor type class until I realized that it’d have to be some sort of IsoBiProDifunctor monstrosity because it’s invariant on the first parameter but covariant on the second. Yuck. | |
isomap :: (a -> b) -> (b -> a) -> REPLF a c -> REPLF b c | |
isomap f _ (Write s v) = Write (f s) v | |
isomap f g (Read h) = Read (h . g) | |
isomap _ _ Exit = Exit | |
-- | Lift a natural transformation over Foldable/Unfoldable functors. | |
liftNat :: (Foldable f, Unfoldable g, Functor (Base f), Functor (Base g)) => (Base f ~> Base g) -> f -> g | |
liftNat nat = embed . nat . fmap (liftNat nat) . project | |
packREPL :: REPL String -> REPL Text | |
packREPL = liftNat (isomap pack unpack) | |
packREPL' :: REPL' String -> REPL' Text | |
packREPL' = liftNat (liftFreeF (isomap pack unpack) pack) | |
liftFreeF :: (Functor f) => (f ~> g) -> (a -> b) -> FreeF f a ~> FreeF g b | |
liftFreeF f g (Free r) = Free (f r) | |
liftFreeF f g (Pure a) = Pure (g a) | |
-- | Instances | |
instance Functor (REPLF s) where | |
fmap f (Write s v) = Write s (f v) | |
fmap f (Read g) = Read (f . g) | |
fmap f Exit = Exit | |
-- Having a `Base` instance for `Free f a` which produces `FreeF f a` makes it possible for us to write both `Foldable` and `Unfoldable` instances for it, whereas if we took the more traditional view of the underlying functor as f, we could really only make an `Unfoldable` instance. (Consider: If we used `f`, how would we implement `project` over the `Pure` constructor?) | |
-- | |
-- Inconveniently, this means that when we apply `liftNat` to is going to take a natural transformation between `FreeF`s instead of between `f`s. That’s why `liftFreeF` exists. | |
type instance Base (Free f a) = FreeF f a | |
instance Functor f => Foldable (Free f a) where project = runFree | |
instance Functor f => Unfoldable (Free f a) where embed = free | |
type instance Base (FreeF f a b) = f | |
instance (Functor f, Unfoldable b, Base b b ~ FreeF f a b) => Unfoldable (FreeF f a b) where embed = Free . fmap embed | |
type instance Base (Cofree f a) = CofreeF f a | |
instance Functor f => Foldable (Cofree f a) where project = runCofree | |
instance Functor f => Unfoldable (Cofree f a) where embed = cofree |
@cbarrett: Thank you for the comments!
Wouldn't this sort of thing be better expressed as a natural transformation btwn functors?
That’s lovely! I have been using natural transformations in the project that spawned this gist, but I hadn’t noticed that they express this so nicely.
It tuns out that one can combine this with e.g. the recursion-schemes
package to define a liftNat
operation for anything in both their Foldable
and Unfoldable
typeclasses (NB: this is quite distinct from the Data.Foldable
typeclass). I’ve added a module implementing this to the gist.
Here's a type-level flip that works for Free (requires poly kinds)
Your Flip
definition is pretty great! I was having quite a bit of trouble defining such myself 💖
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Here's a type-level flip that works for Free (requires poly kinds)