Newtype Deriving

NewtypeDeriving.markdown

Monad gives Applicative, Applicative etc. gives Num, Floating, Fractional

Setting it up

WrapMonad tells us that a Monad implies Functor, Applicative

instance Monad m => Functor     (WrappedMonad m)
instance Monad m => Applicative (WrappedMonad m)
instance Monad m => Monad       (WrappedMonad m)

We can do the same with Applicative and Num (Floating, Fractional)

newtype WrapApplicative f a = WrapApplicative (f a)
  deriving (Functor, Applicative)

instance (Applicative f, Num a) => Num (WrapApplicative f a) where
  (+)         = liftA2 (+)
  (*)         = liftA2 (*)
  negate      = fmap negate
  fromInteger = pure . fromInteger
  abs         = fmap abs
  signum      = fmap signum

instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
  recip        = fmap recip
  fromRational = pure . fromRational

instance (Applicative f, Floating a) => Floating (WrapApplicative f 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

instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
  (<>) = liftA2 (<>)

instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
  mempty = pure mempty

Payoff

Let's take Sorted as an example

data Sorted a = Sorted a a a

If we declare a Monad instance,

{-# Language InstanceSigs #-}

instance Monad Sorted where
  return :: a -> Sorted a
  return a = Sorted a a a
  
  (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
  Sorted a b c >>= f = Sorted a' b' c' where
    Sorted a' _  _  = f a
    Sorted _  b' _  = f b
    Sorted _  _  c' = f c

WrappedMonad Sorted describes how to derive Applicative Sorted and Functor Sorted (which can be derived anyway) from that Monad Sorted instance

data Sorted a = Sorted a a a
  deriving 
    Functor
  deriving as WrappedMonad Sorted a
    Applicative

but given an Applicative we can derive Num, Fractional, Floating, Semigroup, Monoid

data Sorted a = Sorted a a a
  deriving 
    Functor
  deriving as WrappedMonad Sorted a
    Applicative
  deriving as WrappedApplicative Sorted a
    (Num, Fractional, Floating, Semigroup, Monoid)

Pretty Printing

Similar looking example from Functional Pearl: a pretty but not greedy printer from ICFP 2017

class Layout l where
  (<>)   :: l -> l -> l
  text   :: String -> l
  flush  :: l -> l
  render :: l -> String
  
instance Layout [L] where
  text     = pure . text
  flush    = fmap flush
  xs <> ys = (<>) <$> xs <∗> ys

--->

instance (Applicative f, Layout a) => Layout (WrapApplicative f a) where
  (<>)  = liftA2 (<>)
  text  = pure . text
  flush = fmap flush

Alternative to "multiple default methods"

#7395.

A silly example where we want to test if something is zero:

class IsZero a where
  isZero :: a -> Bool

a myriad of silly ways to derive this (== 0) and \a -> "0" == show a:

newtype WrappedNumEq a = WrappedNumEq a
newtype WrappedShow  a = WrappedShow  a

instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
  isZero :: WrappedNumEq a -> Bool
  isZero (WrappedNumEq a) = 0 == a
  
instance Show a => IsZero (WrappedShow a) where
  isZero :: WrappedShow a -> Bool
  isZero (WrappedShow a) = "0" == show a

hopefully this lets us choose which method we want, rather than selecting a priviledged default method:

newtype INT = INT Int 
  deriving as WrappedNumEq Int
    IsZero

newtype VOID = VOID Void
  deriving as WrappedShow Void
    IsZero

This can be easily extended to further default methods, even given the same type

newtype WrappedNumEq2 a = WrappedNumEq2 a

instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
  isZero :: WrappedNumEq2 a -> Bool
  isZero (WrappedNumEq2 a) = a + a == a

QuickCheck

Actual example where we want multiple default methods

Test.QuickCheck

arbitraryBoundedEnum          :: (Bounded a, Enum a)     => Gen a
arbitraryBoundedIntegral      :: (Bounded a, Integral a) => Gen a
arbitraryBoundedRandom        :: (Bounded a, R.Random a) => Gen a
arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a
arbitrarySizedFractional      :: Fractional a            => Gen a
arbitrarySizedIntegral        :: Integral a              => Gen a

coarbitraryEnum     :: Enum     a => a -> Gen b -> Gen b
coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b
coarbitraryReal     :: Real     a => a -> Gen b -> Gen b
coarbitraryShow     :: Show     a => a -> Gen b -> Gen b

We can replace each of those with a newtype with an Arbitrary / CoArbitrary instance

newtype ArbitraryEnum a = ArbitraryEnum a deriving (Bounded, Enum) 

instance (Bounded a, Enum a) => Arbitrary (ArbitraryEnum a) where
  arbitrary :: Gen (ArbitraryEnum a)
  arbitrary = arbitraryBoundedEnum
  
instance Enum a => CoArbitrary (ArbitraryEnum a) where
  coarbitrary :: ArbitraryEnum a -> Gen b -> Gen b
  coarbitrary = coarbitraryEnum
  
data BOOL = F | T
  deriving
    (Enum, Bounded)
  deriving as ArbitraryEnum
    (Arbitrary, CoArbitrary)

Test.QuickCheck.Function

Can be used for Test.QuickCheck.Function

import Test.QuickCheck.Function

newtype FunctionShow     a = FunctionShow     a deriving (Read, Show, Num, CoArbitrary)
newtype FunctionIntegral a = FunctionIntegral a deriving (Integral, Real, Ord, Eq, Enum, Num, CoArbitrary)
newtype FunctionRealFrac a = FunctionRealFrac a deriving (RealFrac, Real, Ord, Eq, Fractional, Num, CoArbitrary)

instance (Read a, Show a) => Function (FunctionShow a) where
  function :: (FunctionShow a -> c) -> (FunctionShow a :-> c)
  function = functionShow

instance (Integral a) => Function (FunctionIntegral a) where
  function :: (FunctionIntegral a -> c) -> (FunctionIntegral a :-> c)
  function = functionIntegral

instance RealFrac a => Function (FunctionRealFrac a) where
  function :: (FunctionRealFrac a -> c) -> (FunctionRealFrac a :-> c)
  function = functionRealFrac

to derive Function instances

data BOOL = F | T
  deriving
    (Show, Read, Enum, Bounded)
  deriving as ArbitraryEnum
    (Arbitrary, CoArbitrary)
  deriving as FunctionShow BOOL
    Function

TODO: If you could provide values to deriving instances

data BOOL = F | T
  deriving Function
    with iso (\case F -> Left  ()
                    T -> Right ())
             (\case Left  () -> F
                    Right () -> T)

Semi-Direct Product

Then the semi-direct product a ⋊ m is structurally just the product type (a, m), but under the monoid operation

(a1 ⋊ m1) ⋄ (a2 ⋊ m2) = (a1 ⋄ (m1 • a2) ⋊ m1 ⋄ m2):

where • is an action of m on a.

— How to Twist Pointers without Breaking Them

"Structurally just the product type" indicates that we can use our deriving technique. It is worth noting that the maxWidth and lastWidth subcomponents of M from Functional Pearl: a pretty but not greedy printer

data M = M
  { height    :: Int
  , lastWidth :: Int
  , maxWidth  :: Int
  }

instance Layout M where
  (<>) :: M -> M -> M
  M h1 l1 m1 <..> M h2 l2 m2 = M
    (h1   +   h2)
    (l1   +   l2)
    (m1 `max` (l1 + m2))

form a semi-direct product

class (Semigroup m, Monoid m) => Action m a where
  act :: m -> a -> a

class (Action m a, Monoid a, Semigroup a) => Distributive m a

data a ⋊ b = a :⋊ b

instance Distributive m a => Semigroup (a ⋊ m) where
  (a1 :⋊ m1) <> (a2 :⋊ m2) =
    (a1 <> act m1 a2) :⋊ (m1 <> m2)

instance Distributive m a => Monoid (a ⋊ m) where
  mempty  = mempty :⋊ mempty
  mappend = (<>)

This looks confusing but it's conceptually nice

newtype LastWidth = LW (Sum Int) deriving (Show, Eq, Semigroup)
newtype MaxWidth  = MW (Max Int) deriving (Show, Eq, Semigroup)

instance Action LastWidth MaxWidth where
  act :: LastWidth -> MaxWidth -> MaxWidth
  act (LW (Sum a)) (MW (Max b)) = MW (Max (a + b))

now we we derive (<>) on M by as a Semigroup it

newtype MaxWidth  = MW Int deriving as Max Int (Show, Eq, Semigroup)
newtype LastWidth = LW Int deriving as Sum Int (Show, Eq, Semigroup)

newtype M = M_ (Sum Int, MaxWidth ⋊ LastWidth)
  deriving (Semigroup)
  
pattern M :: Int -> Int -> Int -> M
pattern M {height, maxWidth, lastWidth} = M_ (Sum height, MW maxWidth :⋊ LW lastWidth)

Wouldn't it be nice

data M = M
  { height    :: Int
  , lastWidth :: Int
  , maxWidth  :: Int
  }
  deriving as pattern M { height, lastWidth, maxWidth } = (Sum height, MW maxWidth :⋊ LW lastWidth)
    Semigroup

Dummy instances

Can be useful to satisfy constraints when you don't actually need the methods.

newtype WrapUndefined a = WrapUndefined a

instance Show (WrapUndefined a) where
  show _ = error "(GHC.Show.show): no implementation"

instance Num (WrapUndefined a) where
  _ + _ = error "(GHC.Num.+): no implementation"
  _ * _ = error "(GHC.Num.+): no implementation"

newtype BOOL = BOOL (WrapUndefined Bool)
  deriving (Show, Num)

pattern F = BOOL (WrapUndefined False)
pattern T = BOOL (WrapUndefined True)

WrappedBifunctor

-- Bitraversable 
----> Traversable
-- Bifoldable
----> Foldable

instance Bifoldable    p => Foldable      (WrappedBifunctor p a)
instance Bitraversable p => Traversable   (WrappedBifunctor p a)

and

-- Bitraversable
----> Bifunctor
----> Bifoldable

instance Bitraversable f => Bifunctor     (WrappedBitraverse f) where bimap                                 = bimapDefault
instance Bitraversable f => Bifoldable    (WrappedBitraverse f) where bifoldMap                             = bifoldMapDefault
instance Bitraversable t => Bitraversable (WrappedBitraverse t) where bitraverse f g (WrappedBitraverse xs) = WrappedBitraverse <$> bitraverse f g xs

So one could write

data P a b = P a b
  deriving as WrappedBifunctor P a b
    (Foldable, Traversable)
  deriving as WrappedBitraverse P a b
    (Bifunctor, Bifoldable)
    
instance Bitraversable P where
  bitraverse :: Applicative f => (a -> f a') -> (b -> f b') -> (P a b -> f (P a' b'))
  bitraverse f g (P a b) = P <$> f a <*> g b