Deriving Via

deriving_via_paper.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
-- {-# LANGUAGE ApplicativeDo #-}
-- {-# LANGUAGE Arrows #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
-- {-# LANGUAGE BlockArguments #-}
-- {-# LANGUAGE CApiFFI #-}
-- {-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds #-}
-- {-# LANGUAGE CPP #-}
-- {-# LANGUAGE CUSKs #-}
{-# LANGUAGE DataKinds #-}
-- {-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-- {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ExplicitForAll #-}
-- {-# LANGUAGE ExplicitNamespaces #-}
-- {-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
-- {-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- {-# LANGUAGE Haskell2010 #-}
-- {-# LANGUAGE Haskell98 #-}
-- {-# LANGUAGE HexFloatLiterals #-}
-- {-# LANGUAGE ImplicitParams #-}
-- {-# LANGUAGE ImplicitPrelude #-}
-- {-# LANGUAGE ImportQualifiedPost #-}
-- {-# LANGUAGE ImpredicativeTypes #-}
-- {-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE InstanceSigs #-}
-- {-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
-- {-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE MagicHash #-}
-- {-# LANGUAGE MonadComprehensions #-}
-- {-# LANGUAGE MonoLocalBinds #-}
-- {-# LANGUAGE MonomorphismRestriction #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
-- {-# LANGUAGE NamedWildCards #-}
-- {-# LANGUAGE ndecreasingIndentation #-}
-- {-# LANGUAGE NegativeLiterals #-}
-- {-# LANGUAGE NPlusKPatterns #-}
-- {-# LANGUAGE NullaryTypeClasses #-}
-- {-# LANGUAGE NumDecimals #-}
-- {-# LANGUAGE NumericUnderscores #-}
-- {-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE PackageImports #-}
-- {-# LANGUAGE ParallelListComp #-}
-- {-# LANGUAGE PartialTypesignatures #-}
-- {-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
-- {-# LANGUAGE PostfixOperators #-}
-- {-# LANGUAGE QuantifiesConstraints #-}
{-# LANGUAGE QuasiQuotes #-}
-- {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RankNTypes #-}
-- {-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RoleAnnotations #-}
-- {-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-- {-# LANGUAGE StandaloneKindSignatures #-}
-- {-# LANGUAGE StarIsType #-}
-- {-# LANGUAGE StaticPointers #-}
-- {-# LANGUAGE Strict #-}
-- {-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
-- {-# LANGUAGE TemplateHaskellQuotes #-}
-- {-# LANGUAGE TraditionalRecordSyntax #-}
-- {-# LANGUAGE TransformListComp #-}
-- {-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
-- {-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE UndecidableSuperClasses #-}
-- {-# LANGUAGE UnicodeSyntax #-}
-- {-# LANGUAGE UnliftedFFITypes #-}
-- {-# LANGUAGE UnliftedNewtypes #-}
-- {-# LANGUAGE Unsafe #-}
{-# LANGUAGE ViewPatterns #-}

module Scratch where

import Control.Monad(ap, liftM)
import Control.Applicative (Alternative (..), liftA2)
import Test.QuickCheck hiding (tabulate)
import GHC.TypeLits
import Data.Proxy
import Data.Coerce
import qualified GHC.Generics as GHC

-----------------------------------------------
-- 1. Introduction
-----------------------------------------------

newtype App f a = App (f a)
instance (Applicative f, Semigroup a)
    => Semigroup (App f a) where
  App f <> App g = App (liftA2 (<>) f g)
instance (Applicative f, Monoid a)
    => Monoid (App f a) where
  mempty = App (pure mempty)

newtype Alt f a = Alt (f a)
instance Alternative f
    => Semigroup (Alt f a) where
  Alt f <> Alt g = Alt (f <|> g)
instance Alternative f
    => Monoid (Alt f a) where
  mempty = Alt empty


data Maybe' a = Nothing' | Just' a
  deriving stock (Functor)
  -- deriving (Semigroup, Monoid) via (App Maybe' a)
  deriving (Semigroup, Monoid) via (Alt Maybe' a)

instance Applicative Maybe' where
  pure = Just'
  Nothing' <*> _ = Nothing'
  Just' f <*> mb = f <$> mb

instance Alternative Maybe' where
  empty = Nothing'
  Nothing' <|> g = g
  f <|> _ = f

-----------------------------------------------
-- 2. Case study: QuickCheck
-----------------------------------------------

-- >>> sample (arbitrary @Duration)
newtype Duration = Duration Int
  deriving stock (Show)
  -- deriving Arbitrary via (NonNegative Int)
  -- deriving Arbitrary via (Positive Int)
  deriving Arbitrary via (Positive (Large Int))

newtype BoundedEnum a = BoundedEnum a
instance (Bounded a, Enum a)
    => Arbitrary (BoundedEnum a) where
  arbitrary = BoundedEnum <$> arbitraryBoundedEnum

-- >>> sample (arbitrary @Weekday)
data Weekday = Mo | Tu | We | Th | Fr | Sa | Su
  deriving stock (Show, Enum, Bounded)
  deriving Arbitrary via (BoundedEnum Weekday)

newtype Between (l :: Nat) (u :: Nat) = Between Integer
instance (KnownNat l, KnownNat u)
    => Arbitrary (Between l u) where
  arbitrary = Between <$> choose (natVal @l Proxy, natVal @u Proxy)

-- >>> sample (arbitrary @(Year))
newtype Year = Year Integer
  deriving stock (Show)
  deriving Arbitrary via (Between 1970 2020)

-----------------------------------------------
-- 3. Typechecking and translation
-----------------------------------------------

-- 1. Well-typeness
-- 2. Codegen via generalized GND

{- Aligning kinds

data D d_1 ... d_m
  deriving (C c_1 ... c_n) via (V v_1 ... v_p)

1. The type (C c_1 ... c_n) must be of kind (k_1 -> ... -> k_r -> *) -> Constraint

   The reason is that the instance we must generate,

   instance C c_1 ... c_n (D d_1 ... d_i) where ...

   requires that we can apply C c_1 ... c_n to another type D d_1 ... d_n
   such that i \leq m

2. The kinds V v_1 .. v_p and D d_1 ... d_i, and the kind of argument to C c_1 ... c_n
   must all unify. For example, deriving Eq via Maybe does not unify as
   Eq :: * and Maybe :: * -> *.
-}

{- Eta-reducing the data type

The kind of C c_1 ... c_n is allowed to be different from D d_1 .. d_m

data Foo a = Foo a a
  deriving Functor

Foo a :: *
Functor ::  * -> *
Foo a is eta-reduced before applyied to Functor => Functor Foo

To determine how many variables to eta-reduce:

C c_1 ... c_n :: (k_1 -> ... -> k_r -> *) -> Constraint
Variables to eta-reduce = r
To compute the i in D d_1 ... d_i, we take i = m - r.

For example:

newtype A a = A a deriving Eq via (Identity a) -- Not eta-reduced
newtype B a = B a deriving Funtor via (Identity) -- Eta-reduced one variable
-}

{- The Coercible constraint

GHC's constraint solver can look inside of other type constructor
when determining if two types are inter-Coercible.

For example:

  If

   instance  Coercible Age Int
   instance  Coercible Int Age

  Then,

   instance  Coercible (Age -> [Age]) (Int -> [Int])
   instance  Coercible (Int -> [Int]) (Age -> [Age])


Coercible is transitive:

newtype A a = A [a]
newtype B   = B [Int]

then GHC is able to conclude that Coercible (A Int) B holds
-}

{- From GND to Deriving Via

The only difference between them is that in GND
GHC always picks the representation type for you.

Example:

newtype T = T Int
instnace Enum T where
newtype Age = MkAge Int deriving Enum via T

the generated code would be :

...
  enumFrom = coerce @(T -> [T])
                    @(Age -> [Age])
                    enumFrom

the transitivity Coercible is T -> Int -> Age.

Deriving Via is a superset of GND:

 newtype Age = MkAge Int deriving newtype Enum
  ≡ newtype Age = MkAge Int deriving Enum via Int
-}

{- Type variable scoping

data Foo a = ...
  deriving (Baz a b c) via (Bar a b)

- a is bound by Foo itself
- b is bound by the via type, Bar a b
- c is bound by the derived class, Baz a b c

data > via type > derived class type

If the order was data > derived class type > via type
  then,
       data D deriving (C1 a, C2 a) via (T a)
  would look like this
       data D deriving (forall a . C1 a, forall a1 . C2 a1) via (T ?)

-}

-----------------------------------------------
-- 4. More use cases
-----------------------------------------------


{-
Some default methods can be implemented more efficient:

class Functor f => Applicative f where
  (*>) = liftA2 (\ _ b -> b)

instance Applicative ((->) r) where
  _ *> g = g -- notice we don't apply f

This trick works for any data type that is isomorphic to ((->) r) for some r.
-}

-- | Represents the isomorphsim between ((->) r) and f
class Functor f => Representable f where
  type Rep f
  index :: f a -> (Rep f -> a)
  tabulate :: (Rep f -> a) -> f a

instance Representable ((->) r) where
  type Rep ((->) r) = r
  index f = f
  tabulate f = f

newtype WrapRep f a = WrapRep (f a)
  deriving newtype (Functor, Representable)
-- WrapRep f a has a Representable instance as long as
-- f is representabe.

instance Representable f
    => Applicative (WrapRep f) where
  pure = tabulate . pure
  f <*> g = tabulate (index f <*> index g)
  f <* _ = f
  _ *> g = g

-- Instead of having to manually override (<*) and (*>) to get
-- the desired performance, one can accomplish this in a more
-- straightforward fasion

newtype IntConsumer a = IntConsumer (Int -> a)
  deriving newtype (Functor, Representable)
  deriving Applicative via (WrapRep IntConsumer)

-- 4.2 Replace default signatures with deriving via

-- default signatures are limited to one default per method.

{-
Before default signatures:

class Petty a where
  pPrint :: a -> Doc
  genericPPrint :: (Generic a, GPretty (Rep a)) => a -> Doc

instance Pretty Bool where
  pPrint = genericPPrint

After:

class Petty a where
  pPrint :: a -> Doc
  genericPPrint :: (Generic a, GPretty (Rep a)) => a -> Doc
  default pPrint :: (Generic a, GPretty (Rep a)) => a -> Doc
  pPrint = genericPPrint

instance Pretty Bool

The problem is that one might one to:
  * Leverage a Show-based default implementation instead of a Generic-based one,
  * Use another generics library: generics-eot, generics-sop
  * Use a tweaked version which displays extra debugging info.

newtype GenericPPrint a = GenericPPrint a
instance (Generic a, GPretty (Rep a))
    => Pretty (GenericPPRint a) where
  pPrint (GenericPPrint x) = genericPPrint x

newtype ShowPPrint a = ShowPPrint a
instance Show a => Pretty (ShowPPrint a) where
  pPrint (ShowPPrint x) = stringToDoc (show x)

data D
  deriving Pretty via (GenericPPRint D)
  deriving Pretty via (ShowPPrint    D)

The paper proposes to remove default signatures
ought to be removed in favor of deriving via
-}

-- 4.3 Deriving via isomorphisms

-- So far we only derived data types that have the same
-- runtime representation as the original data type.

-- But we can also derive newtypes that are isomorphic, not just
-- representational equal. This technique rely on generic prog techniques.

newtype Title = Title String
  deriving newtype (Show, Arbitrary)

data Track = Track Title Duration
  deriving stock (Show, GHC.Generic)
  deriving Arbitrary via (Track `SameRepAs` (Title, Duration))

-- we would to define an arbitrary instance

{-
There's the instance:

instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b)

Track is isomorphic to (Title, Duration) but GHC doesn't know it
i.e there is no Coercible instance.
-}

-- | Captures isomorphism
newtype SameRepAs a b = SameRepAs a
instance
  ( GHC.Generic a
  , GHC.Generic b
  , Arbitrary b
  , Coercible (GHC.Rep a ()) (GHC.Rep b ())
  ) => Arbitrary (a `SameRepAs` b) where
  arbitrary = SameRepAs . coerceViaRep <$> arbitrary
    where
      coerceViaRep :: b -> a
      coerceViaRep =
        GHC.to . (coerce :: GHC.Rep b () -> GHC.Rep a ()) . GHC.from


-- 4.4 Retrofitting superclasses

{-
Retrofit existing type class with a superclass.
For example when Monad was changed to have Applicative as superclass.
You had to define Applicative and Functor in order to define Monad.

We can capture this fact as a newtype and make the process less tedious:
-}

newtype FromMonad m a = FromMonad (m a)
  deriving newtype Monad
instance Monad m => Functor (FromMonad m) where
  fmap = liftM
instance Monad m => Applicative (FromMonad m) where
  pure = return
  (<*>) = ap

data Stream a b = Done b | Yield a (Stream a b)
  deriving (Functor, Applicative)
    via (FromMonad (Stream a))

instance Monad (Stream a) where
  return = Done
  Yield a k >>= f = Yield a (k >>= f)
  Done b >>= f = f b

-- 4.5 Avoiding orphan instances

{-
newtype Plugin = Plugin (IO (String -> IO ()))
  deriving newtype Semigroup

In order for this to typecheck, there must be a Semigroup
instance for IO available.

Suppose there was no such instance for IO. We would need to:
 * Refactor base
 * Write na orphan instance for IO.

Deriving Via presents a more convenient third option: re-use
a Semigroup instance from another data type
-}

newtype Plugin = Plugin (IO (String -> IO ()))
  deriving Semigroup
    via (App IO (String -> App IO ()))

-----------------------------------------------
-- 5. Related Ideas
-----------------------------------------------

-- 5.1 ML functors

-- ML family (Standard ML, OCaml) provide "functors" which allow
-- writing functions from modules of one signature to modules of another signature.

-- functors = allow "lifting" of code int othe module language
-- Deriving Via = allow lifting of code into GHC's deriving construct.

-- 5.2 Explicit dictionary passing

-- This is more powerful than Deriving Via
-- This would allow users to actually cocerte concrete instance values
-- and pas them around as first-class values.

-----------------------------------------------
-- 6. Current status
-----------------------------------------------

-- Interacts well with:
--   * kind polymorphism
--   * StandaloneDeriving
--   * type classes with associated type families

-- 6.1 Quality of error messages

-- Error messages may be confusing as they are from generated code.
-- But GHC has put effort on making type errors involving Coercible easy to understand.

-- 6.2 Multi-Parameter Type Classes

-----------------------------------------------
-- 7. Conclusions
-----------------------------------------------

-- Deriving Via rocks.