-
-
Save robrix/b0a82c2a85c94edacd98ffcdaa2baf8c to your computer and use it in GitHub Desktop.
-- 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) |
{-# 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 |
Wouldn't this sort of thing be better expressed as a natural transformation btwn functors? type (~>) f g = forall x. f x -> g x
. Then you could write liftNat :: Functor f, Functor g => (f ~> g) -> Fix f -> Fix g
with an implementation like liftNat nat = Fix . nat . fmap (liftNat nat) . unFix
Here's a type-level flip that works for Free (requires poly kinds)
type family Flip (f :: i -> j -> k) (b :: j) (a :: i) :: k where
Flip f b a = f a b
*Main> :k Free
Free :: (* -> *) -> * -> *
*Main> :k Flip Free
Flip Free :: * -> (* -> *) -> *
@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 💖
It should be possible to write an
RFunctor'
instance for theRec
type from Functional Programming with Structured Graphs, but I haven’t tried—my implementation of structured graphs is higher-order (for use over GADTs) and regrettably I lack thePolyKinds
moxie required to unify myHRec
with theirRec
.But
hmap
is pretty much 1:1 withrmap'
.