Deriving Functor instances in Haskell with GHC.Generics and one-liner

functor.hs

-- Example of deriving Functor using GHC.Generics and one-liner with
-- type-changing generic traversals.

{-# LANGUAGE
    DeriveGeneric
  , DeriveFunctor
  , MonoLocalBinds  -- TODO: used to turn off some warnings, why?
  , FlexibleContexts
  , TypeApplications
  , FlexibleInstances
  , StandaloneDeriving
  , AllowAmbiguousTypes
  , ScopedTypeVariables
  , UndecidableInstances
  , MultiParamTypeClasses
  #-}

import Data.Bifunctor (Bifunctor(..))
import GHC.Generics (Generic(..))
import Generics.OneLiner.Binary

-- A generic implementation of @fmap@.
-- Ignore @x@ for now.
gfmap
  :: forall x a b s t
  .  (Generic s, Generic t, ADT s t, Constraints s t (Functorial x a b))
  => (a -> b) -> s -> t
gfmap f = gmap @(Functorial x a b) (fmap' @x f)

-- The functorial class defines how we handle each constructor field.
--
-- * A few words about the scary @INCOHERENT@ pragmas
--
-- The precondition here (that users have the burden to ensure) is that
-- @gfmap@ is only ever used to define @fmap@ in @Functor@ instances.
-- Under that precondition, @a@ and @b@ shouldn't unify with each other, or
-- anything else, and @Functorial@ instances use that fact to not
-- actually overlap with each other.
--
-- @Functor@ is also special here because as long as @fmap id = id@, then there
-- is essentially only one implementation we should be able to write at all by
-- parametricity, so we don't have to worry so much about overlap in the first
-- place.
class Functorial x a b s t where
  fmap' :: (a -> b) -> (s -> t)

-- The most common cases are when we must directly apply the @(a -> b)@
-- function to a field...
instance {-# INCOHERENT #-} Functorial x a b a b where
  fmap' = id

-- ... and when the field should remain constant.
instance {-# INCOHERENT #-} Functorial x a b c c where
  fmap' _ = id

-- Two more common cases are that a field is functorial...
-- TODO: what about (Functor f, Functorial x a b s t) => Functorial x a b (f s) (f t)?
-- Seems like a bad idea in the case f is actually not a functor but its
-- arguments happen to mention a and b... (does that happen?)
instance {-# INCOHERENT #-} Functor f => Functorial x a b (f a) (f b) where
  fmap' = fmap

-- ... or it is a function (and we should map on its argument type).
-- This does overlap with @Functorial x a b (f a) (f b)@...
instance {-# INCOHERENT #-} (Functorial x a b v u, Functorial x a b s t)
  => Functorial x a b (u -> s) (v -> t) where
  fmap' f g = fmap' @x f . g . fmap' @x f

-- Otherwise we assume the type is @Generic@ and we automatically keep going
-- with @gfmap@.
--
-- Do not use @fmap'@ to implement @Functor@ because the instance
-- @Functorial a b (f a) (f b)@ would get picked! Use @gfmap@!
instance {-# OVERLAPPABLE #-}
  (Generic s, Generic t, ADT s t, Constraints s t (Functorial x a b))
  => Functorial x a b s t where
  fmap' = gfmap @x

-- Demo 1: Examples with some simple ADTs

data U a = U deriving (Generic, Show)
instance Functor U where fmap = gfmap

data I a = I a deriving (Generic, Show)
instance Functor I where fmap = gfmap

data V a deriving Generic
instance Functor V where fmap = gfmap

data P a = P a a Int deriving (Generic, Show)
instance Functor P where fmap = gfmap

data A a = X | Y a | Z Int a deriving (Generic, Show)
instance Functor A where fmap = gfmap

data R a = R0 a | R1 (R a) deriving (Generic, Show)
instance Functor R where fmap = gfmap

-- With a bit of work, this approach actually works well for complex types
-- that even GHC can't handle on its own with DeriveFunctor.

-- Demo 2: When functors which are not Functors get involved.

-- f is a Bifunctor
data C f a = C1 (f a a) | C2 (f (Maybe a) a) | C3 (f a [a])
  deriving Generic
  -- deriving (Generic, Functor)
  -- fails:
  --  • Can't make a derived instance of ‘Functor (C f)’:
  --    Constructor ‘C’ must use the type variable only as the last argument of
  --    a data type

{-
Writing the instance manually, for comparison:

instance Bifunctor f => Functor (C f) where
  fmap f (C1 x) = C1 (bimap f f x)
  fmap f (C2 y) = C2 (bimap (fmap f) f y)
  fmap f (C3 z) = C3 (bimap f (fmap f) z)

Doesn't look so bad, though it scales linearly in the size of the type
declaration.
-}

-- After tweaking @Functorial@ a bit, we will be able to write this one-liner:
instance Bifunctor f => Functor (C f) where fmap = gfmap @X'

-- We tweak it by writing an instance (which hopefully needs to be done once
-- for all).
instance {-# INCOHERENT #-}
  (Bifunctor f, Functorial X' a b s t, Functorial X' a b u v)
  => Functorial X' a b (f s u) (f t v) where
  fmap' f = bimap (fmap' @X' f) (fmap' @X' f)

-- We use the @x@ tag in the @Functorial@ class to namespace instances
-- and not conflict with other potential users.
data X'

deriving instance Show a => Show (C (,) a)

-- Demo 3: Polymorphic recursion

data Weird a
  = Tip a a
  | Nest (Weird (Weird a))
  | VeryNest (Weird (Weird (Weird (Weird a))))
  deriving (Generic, Show)

{-
instance Functor Weird where
  fmap f (Tip a b) = Tip (f a) (f b)
  fmap f (Nest x) = Nest ((fmap . fmap) f x)
  fmap f (VeryNest y) = VeryNest ((fmap . fmap . fmap . fmap) f y)
-}

-- As a one-liner
instance Functor Weird where fmap = gfmap @X''

-- OK, not really a one-liner either...
instance {-# INCOHERENT #-} Functorial X'' a b u v
  => Functorial X'' a b (Weird u) (Weird v) where
  fmap' = fmap . fmap' @X''

data X''

-- This should use fmap and print something.

test :: (Functor f, Show (f Int)) => f Int -> IO ()
test = print . fmap (+ 1)

main :: IO ()
main = do
  test $ U
  test $ I 0
  test $ P 0 0 0
  test $ Z 0 0
  test $ R1 (R1 (R0 0))
  test $ C1 (0, 0)
  test $ C2 (Just 0, 0)
  test $ Nest (Tip (Tip 0 0) (Tip 0 0))