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