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