1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE DerivingVia #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE InstanceSigs #-}
8{-# LANGUAGE TypeInType #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE ConstraintKinds #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE MultiWayIf #-}
14{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE FlexibleInstances #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE UndecidableInstances #-}
20module DerivingVia where
21
22import Data.Void
23import Data.Complex
24import Data.Functor.Const
25import Data.Functor.Identity
26import Data.Ratio
27import Control.Monad.Reader
28import Control.Monad.State
29import Control.Monad.Writer
30import Control.Applicative hiding (WrappedMonad(..))
31
32import Data.Bifunctor
33import Data.Monoid
34import Data.Kind
35
36type f ~> g = forall xx. f xx -> g xx
37
38-----
39-- Simple example
40-----
41
42data Foo a = MkFoo a a
43  deriving Show
44       via (Identity (Foo a))
45
46-----
47-- Eta reduction at work
48-----
49
50newtype Flip p a b = Flip { runFlip :: p b a }
51
52instance Bifunctor p => Bifunctor (Flip p) where
53  bimap f g = Flip . bimap g f . runFlip
54
55instance Bifunctor p => Functor (Flip p a) where
56  fmap f = Flip . first f . runFlip
57
58newtype Bar a = MkBar (Either a Int)
59  deriving Functor
60       via (Flip Either Int)
61
62-----
63-- Monad transformers
64-----
65
66type MTrans = (Type -> Type) -> (Type -> Type)
67
68-- From `constraints'
69data Dict c where
70  Dict :: c => Dict c
71
72newtype a :- b = Sub (a => Dict b)
73
74infixl 1 \\
75(\\) :: a => (b => r) -> (a :- b) -> r
76r \\ Sub Dict = r
77
78-- With `-XQuantifiedConstraints' this just becomes
79--
80--    type Lifting cls  trans = forall mm. cls mm => cls (trans mm)
81--
82--    type LiftingMonad trans = Lifting Monad trans
83--
84class LiftingMonad (trans :: MTrans) where
85  proof :: Monad m :- Monad (trans m)
86
87instance LiftingMonad (StateT s :: MTrans) where
88  proof :: Monad m :- Monad (StateT s m)
89  proof = Sub Dict
90
91instance Monoid w => LiftingMonad (WriterT w :: MTrans) where
92  proof :: Monad m :- Monad (WriterT w m)
93  proof = Sub Dict
94
95instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where
96  proof :: forall m. Monad m :- Monad (ComposeT trans trans' m)
97  proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m)
98
99newtype Stack :: MTrans where
100  Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a
101  deriving newtype
102    ( Functor
103    , Applicative
104    , Monad
105    , MonadReader Int
106    , MonadState Bool
107    , MonadWriter String
108    )
109  deriving (MonadTrans, MFunctor)
110       via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String)
111
112class MFunctor (trans :: MTrans) where
113  hoist :: Monad m => (m ~> m') -> (trans m ~> trans m')
114
115instance MFunctor (ReaderT r :: MTrans) where
116  hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m')
117  hoist nat = ReaderT . fmap nat . runReaderT
118
119instance MFunctor (StateT s :: MTrans) where
120  hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m')
121  hoist nat = StateT . fmap nat . runStateT
122
123instance MFunctor (WriterT w :: MTrans) where
124  hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m')
125  hoist nat = WriterT . nat . runWriterT
126
127infixr 9 `ComposeT`
128newtype ComposeT :: MTrans -> MTrans -> MTrans where
129  ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a
130  deriving newtype (Functor, Applicative, Monad)
131
132instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where
133  lift :: forall m. Monad m => m ~> ComposeT f g m
134  lift = ComposeT . lift . lift
135    \\ proof @g @m
136
137instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where
138  hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m')
139  hoist f = ComposeT . hoist (hoist f) . getComposeT
140    \\ proof @g @m
141
142-----
143-- Using tuples in a `via` type
144-----
145
146newtype X a = X (a, a)
147  deriving (Semigroup, Monoid)
148       via (Product a, Sum a)
149
150  deriving (Show, Eq)
151       via (a, a)
152
153-----
154-- Abstract data types
155-----
156
157class C f where
158  c :: f a -> Int
159
160newtype X2 f a = X2 (f a)
161
162instance C (X2 f) where
163  c = const 0
164
165deriving via (X2 IO) instance C IO
166
167----
168-- Testing parser
169----
170
171newtype P0 a = P0 a             deriving Show via a
172newtype P1 a = P1 [a]           deriving Show via [a]
173newtype P2 a = P2 (a, a)        deriving Show via (a, a)
174newtype P3 a = P3 (Maybe a)     deriving Show via (First a)
175newtype P4 a = P4 (Maybe a)     deriving Show via (First $ a)
176newtype P5 a = P5 a             deriving Show via (Identity $ a)
177newtype P6 a = P6 [a]           deriving Show via ([] $ a)
178newtype P7 a = P7 (a, a)        deriving Show via (Identity $ (a, a))
179newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ()))
180
181newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor
182
183----
184-- From Baldur's notes
185----
186
187----
188-- 1
189----
190newtype WrapApplicative f a = WrappedApplicative (f a)
191  deriving (Functor, Applicative)
192
193instance (Applicative f, Num a) => Num (WrapApplicative f a) where
194  (+)         = liftA2 (+)
195  (*)         = liftA2 (*)
196  negate      = fmap negate
197  fromInteger = pure . fromInteger
198  abs         = fmap abs
199  signum      = fmap signum
200
201instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
202  recip        = fmap recip
203  fromRational = pure . fromRational
204
205instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where
206  pi    = pure pi
207  sqrt  = fmap sqrt
208  exp   = fmap exp
209  log   = fmap log
210  sin   = fmap sin
211  cos   = fmap cos
212  asin  = fmap asin
213  atan  = fmap atan
214  acos  = fmap acos
215  sinh  = fmap sinh
216  cosh  = fmap cosh
217  asinh = fmap asinh
218  atanh = fmap atanh
219  acosh = fmap acosh
220
221instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
222  (<>) = liftA2 (<>)
223
224instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
225  mempty = pure mempty
226
227----
228-- 2
229----
230class Pointed p where
231  pointed :: a -> p a
232
233newtype WrapMonad f a = WrappedMonad (f a)
234  deriving newtype (Pointed, Monad)
235
236instance (Monad m, Pointed m) => Functor (WrapMonad m) where
237  fmap = liftM
238
239instance (Monad m, Pointed m) => Applicative (WrapMonad m) where
240  pure  = pointed
241  (<*>) = ap
242
243-- data
244data Sorted a = Sorted a a a
245  deriving (Functor, Applicative)
246    via (WrapMonad Sorted)
247  deriving (Num, Fractional, Floating, Semigroup, Monoid)
248    via (WrapApplicative Sorted a)
249
250
251instance Monad Sorted where
252  (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
253  Sorted a b c >>= f = Sorted a' b' c' where
254    Sorted a' _  _  = f a
255    Sorted _  b' _  = f b
256    Sorted _  _  c' = f c
257
258instance Pointed Sorted where
259  pointed :: a -> Sorted a
260  pointed a = Sorted a a a
261
262----
263-- 3
264----
265class IsZero a where
266  isZero :: a -> Bool
267
268newtype WrappedNumEq  a = WrappedNumEq a
269newtype WrappedShow   a = WrappedShow  a
270newtype WrappedNumEq2 a = WrappedNumEq2 a
271
272instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
273  isZero :: WrappedNumEq a -> Bool
274  isZero (WrappedNumEq a) = 0 == a
275
276instance Show a => IsZero (WrappedShow a) where
277  isZero :: WrappedShow a -> Bool
278  isZero (WrappedShow a) = "0" == show a
279
280instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
281  isZero :: WrappedNumEq2 a -> Bool
282  isZero (WrappedNumEq2 a) = a + a == a
283
284newtype INT = INT Int
285  deriving newtype Show
286  deriving IsZero via (WrappedNumEq Int)
287
288newtype VOID = VOID Void deriving IsZero via (WrappedShow Void)
289
290----
291-- 4
292----
293class Bifunctor p => Biapplicative p where
294  bipure :: a -> b -> p a b
295
296  biliftA2
297    :: (a  -> b  -> c)
298    -> (a' -> b' -> c')
299    -> p a a'
300    -> p b b'
301    -> p c c'
302
303instance Biapplicative (,) where
304  bipure = (,)
305
306  biliftA2 f f' (a, a') (b, b') =
307    (f a b, f' a' b')
308
309newtype WrapBiapp p a b = WrapBiap (p a b)
310  deriving newtype (Bifunctor, Biapplicative, Eq)
311
312instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where
313  (+) = biliftA2 (+) (+)
314  (-) = biliftA2 (*) (*)
315  (*) = biliftA2 (*) (*)
316  negate = bimap negate negate
317  abs = bimap abs abs
318  signum = bimap signum signum
319  fromInteger n = fromInteger n `bipure` fromInteger n
320
321newtype INT2 = INT2 (Int, Int)
322  deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int))
323
324----
325-- 5
326----
327class Monoid a => MonoidNull a where
328  null :: a -> Bool
329
330newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid)
331
332instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where
333  null :: WrpMonNull a -> Bool
334  null = (== mempty)
335
336deriving via (WrpMonNull Any) instance MonoidNull Any
337deriving via ()               instance MonoidNull ()
338deriving via Ordering         instance MonoidNull Ordering
339
340----
341-- 6
342----
343-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635
344
345class Lattice a where
346  sup   :: a -> a -> a
347  (.>=) :: a -> a -> Bool
348  (.>)  :: a -> a -> Bool
349
350newtype WrapOrd a = WrappedOrd a
351  deriving newtype (Eq, Ord)
352
353instance Ord a => Lattice (WrapOrd a) where
354  sup   = max
355  (.>=) = (>=)
356  (.>)  = (>)
357
358deriving via [a]    instance Ord a          => Lattice [a]
359deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b)
360--mkLattice_(Bool)
361deriving via Bool instance Lattice Bool
362--mkLattice_(Char)
363deriving via Char instance Lattice Char
364--mkLattice_(Int)
365deriving via Int instance Lattice Int
366--mkLattice_(Integer)
367deriving via Integer instance Lattice Integer
368--mkLattice_(Float)
369deriving via Float instance Lattice Float
370--mkLattice_(Double)
371deriving via Double instance Lattice Double
372--mkLattice_(Rational)
373deriving via Rational instance Lattice Rational
374
375----
376-- 7
377----
378-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html
379
380class Functor f => Additive f where
381  zero :: Num a => f a
382  (^+^) :: Num a => f a -> f a -> f a
383  (^+^) = liftU2 (+)
384  (^-^) :: Num a => f a -> f a -> f a
385  x ^-^ y = x ^+^ fmap negate y
386  liftU2 :: (a -> a -> a) -> f a -> f a -> f a
387
388instance Additive [] where
389  zero = []
390  liftU2 f = go where
391    go (x:xs) (y:ys) = f x y : go xs ys
392    go [] ys = ys
393    go xs [] = xs
394
395instance Additive Maybe where
396  zero = Nothing
397  liftU2 f (Just a) (Just b) = Just (f a b)
398  liftU2 _ Nothing ys = ys
399  liftU2 _ xs Nothing = xs
400
401instance Applicative f => Additive (WrapApplicative f) where
402  zero   = pure 0
403  liftU2 = liftA2
404
405deriving via (WrapApplicative ((->) a)) instance Additive ((->) a)
406deriving via (WrapApplicative Complex)  instance Additive Complex
407deriving via (WrapApplicative Identity) instance Additive Identity
408
409instance Additive ZipList where
410  zero = ZipList []
411  liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)
412
413class Additive (Diff p) => Affine p where
414  type Diff p :: Type -> Type
415
416  (.-.) :: Num a => p a -> p a -> Diff p a
417  (.+^) :: Num a => p a -> Diff p a -> p a
418  (.-^) :: Num a => p a -> Diff p a -> p a
419  p .-^ v = p .+^ fmap negate v
420
421-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
422--   (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
423--   (.-^) = (^-^) ; {-# INLINE (.-^) #-}
424-- #define ADDITIVE(T) ADDITIVEC((), T)
425newtype WrapAdditive f a = WrappedAdditive (f a)
426
427instance Additive f => Affine (WrapAdditive f) where
428  type Diff (WrapAdditive f) = f
429
430  WrappedAdditive a .-. WrappedAdditive b = a ^-^ b
431  WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b)
432  WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b)
433
434-- ADDITIVE(((->) a))
435deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)
436-- ADDITIVE([])
437deriving via (WrapAdditive [])       instance Affine []
438-- ADDITIVE(Complex)
439deriving via (WrapAdditive Complex)  instance Affine Complex
440-- ADDITIVE(Maybe)
441deriving via (WrapAdditive Maybe)    instance Affine Maybe
442-- ADDITIVE(ZipList)
443deriving via (WrapAdditive ZipList)  instance Affine ZipList
444-- ADDITIVE(Identity)
445deriving via (WrapAdditive Identity) instance Affine Identity
446
447----
448-- 8
449----
450
451class C2 a b c where
452  c2 :: a -> b -> c
453
454instance C2 a b (Const a b) where
455  c2 x _ = Const x
456
457newtype Fweemp a = Fweemp a
458  deriving (C2 a b)
459       via (Const a (b :: Type))
460