Blog Post: Derive instances of representationally equal types

blog_deriving.markdown

Reddit discusson thread.

I made a way to get more free stuff and free stuff is good.

The current implementation of deriveVia is here, it works with all the examples here. Needs GHC 8.2 and th-desugar.

It doesn't take long

for new Haskellers to get pampered by their compiler. For the price of a line or two the compiler offers to do your job, to write uninteresting code for you (in the form of type classes) such as equality, comparison, serialization, ... in the case of 3-D vectors

-- Eq   :: Type -> Constraint
-- Ord  :: Type -> Constraint
-- Show :: Type -> Constraint
-- Read :: Type -> Constraint

data V3 a = V3 a a a
  deriving (Eq, Ord, Show, Read, ...)

In the distant past GHC could only be cajoled into defining a few classes hard-coded into the compiler. With time that list grew to include more interesting classes — type classes over type constructors (of kind Type -> Type) rather than simple types (Type) — but always at the discretion of compiler writers.

{-# Language DeriveTraversable #-}

-- Functor     :: (Type -> Type) -> Constraint
-- Foldable    :: (Type -> Type) -> Constraint
-- Traversable :: (Type -> Type) -> Constraint

data V3 a = V3 a a a
  deriving (..., Functor, Foldable, Traversable)

With the advent of default methods and Generic the rubber band was on the other claw, library writers could now specify a generic, singular (privileged) function to be the default implementation of certain methods.

The JSON-library aeson provides default implementations of JSON serialization

class ToJSON a where
  toJSON :: a -> Value
  toJSON = genericToJSON defaultOptions
  default 
    toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value

class FromJSON a where
  parseJSON :: Value -> Parser a
  parseJSON = genericParseJSON defaultOptions
  default 
    parseJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a

so users don't even have to specify them

{-# Language DeriveGeneric #-}

import GHC.Generics (Generic)
import Data.Aeson   (ToJSON, FromJSON)

data V3 a = V3 a a a
  deriving 
    (..., Generic)

instance   ToJSON a =>   ToJSON (V3 a)
instance FromJSON a => FromJSON (V3 a)

Then we got the option of deriving any class like this

{-# Language ..., DeriveAnyClass #-}

data V3 a = V3 a a a
  deriving 
    (..., Generic, ToJSON, FromJSON)

and with the latest release (GHC 8.2) we get the option to be more explicit

{-# Language ..., DerivingStrategies #-}

data V3 a = V3 a a a
  deriving 
    (Eq, Ord, Show, Read, Generic)
    
  deriving 
    (Functor, Foldable, Traversable)

  deriving anyclass
    (ToJSON, FromJSON)

Any applicative functor can be given numeric instances in a boilerplate way.

— applicative-numbers package

Spoilers

Assuming an Applicative V3 instance we can make it into a number

instance Num a => Num (V3 a) where
  (+)         = liftA2 (+)
  (*)         = liftA2 (*)
  negate      = fmap negate
  abs         = fmap abs
  signum      = fmap signum
  fromInteger = pure . fromInteger

instance Fractional a => Fractional (V3 a) where
  recip        = fmap recip
  fromRational = pure . fromRational

instance Floating a => Floating (V3 a) where
  pi    = pure pi
  sqrt  = fmap sqrt
  exp   = fmap exp
  log   = fmap log
  sin   = fmap sin
  cos   = fmap cos
  asin  = fmap asin
  atan  = fmap atan
  acos  = fmap acos
  sinh  = fmap sinh
  cosh  = fmap cosh
  asinh = fmap asinh
  atanh = fmap atanh
  acosh = fmap acosh

with my solution we can define a newtype WrappedApplicative and write those instances once and for all.. and then use that newtype to derive them for any Applicative (the applicative-numbers package provides an include file.. not great folks)

data V3 a = V3 a a a
  deriving Functor

deriveVia ''Num        ''V3 ''WrappedApplicative
deriveVia ''Floating   ''V3 ''WrappedApplicative
deriveVia ''Fractional ''V3 ''WrappedApplicative
deriveVia ''Semigroup  ''V3 ''WrappedApplicative
deriveVia ''Monoid     ''V3 ''WrappedApplicative

instance Applicative V3 where
  pure :: a -> V3 a
  pure a = V3 a a a

  (<*>) :: V3 (a -> b) -> V3 a -> V3 b
  V3 f g h <*> V3 x y z = V3 (f x) (g y) (h z)

This gets translated into safe coercions

instance Num a => Num (V3 a) where
  (+) :: V3 a -> V3 a -> V3 a
  (+) = coerce ((+) @(WrappedApplicative V3 a))

  (-) :: V3 a -> V3 a -> V3 a
  (-) = coerce ((-) @(WrappedApplicative V3 a))

  (*) :: V3 a -> V3 a -> V3 a
  (*) = coerce ((*) @(WrappedApplicative V3 a))

  negate :: V3 a -> V3 a
  negate = coerce (negate @(WrappedApplicative V3 a))

  abs :: V3 a -> V3 a
  abs = coerce (abs @(WrappedApplicative V3 a))

  signum :: V3 a -> V3 a
  signum = coerce (signum @(WrappedApplicative V3 a))

  fromInteger :: Integer -> V3 a
  fromInteger = coerce (fromInteger @(WrappedApplicative V3 a)) 

With a tiny bit of compiler support it can be written

data V3 a = V3 a a a
  deriving Functor

  deriving via WrappedApplicative
    (Num, Floating, Fractional, Semigroup, Monoid)

instance Applicative V3 ...

"But wait..."

Defining Applicative can look like boilerplate too, if we have a Monad instance! (ignoring MRP, since it can be trivially worked around)

instance Applicative V3 where
  pure :: a -> V3 a
  pure = return

  (<*>) :: V3 (a -> b) -> V3 a -> V3 b
  (<*>) = ap

instance Monad V3 where
  return :: a -> V3 a
  return a = V3 a a a

  (>>=) :: V3 a -> (a -> V3 b) -> V3 b
  V3 a b c >>= f = V3 a' b' c' where
    V3 a' _ _ = f a
    V3 _ b' _ = f b
    V3 _ _ c' = f c

Using the same technique as earlier but with a different newtype WrappedMonad we can derive (Monad) → (Functor, Applicative) → (Num, Floating, Fractional)

data V3 a = V3 a a a
  deriving via WrappedMonad
    (Functor, Applicative)

  deriving via WrappedApplicative
    (Num, Floating, Fractional, Semigroup, Monoid)

instance Monad V3 ...

As mention before there can only be a

single

default

method

but methods like arbitrary and coarbitrary of the QuickCheck library have many candidates

arbitraryBoundedEnum     :: (Bounded a, Enum     a) => Gen a
arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a
arbitraryBoundedRandom   :: (Bounded a, Random   a) => Gen a
-- ...

so instead of picking a single we define multiple newtypes so we can derive Arbitrary from an Enum

data ABC = A | B | C 
  deriving 
    (Enum, Bounded, Show)
  deriving via WrappedArbitraryEnum
    (Arbitrary, CoArbitrary)

Integral

newtype UU = UU Int 
  deriving
    (Eq, Show, Ord, Enum, Bounded, Generic)

  deriving newtype 
    (Num, Real, Integral)

  deriving via WrappedArbitraryIntegral
    (Arbitrary, CoArbitrary)

or Random

newtype UU = UU Int 
  deriving
    (Bounded, Generic)

  deriving newtype 
    Random

  deriving anyclass
    CoArbitrary

  deriving via WrappedArbitraryRandom
    Arbitrary

We can derive Bifunctor, Bifoldable from Bitraversable using the WrappedBif newtype

data Pair2 a b = Pair2 a b
  deriving via WrappedBif
    (Bifunctor, Bifoldable)

  deriving via WrappedBifunctor
    (Functor, Foldable)

instance Bitraversable Pair2 where
  bitraverse :: Applicative f 
             => (a -> f a') 
             -> (b -> f b') 
             -> (Pair2 a b -> f (Pair2 a' b'))
  bitraverse f g (Pair2 a b) = Pair2 <$> f a <*> g b

and then Functor, Foldable can be derived using WrappedBifunctor. Same could be done with many other types when roles get updated.

There are many more applications, some allow us to avoid boilerplate code and others allow us to codify ‘common Haskell knowledge’ (like getting Num from Applicative).

Another example of such knowledge is that Monad can be defined in terms of a Functor with return and join:

class Functor m => MonadJoin m where
  return_  :: a -> m a
  join_    :: m (m a) -> m a

so given an instance for MonadJoin we can derive Monad via WrappedMonadJoin

data MAYBE a = NOTHING | JUST a
  deriving 
    Functor
  deriving via WrappedMonad
    Applicative
  deriving via WrappedMonadJoin
    Monad

instance MonadJoin MAYBE where
  return_ :: a -> MAYBE a
  return_ = JUST

  join_ :: MAYBE (MAYBE a) -> MAYBE a
  join_ (JUST (JUST a)) = JUST a
  join_ _               = NOTHING

Sometimes join is more intuitive, we may also wish to specify Applicative in terms of the equivalent Monoidal using WrappedMonoidal

class Functor f => Monoidal f where
  unit :: f ()
  (**) :: f a -> f b -> f (a,b)

data MAYBE a = ...
  deriving via WrappedMonoidal
    Applicative

instance Monoidal MAYBE where
  unit :: MAYBE ()
  unit = JUST ()

  (**) :: MAYBE a -> MAYBE b -> MAYBE (a, b)
  JUST a ** JUST b = JUST (a, b)
  _      ** _      = NOTHING

---

It also allows us to work with crazy hierarchies like this where we can derive everything..

I will write more posts about more interesting deriving schemes but for now, what do you think?

Please keep writing.

@andorp I'm already working on Part 2.

Here's another use case: You can trivially get Storable from the more expressive Primitive.

Thanks for the suggestion @andrewthad, maybe you know how to complete the instance declaration

newtype WrappedPrim a = WrapPrim a
  deriving newtype
    Prim

instance Prim a => Storable (WrappedPrim a) where
  sizeOf :: WrappedPrim a -> Int
  sizeOf a = I# (sizeOf# a)

  alignment :: WrappedPrim a -> Int
  alignment a = I# (alignment# a)