wip, spin-off gists: https://gist.github.com/Icelandjack/e42495341f6029aad8c7e4e4a12c34ce
Monad
gives Applicative
, Applicative
etc. gives Num
, Floating
, Fractional
(regardless of actual subclass relationship)
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
(The uninteresting monoids of certain monads are just WrapApplicative
and Alt
)
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)
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
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 newtype
Show
deriving as WrappedShow Void
IsZero
newtype VOID = VOID Void
deriving as WrappedNumEq Int
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
From monoid-subclasses
class Monoid m => MonoidNull m where
null :: m -> Bool
newtype WrpMonNull a = WMN a
instance Monoid a => MonoidNull (WrpMonNull a) where
null :: WrpMonNull a -> bool
null (WMN a) = a == mempty
deriving via WrpMonNull () instance MonoidNull ()
deriving via WrpMonNull Ordering instance MonoidNull Ordering
deriving via WrpMonNull Any instance MonoidNull Any
Actual example where we want multiple default methods
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)
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)
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):
"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
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)
-- 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
#define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
(.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
(.-^) = (^-^) ; {-# INLINE (.-^) #-}
#define ADDITIVE(T) ADDITIVEC((), T)
#define id_TestData(ty) \
instance TestData ty where { \
type Model ty = ty; \
model = id; \
unmodel = id; \
\
type EqTest ty = Property; \
equal x y = property (x == y) }
id_TestData(())
id_TestData(Bool)
id_TestData(Int)
id_TestData(Float)
id_TestData(Double)
id_TestData(Ordering)
#define mkLattice_(x)\
instance Lattice_ x where \
sup = (P.max) ;\
(>=) = (P.>=) ;\
(>) = (P.>) ;\
{-# INLINE sup #-} ;\
{-# INLINE (>=) #-} ;\
{-# INLINE (>) #-}
mkLattice_(Bool)
mkLattice_(Char)
mkLattice_(Int)
mkLattice_(Integer)
mkLattice_(Float)
mkLattice_(Double)
mkLattice_(Rational)
Not too elegantly though, since it requires defining some ad-hoc subset of things with new names but it's a some solution at least.
class OrdShowArb a where
cmp :: a -> a -> Ordering
shw :: a -> String
arb :: Gen a
instance OrdShowArb Int where
cmp :: Int -> Int -> Ordering
cmp = compare
shw :: Int -> String
shw = show
arb :: Gen Int
arb = arbitrary
newtype WrappedOrdShowArb a = WrappedOrdShowArb a
deriving OrdShowArb
instance OrdShowArb a => Eq (WrappedOrdShowArb a) where
a == b = compare a b == EQ
instance OrdShowArb a => Ord (WrappedOrdShowArb a) where
compare = cmp
instance OrdShowArb a => Show (WrappedOrdShowArb a) where
show a = "default: " ++ shw a
instance OrdShowArb a => Arbitrary (WrappedOrdShowArb a) where
arbitrary = arb
So now I hope to write
data A = A
deriving (Eq, Ord, Show)
via OrdShowArb A
instance OrdShowArb A where
cmp :: A -> A -> Ordering
cmp A A = EQ
shw :: A -> String
shw A = "A"
arb :: Gen A
arb = pure A
newtype FOO = FOO (WrappedOrdShowArb Int)
deriving (Eq, Show, Ord, Arbitrary)
Holy crap I don't want to define these instances, from Tower.Multiplicative
class MultiplicativeMagma a where times :: a -> a -> a
class MultiplicativeMagma a => MultiplicativeUnital a where one :: a
class MultiplicativeMagma a => MultiplicativeCommutative a
class MultiplicativeMagma a => MultiplicativeAssociative a
class MultiplicativeMagma a => MultiplicativeInvertible a where recip :: a -> a
class (MultiplicativeUnital a , MultiplicativeAssociative a) => MultiplicativeMonoidal a
class (MultiplicativeCommutative a , MultiplicativeUnital a , MultiplicativeAssociative a) => Multiplicative a where
infixl 7 *
(*) :: a -> a -> a
a * b = times a b
class (MultiplicativeUnital a , MultiplicativeAssociative a , MultiplicativeInvertible a) => MultiplicativeLeftCancellative a where
infixl 7 ~/
(~/) :: a -> a -> a
a ~/ b = A.recip b `times` a
class (MultiplicativeUnital a , MultiplicativeAssociative a , MultiplicativeInvertible a) => MultiplicativeRightCancellative a where
infixl 7 /~
(/~) :: a -> a -> a
a /~ b = a `times` A.recip b
class ( Multiplicative a , MultiplicativeInvertible a) => MultiplicativeGroup a where
infixl 7 /
(/) :: a -> a -> a
a / b = a `times` A.recip b
we would define
class EVERYTHING a where
times_ :: a -> a -> a
one_ :: a
recip_ :: a -> a
(*%) :: a -> a -> a
(*%) = times_
(~/%) :: a -> a -> a
a~/%b = recip_ a `times_` b
(/~%) :: a -> a -> a
a/~%b = a `times_` recip_ b
(/%) :: a -> a -> a
a/%b = a `times_` recip_ b
newtype WrapEVERYTHING a = WrapEVERYTHING a
deriving EVERYTHING
instance EVERYTHING a => MultiplicativeMagma (WrapEVERYTHING a) where times = times_
instance EVERYTHING a => MultiplicativeUnital (WrapEVERYTHING a) where one = one_
instance EVERYTHING a => MultiplicativeCommutative (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeAssociative (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeInvertible (WrapEVERYTHING a) where recip = recip_
instance EVERYTHING a => MultiplicativeMonoidal (WrapEVERYTHING a)
instance EVERYTHING a => Multiplicative (WrapEVERYTHING a) where (*) = (*%)
instance EVERYTHING a => MultiplicativeLeftCancellative (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeRightCancellative (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeGroup (WrapEVERYTHING a)
and then you can derive all them classes, from defining a single instance
instance EVERYTHING Double where
times_ :: Num a => a -> a -> a
times_ = (Prelude.*)
one_ :: Num a => a
one_ = 1
recip_ :: Fractional a => a -> a
recip_ = Prelude.recip
newtype Y = Y Double
deriving
( MultiplicativeMagma, MultiplicativeUnital, MultiplicativeCommutative
, MultiplicativeAssociative, MultiplicativeInvertible, MultiplicativeMonoidal
, Multiplicative, MultiplicativeLeftCancellative, MultiplicativeRightCancellative)
via WrapEVERYTHING Double
and in fact EVERYTHING
could itself be defined for all Fractional
instance Fractional a => EVERYTHING a where
times_ = (Prelude.*)
one_ = 1
recip_ = Prelude.recip
so we'd have to write a new newtype
for this? Fun we could even derive
import Debug.SimpleReflect
newtype SR = SR Expr
deriving (MultiplicativeGroup)
via WrapFractionalEVERYTHING Expr
deriving
( MultiplicativeMagma, MultiplicativeUnital, MultiplicativeCommutative
, MultiplicativeAssociative, MultiplicativeInvertible, MultiplicativeMonoidal
, Multiplicative, MultiplicativeLeftCancellative, MultiplicativeRightCancellative)
via WrapEVERYTHING Expr
Let me invent syntax for "joining" together methods of two classes
instance (Ord & Show & Arbitrary) A where
compare :: A -> A -> Ordering
compare A A = EQ
show :: A -> String
show A = "A"
arbitrary :: Gen A
arb = pure A
instance (Ord & Show & Arbitrary) a => Eq (WrappedOrdShowArb a) where
a == b = compare a b == EQ
instance (Ord & Show & Arbitrary) a => Ord (WrappedOrdShowArb a) where
compare = cmp
instance (Ord & Show & Arbitrary) a => Show (WrappedOrdShowArb a) where
show a = "default: " ++ shw a
instance (Ord & Show & Arbitrary) a => Arbitrary (WrappedOrdShowArb a) where
arbitrary = arb
from
https://bitbucket.org/kztk/app-lens/src/83376a9b25bc483c65776db48b33593601d274bd/Control/LensFunction/Core.hs?at=master&fileviewer=file-view-default
from
http://www2.sf.ecei.tohoku.ac.jp/~kztk/papers/kztk_jfp_am_2018.pdf (Applicative Bidirectional Programming: Mixing Lenses and Semantic Bidirectionalization)