{-# LANGUAGE
AllowAmbiguousTypes,
DataKinds,
DerivingVia,
FlexibleContexts,
FlexibleInstances,
MonoLocalBinds,
MultiParamTypeClasses,
PolyKinds,
QuantifiedConstraints,
RankNTypes,
ScopedTypeVariables,
StandaloneKindSignatures,
TypeAbstractions,
TypeFamilies,
TypeOperators,
TypeApplications,
UndecidableInstances #-}
-- | Deriving via first-class functions.
--
-- See the [README](https://hackage.haskell.org/package/deriving-via-fun#readme) for details.
--
-- = Examples
--
-- > data T0 = T0 Int Bool
-- > deriving Generic
-- > deriving (Eq, Ord) via Fun (T0 ?-> (Int, Bool))
-- > deriving (Semigroup, Monoid) via Fun (T0 ?-> (Sum Int, Any))
--
-- > newtype All = All Bool
-- > deriving (Semigroup, Monoid)
-- > via Fun (Coerce All Bool >>> Not >>> Coerce Bool Any)
--
-- > data T1 a = T1 [a] a
-- > deriving Generic
-- > deriving (Functor, Applicative, Monad, Foldable) via Fun1 (T1 ?-> Product [] Identity)
--
-- = Extensions to use this library
--
-- > {-# LANGUAGE DerivingVia, TypeOperators #-}
--
-- To use the generic isomorphism @t'(DerivingViaFun.?->)'@, you will also want
--
-- > {-# LANGUAGE DeriveGeneric #-}
module DerivingViaFun
(
-- * Basic features
Fun(..)
, fun
, unfun
, GenericIso
, type (?->)
, Coerce
-- * Core definitions
, FUN
, type (~>)
, Apply(..)
, Inv
, Iso
-- * Simple function names
, Id
, type (.)
, type (>>>)
, Fst
, Snd
, Pair
, Fmap
, Bimap
, Not
, Adhoc
-- * Higher-kinded types
, Fun1(..)
, fun1
, unfun1
, Apply1
, Iso1
, TApply
, Apply1_
) where
import Control.Applicative (Alternative(..))
import Control.Monad.Fix (MonadFix(..))
import Data.Bifunctor (Bifunctor(first, bimap))
import Data.Bits (Bits(..))
import Data.Coerce (Coercible, coerce)
import Data.Foldable (Foldable(..))
import Data.Function (on)
import Data.Ix (Ix(..))
import Data.Kind (Constraint, Type)
import Data.Semigroup (Semigroup(..))
import Foreign (Storable(..), castPtr)
import GHC.Generics (Generic(..))
import Text.Read (Read(..))
-- | @DerivingVia@ wrapper for "deriving via a function".
--
-- A @Fun (f :: a ~> b)@ is a value of type @a@ which
-- may be viewed as a @b@ through the function @f@.
--
-- The 'fun' constructor and 'unfun' destructor automatically
-- "apply @f@" in the suitable direction, using an instance
-- @'Apply' f@ or @'Apply' ('Inv' f)@.
--
-- == Usage
--
-- @
-- __data__ MyType
-- __deriving__ MyClass __via__ t'Fun' MyFun
-- @
--
-- Note that @MyFun@ may need a type annotation,
-- as in @Fun (MyFun :: MyType ~> OtherType)@,
-- because the types often can't be inferred.
newtype Fun (f :: a ~> b) = Fun a
-- | Destruct t'Fun'.
unfun :: forall {a} {b} (f :: a ~> b). Apply f => Fun f -> b
unfun (Fun a) = apply @f a
-- | Construct t'Fun'.
fun :: forall {a} {b} (f :: a ~> b). Apply (Inv f) => b -> Fun f
fun b = Fun (apply @(Inv f) b)
-- |
-- @
-- GenericIso :: a ~> b
-- @
-- 'Generic' isomorphism.
--
-- @GenericIso :: a ~> b@ maps between 'Generic' types @a@ and @b@
-- where @'Rep' a@ is coercible to @'Rep' b@. It is invertible.
data GenericIso :: a ~> b
-- |
-- @
-- a ?-> b = 'GenericIso' :: a ~> b
-- @
--
-- Shorthand for @'GenericIso' :: a ~> b@.
type (?->) :: forall {k}. forall (a :: k) (b :: k) -> a ~> b
type a ?-> b = GenericIso
infix 1 ?->
type instance Inv GenericIso = GenericIso
type instance TApply GenericIso _ = GenericIso
instance (Generic a, Generic b, Coercible (Rep a) (Rep b))
=> Apply (a ?-> b) where
apply = to @b @() . coerce . from @a @()
-- |
-- @
-- Coerce a b :: a ~> b
-- @
-- Type-level name for 'coerce'.
data Coerce a b :: a ~> b
instance Coercible a b => Apply (Coerce a b) where
apply = coerce
type instance Inv (Coerce a b) = Coerce b a
type instance TApply (Coerce a b) x = Coerce (a x) (b x)
-- | An implementation detail of @t'(DerivingViaFun.~>)'@.
--
-- If you see @FUN@ in kind signatures in the documentation,
-- that's because Haddock messed up.
-- In those cases, the morally correct kind signature
-- is provided below.
--
-- This allows @(~>)@ to be poly-kinded.
data FUN (a :: k) (b :: k)
-- | An extensible kind of type-level function names.
--
-- Think of this as an abstract kind.
-- The right-hand side of this definition is an
-- implementation detail.
--
-- Function names are declared as data types. For example:
--
-- > data Not :: Bool -> Bool
--
-- 'Apply' instances associate function names to actual functions:
--
-- > instance Apply Not where
-- > apply = not
--
-- 'Inv' instances associate function names to their inverse:
--
-- > type instance Inv Not = Not
--
-- @(~>)@ is poly-kinded and is intended to represent
-- morphisms of any kind. This library provides facilities
-- for kinds @Type@ (t'Fun') and @k -> Type@ (t'Fun1').
type a ~> b = FUN a b -> Type
infixr 1 ~>
-- | Class of applicable function names.
--
-- Interpret a type-level function name @f :: a ~> b@
-- as an actual function @'apply' \@f :: a -> b@.
type Apply :: forall {a :: Type} {b :: Type}. (a ~> b) -> Constraint
class Apply (f :: a ~> b) where
apply :: a -> b
-- |
-- @
-- Inv :: (a ~> b) -> (b ~> a)
-- @
--
-- Inverse function name.
--
-- == Laws
--
-- Instances of @'Apply' f@ and @'Apply' (Inv f)@ must satisfy the isomorphism laws:
--
-- @
-- 'apply' \@f . 'apply' \@(Inv f) = id
-- 'apply' \@(Inv f) . 'apply' \@f = id
-- @
type family Inv (f :: (a ~> b)) :: (b ~> a)
-- | Class of invertible function names.
--
-- @Iso f@ means that both @'apply' \@f@ and @'apply' \@(Inv f)@ are defined.
type Iso :: forall {a :: Type} {b :: Type}. (a ~> b) -> Constraint
class (Apply f, Apply (Inv f)) => Iso f
instance (Apply f, Apply (Inv f)) => Iso f
-- * Simple functions
-- |
-- @
-- Id :: a ~> a
-- @
--
-- Identity function.
data Id :: a ~> a
instance Apply Id where
apply = id
type instance Inv Id = Id
type instance TApply Id _ = Id
-- |
-- @
-- (.) :: (b ~> c) -> (a ~> b) -> (a ~> c)
-- @
--
-- Function composition.
data (.) :: forall {a} {b} {c}. (b ~> c) -> (a ~> b) -> (a ~> c)
infixr 9 .
instance (Apply f, Apply g) => Apply (f . g) where
apply = apply @f . apply @g
type instance Inv (f . g) = Inv g . Inv f
type instance TApply (f . g) a = TApply f a . TApply g a
-- |
-- @
-- (>>>) :: (a ~> b) -> (b ~> c) -> (a ~> c)
-- @
--
-- Forward function composition.
--
-- The name originates from "Control.Category".
type f >>> g = g . f
infixr 1 >>>
-- |
-- @
-- Fst :: (a, b) ~> a
-- @
--
-- First pair projection.
data Fst :: (a, b) ~> a
instance Apply Fst where
apply = fst
-- |
-- @
-- Snd :: (a, b) ~> b
-- @
--
-- Second pair projection.
data Snd :: (a, b) ~> b
instance Apply Snd where
apply = snd
-- |
-- @
-- Pair :: (a ~> b) -> (a ~> c) -> (a ~> (b, c))
-- @
--
-- Pointwise pairing of two functions.
--
-- To map on the components of a pair independently, see 'Bimap'.
data Pair :: (a ~> b) -> (a ~> c) -> (a ~> (b, c))
instance (Apply f, Apply g) => Apply (Pair f g) where
apply a = (apply @f a, apply @g a)
-- |
-- @
-- Fmap :: (a ~> b) -> (p a ~> p b)
-- @
--
-- Apply a function under a functor ('fmap').
data Fmap :: forall {p} {a} {b}. (a ~> b) -> (p a ~> p b)
instance (Apply f, Functor p) => Apply (Fmap f :: p a ~> p b) where
apply = fmap (apply @f)
type instance Inv (Fmap f) = Fmap (Inv f)
type instance TApply (Fmap f) _ = Bimap f Id
-- |
-- @
-- Bimap :: (a ~> b) -> (c ~> d) -> (p a c ~> p b d)
-- @
--
-- Apply a function under a bifunctor ('bimap').
data Bimap :: forall {p} {a} {b} {c} {d}. (a ~> b) -> (c ~> d) -> (p a c ~> p b d)
instance (Apply f, Apply g, Bifunctor p) => Apply (Bimap f g :: p a c ~> p b d) where
apply = bimap (apply @f) (apply @g)
type instance Inv (Bimap f g) = Bimap (Inv f) (Inv g)
-- |
-- @
-- Not :: Bool ~> Bool
-- @
--
-- Boolean negation.
data Not :: Bool ~> Bool
instance Apply Not where
apply = not
type instance Inv Not = Not
-- |
-- @
-- Adhoc a b :: a ~> b
-- @
--
-- Function name with /ad hoc/ interpretations.
--
-- You can define instances of @'Apply' (Adhoc a b)@
-- as long as at least one of @a@ or @b@ is a concrete type that you own
-- (to avoid orphan instances).
--
-- This allows imitating the usage of [/iso-deriving/](https://hackage.haskell.org/package/iso-deriving),
-- a similar deriving-via library.
--
-- - /iso-deriving/'s @As a b@ newtype corresponds to @t'Fun' (Adhoc a b)@.
-- - /iso-deriving/'s @Project a b@ and @Inject a b@ instances correspond to @'Apply' (Adhoc a b)@ (they are fused into one for simplicity).
data Adhoc a b :: a ~> b
type instance Inv (Adhoc a b) = Adhoc b a
type instance TApply (Adhoc a b) x = Adhoc (a x) (b x)
-- * Higher-kinded types
-- | @DerivingVia@ wrapper for "deriving via indexed functions".
--
-- This is the indexed version of t'Fun'.
-- Use @Fun1@ to derive higher-kinded classes like
-- 'Functor', 'Applicative', 'Monad', 'Foldable'.
--
-- Function names intended to work with this should most likely
-- implement type family instances of 'TApply'.
type Fun1 :: forall {k} (p :: k -> Type) (q :: k -> Type). (p ~> q) -> k -> Type
newtype Fun1 @p @q (f :: p ~> q) a = Fun1 (p a)
-- | Destruct t'Fun1'.
unfun1 :: forall {p} {q} (f :: p ~> q) a. Apply1 f => Fun1 f a -> q a
unfun1 (Fun1 p) = apply @(TApply f a) p
-- | Construct t'Fun1'.
fun1 :: forall {p} {q} (f :: p ~> q) a. Apply1 (Inv f) => q a -> Fun1 f a
fun1 q = Fun1 (apply @(TApply (Inv f) a) q)
-- |
-- @
-- TApply (f :: p ~> q) :: p a ~> q a
-- @
--
-- Type application for indexed function names.
type family TApply (f :: p ~> q) (a :: k) :: p a ~> q a
-- | Implementation detail of 'Apply1'.
class Apply (TApply f a) => Apply1_ (f :: p ~> q) a
instance Apply (TApply f a) => Apply1_ (f :: p ~> q) a
-- | Class of applicable indexed functions.
--
-- These are polymorphic functions of type @forall a. p a -> q a@.
class (forall a. Apply1_ f a) => Apply1 f
instance (forall a. Apply1_ f a) => Apply1 f
-- | Class of indexed isomorphisms.
class (Apply1 f, Apply1 (Inv f)) => Iso1 f
instance (Apply1 f, Apply1 (Inv f)) => Iso1 f
-- * Instances
instance (Apply f, Eq b) => Eq (Fun (f :: a ~> b)) where
(==) = (==) `on` unfun
instance (Apply f, Ord b) => Ord (Fun (f :: a ~> b)) where
compare = compare `on` unfun
(<=) = (<=) `on` unfun
(>=) = (>=) `on` unfun
(>) = (>) `on` unfun
(<) = (<) `on` unfun
instance (Apply (Inv f), Bounded b) => Bounded (Fun (f :: a ~> b)) where
minBound = fun minBound
maxBound = fun maxBound
instance (Iso f, Enum b) => Enum (Fun (f :: a ~> b)) where
succ = fun . succ . unfun
pred = fun . pred . unfun
toEnum = fun . toEnum
fromEnum = fromEnum . unfun
enumFrom = fmap fun . enumFrom . unfun
enumFromThen x y = fmap fun (enumFromThen (unfun x) (unfun y))
enumFromTo x y = fmap fun (enumFromTo (unfun x) (unfun y))
enumFromThenTo x y z = fmap fun (enumFromThenTo (unfun x) (unfun y) (unfun z))
instance (Iso f, Ix b) => Ix (Fun (f :: a ~> b)) where
range (x, y) = fmap fun (range (unfun x, unfun y))
index (x, y) = index (unfun x, unfun y) . unfun
inRange (x, y) = inRange (unfun x, unfun y) . unfun
rangeSize (x, y) = rangeSize (unfun x, unfun y)
instance (Iso f, Semigroup b) => Semigroup (Fun (f :: a ~> b)) where
x <> y = fun (unfun x <> unfun y)
sconcat = fun . sconcat . fmap unfun
instance (Iso f, Monoid b, Semigroup a) => Monoid (Fun (f :: a ~> b)) where
mempty = fun mempty
mappend (Fun x) (Fun y) = Fun (x <> y)
mconcat = fun . mconcat . fmap unfun
instance (Iso f, Num b) => Num (Fun (f :: a ~> b)) where
x + y = fun (unfun x + unfun y)
x - y = fun (unfun x - unfun y)
x * y = fun (unfun x * unfun y)
negate = fun . negate . unfun
abs = fun . abs . unfun
signum = fun . signum . unfun
fromInteger = fun . fromInteger
instance (Iso f, Real b) => Real (Fun (f :: a ~> b)) where
toRational = toRational . unfun
instance (Iso f, Integral b) => Integral (Fun (f :: a ~> b)) where
quot x y = fun (quot (unfun x) (unfun y))
rem x y = fun (rem (unfun x) (unfun y))
div x y = fun (div (unfun x) (unfun y))
mod x y = fun (mod (unfun x) (unfun y))
quotRem x y = bimap fun fun (quotRem (unfun x) (unfun y))
divMod x y = bimap fun fun (divMod (unfun x) (unfun y))
toInteger = toInteger . unfun
instance (Iso f, Fractional b) => Fractional (Fun (f :: a ~> b)) where
x / y = fun (unfun x / unfun y)
recip = fun . recip . unfun
fromRational = fun . fromRational
instance (Iso f, Floating b) => Floating (Fun (f :: a ~> b)) where
pi = fun pi
exp = fun . exp . unfun
log = fun . log . unfun
sqrt = fun . sqrt . unfun
x ** y = fun (unfun x ** unfun y)
logBase x y = fun (logBase (unfun x) (unfun y))
sin = fun . sin . unfun
cos = fun . cos . unfun
tan = fun . tan . unfun
asin = fun . asin . unfun
acos = fun . acos . unfun
atan = fun . atan . unfun
sinh = fun . sinh . unfun
cosh = fun . cosh . unfun
tanh = fun . tanh . unfun
asinh = fun . asinh . unfun
acosh = fun . acosh . unfun
atanh = fun . atanh . unfun
instance (Iso f, RealFrac b) => RealFrac (Fun (f :: a ~> b)) where
properFraction = fmap fun . properFraction . unfun
truncate = truncate . unfun
round = round . unfun
ceiling = ceiling . unfun
floor = floor . unfun
instance (Iso f, RealFloat b) => RealFloat (Fun (f :: a ~> b)) where
floatRadix = floatRadix . unfun
floatDigits = floatDigits . unfun
floatRange = floatRange . unfun
decodeFloat = decodeFloat . unfun
encodeFloat = fmap fun . encodeFloat
exponent = exponent . unfun
significand = fun . significand . unfun
scaleFloat n = fun . scaleFloat n . unfun
isNaN = isNaN . unfun
isInfinite = isInfinite . unfun
isDenormalized = isDenormalized . unfun
isNegativeZero = isNegativeZero . unfun
isIEEE = isIEEE . unfun
atan2 x y = fun (atan2 (unfun x) (unfun y))
instance (Iso f, Bits b) => Bits (Fun (f :: a ~> b)) where
x .&. y = fun (unfun x .&. unfun y)
x .|. y = fun (unfun x .|. unfun y)
x `xor` y = fun (unfun x `xor` unfun y)
complement = fun . complement . unfun
shift = fmap fun . shift . unfun
rotate = fmap fun . rotate . unfun
zeroBits = fun zeroBits
bit = fun . bit
setBit = fmap fun . setBit . unfun
clearBit = fmap fun . clearBit . unfun
complementBit = fmap fun . complementBit . unfun
testBit = testBit . unfun
bitSizeMaybe = bitSizeMaybe . unfun
isSigned = isSigned . unfun
shiftL = fmap fun . shiftL . unfun
unsafeShiftL = fmap fun . unsafeShiftL . unfun
shiftR = fmap fun . shiftR . unfun
unsafeShiftR = fmap fun . unsafeShiftR . unfun
rotateL = fmap fun . rotateL . unfun
rotateR = fmap fun . rotateR . unfun
popCount = popCount . unfun
bitSize = bitSize . unfun
instance (Iso f, Storable b) => Storable (Fun (f :: a ~> b)) where
sizeOf = sizeOf . unfun
alignment = alignment . unfun
peekElemOff ptr = fmap fun . peekElemOff (castPtr ptr)
pokeElemOff ptr n = pokeElemOff (castPtr ptr) n . unfun
peekByteOff ptr = fmap fun . peekByteOff (castPtr ptr)
pokeByteOff ptr n = pokeByteOff (castPtr ptr) n . unfun
peek = fmap fun . peek . castPtr
poke ptr = poke (castPtr ptr) . unfun
instance (Apply f, Show b) => Show (Fun (f :: a ~> b)) where
showsPrec d = showsPrec d . unfun
show = show . unfun
instance (Apply (Inv f), Read b) => Read (Fun (f :: a ~> b)) where
readsPrec = (fmap . fmap . fmap . first) fun readsPrec
readList = (fmap . fmap . first . fmap) fun readList
readPrec = fmap fun readPrec
readListPrec = (fmap . fmap) fun readListPrec
instance (Iso1 f, Functor q) => Functor (Fun1 (f :: p ~> q)) where
fmap m = fun1 . fmap m . unfun1
(<$) x = fun1 . (<$) x . unfun1
instance (Iso1 f, Applicative q) => Applicative (Fun1 (f :: p ~> q)) where
pure = fun1 . pure
u <*> v = fun1 (unfun1 u <*> unfun1 v)
liftA2 m u v = fun1 (liftA2 m (unfun1 u) (unfun1 v))
u <* v = fun1 (unfun1 u <* unfun1 v)
u *> v = fun1 (unfun1 u *> unfun1 v)
instance (Iso1 f, Alternative q) => Alternative (Fun1 (f :: p ~> q)) where
empty = fun1 empty
u <|> v = fun1 (unfun1 u <|> unfun1 v)
some = fun1 . some . unfun1
many = fun1 . many . unfun1
-- | This uses the @Applicative@ instance of the source type to define `return`.
instance (Iso1 f, Monad q, Applicative p) => Monad (Fun1 (f :: p ~> q)) where
return = Fun1 . pure
u >>= v = fun1 (unfun1 u >>= unfun1 . v)
u >> v = fun1 (unfun1 u >> unfun1 v)
instance (Iso1 f, MonadFail q, Applicative p) => MonadFail (Fun1 (f :: p ~> q)) where
fail = fun1 . fail
instance (Iso1 f, MonadFix q, Applicative p) => MonadFix (Fun1 (f :: p ~> q)) where
mfix f = fun1 (mfix (unfun1 . f))
instance (Apply1 f, Foldable q) => Foldable (Fun1 (f :: p ~> q)) where
fold = fold . unfun1
foldMap f = foldMap f . unfun1
foldMap' f = foldMap' f . unfun1
foldr f x = foldr f x . unfun1
foldl f x = foldl f x . unfun1
foldl' f x = foldl' f x . unfun1
foldr1 f = foldr1 f . unfun1
foldl1 f = foldl1 f . unfun1
toList = toList . unfun1
null = null . unfun1
length = length . unfun1
elem x = elem x . unfun1
maximum = maximum . unfun1
minimum = minimum . unfun1
sum = sum . unfun1
product = product . unfun1
instance (Iso1 f, Traversable q) => Traversable (Fun1 (f :: p ~> q)) where
traverse f = fmap fun1 . traverse f . unfun1
sequenceA = fmap fun1 . sequenceA . unfun1
mapM f = fmap fun1 . mapM f . unfun1
sequence = fmap fun1 . sequence . unfun1