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