{{ message }}

Instantly share code, notes, and snippets.

# vlopezj/NewtypeDeriving.markdown

Forked from Icelandjack/NewtypeDeriving.markdown
Last active Oct 4, 2017
Newtype Deriving

# `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)

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 #-}

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
Applicative```

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

```data Sorted a = Sorted a a a
deriving
Functor
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"

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
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`.

"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```