content: {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE DerivingVia #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE InstanceSigs #-}
  {-# LANGUAGE TypeInType #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE UndecidableInstances #-}
  module DerivingViaCompile where
  
  import Data.Void
  import Data.Complex
  import Data.Functor.Const
  import Data.Functor.Identity
  import Data.Ratio
  import Control.Monad.Reader
  import Control.Monad.State
  import Control.Monad.Writer
  import Control.Applicative hiding (WrappedMonad(..))
  
  import Data.Bifunctor
  import Data.Monoid
  import Data.Kind
  
  type f ~> g = forall xx. f xx -> g xx
  
  -----
  -- Simple example
  -----
  
  data Foo a = MkFoo a a
    deriving Show
         via (Identity (Foo a))
  
  -----
  -- Eta reduction at work
  -----
  
  newtype Flip p a b = Flip { runFlip :: p b a }
  
  instance Bifunctor p => Bifunctor (Flip p) where
    bimap f g = Flip . bimap g f . runFlip
  
  instance Bifunctor p => Functor (Flip p a) where
    fmap f = Flip . first f . runFlip
  
  newtype Bar a = MkBar (Either a Int)
    deriving Functor
         via (Flip Either Int)
  
  -----
  -- Monad transformers
  -----
  
  type MTrans = (Type -> Type) -> (Type -> Type)
  
  -- From `constraints'
  data Dict c where
    Dict :: c => Dict c
  
  newtype a :- b = Sub (a => Dict b)
  
  infixl 1 \\
  (\\) :: a => (b => r) -> (a :- b) -> r
  r \\ Sub Dict = r
  
  -- With `-XQuantifiedConstraints' this just becomes
  --
  --    type Lifting cls  trans = forall mm. cls mm => cls (trans mm)
  --
  --    type LiftingMonad trans = Lifting Monad trans
  --
  class LiftingMonad (trans :: MTrans) where
    proof :: Monad m :- Monad (trans m)
  
  instance LiftingMonad (StateT s :: MTrans) where
    proof :: Monad m :- Monad (StateT s m)
    proof = Sub Dict
  
  instance Monoid w => LiftingMonad (WriterT w :: MTrans) where
    proof :: Monad m :- Monad (WriterT w m)
    proof = Sub Dict
  
  instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where
    proof :: forall m. Monad m :- Monad (ComposeT trans trans' m)
    proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m)
  
  newtype Stack :: MTrans where
    Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a
    deriving newtype
      ( Functor
      , Applicative
      , Monad
      , MonadReader Int
      , MonadState Bool
      , MonadWriter String
      )
    deriving (MonadTrans, MFunctor)
         via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String)
  
  class MFunctor (trans :: MTrans) where
    hoist :: Monad m => (m ~> m') -> (trans m ~> trans m')
  
  instance MFunctor (ReaderT r :: MTrans) where
    hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m')
    hoist nat = ReaderT . fmap nat . runReaderT
  
  instance MFunctor (StateT s :: MTrans) where
    hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m')
    hoist nat = StateT . fmap nat . runStateT
  
  instance MFunctor (WriterT w :: MTrans) where
    hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m')
    hoist nat = WriterT . nat . runWriterT
  
  infixr 9 `ComposeT`
  newtype ComposeT :: MTrans -> MTrans -> MTrans where
    ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a
    deriving newtype (Functor, Applicative, Monad)
  
  instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where
    lift :: forall m. Monad m => m ~> ComposeT f g m
    lift = ComposeT . lift . lift
      \\ proof @g @m
  
  instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where
    hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m')
    hoist f = ComposeT . hoist (hoist f) . getComposeT
      \\ proof @g @m
  
  -----
  -- Using tuples in a `via` type
  -----
  
  newtype X a = X (a, a)
    deriving (Semigroup, Monoid)
         via (Product a, Sum a)
  
    deriving (Show, Eq)
         via (a, a)
  
  -----
  -- Abstract data types
  -----
  
  class C f where
    c :: f a -> Int
  
  newtype X2 f a = X2 (f a)
  
  instance C (X2 f) where
    c = const 0
  
  deriving via (X2 IO) instance C IO
  
  ----
  -- Testing parser
  ----
  
  newtype P0 a = P0 a             deriving Show via a
  newtype P1 a = P1 [a]           deriving Show via [a]
  newtype P2 a = P2 (a, a)        deriving Show via (a, a)
  newtype P3 a = P3 (Maybe a)     deriving Show via (First a)
  newtype P4 a = P4 (Maybe a)     deriving Show via (First $ a)
  newtype P5 a = P5 a             deriving Show via (Identity $ a)
  newtype P6 a = P6 [a]           deriving Show via ([] $ a)
  newtype P7 a = P7 (a, a)        deriving Show via (Identity $ (a, a))
  newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ()))
  
  newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor
  
  ----
  -- From Baldur's notes
  ----
  
  ----
  -- 1
  ----
  newtype WrapApplicative f a = WrappedApplicative (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
  
  ----
  -- 2
  ----
  class Pointed p where
    pointed :: a -> p a
  
  newtype WrapMonad f a = WrappedMonad (f a)
    deriving newtype (Pointed, Monad)
  
  instance (Monad m, Pointed m) => Functor (WrapMonad m) where
    fmap = liftM
  
  instance (Monad m, Pointed m) => Applicative (WrapMonad m) where
    pure  = pointed
    (<*>) = ap
  
  -- data
  data Sorted a = Sorted a a a
    deriving (Functor, Applicative)
      via (WrapMonad Sorted)
    deriving (Num, Fractional, Floating, Semigroup, Monoid)
      via (WrapApplicative Sorted a)
  
  
  instance Monad Sorted where
    (>>=) :: 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
  
  instance Pointed Sorted where
    pointed :: a -> Sorted a
    pointed a = Sorted a a a
  
  ----
  -- 3
  ----
  class IsZero a where
    isZero :: a -> Bool
  
  newtype WrappedNumEq  a = WrappedNumEq a
  newtype WrappedShow   a = WrappedShow  a
  newtype WrappedNumEq2 a = WrappedNumEq2 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
  
  instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
    isZero :: WrappedNumEq2 a -> Bool
    isZero (WrappedNumEq2 a) = a + a == a
  
  newtype INT = INT Int
    deriving newtype Show
    deriving IsZero via (WrappedNumEq Int)
  
  newtype VOID = VOID Void deriving IsZero via (WrappedShow Void)
  
  ----
  -- 4
  ----
  class Bifunctor p => Biapplicative p where
    bipure :: a -> b -> p a b
  
    biliftA2
      :: (a  -> b  -> c)
      -> (a' -> b' -> c')
      -> p a a'
      -> p b b'
      -> p c c'
  
  instance Biapplicative (,) where
    bipure = (,)
  
    biliftA2 f f' (a, a') (b, b') =
      (f a b, f' a' b')
  
  newtype WrapBiapp p a b = WrapBiap (p a b)
    deriving newtype (Bifunctor, Biapplicative, Eq)
  
  instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where
    (+) = biliftA2 (+) (+)
    (-) = biliftA2 (*) (*)
    (*) = biliftA2 (*) (*)
    negate = bimap negate negate
    abs = bimap abs abs
    signum = bimap signum signum
    fromInteger n = fromInteger n `bipure` fromInteger n
  
  newtype INT2 = INT2 (Int, Int)
    deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int))
  
  ----
  -- 5
  ----
  class Monoid a => MonoidNull a where
    null :: a -> Bool
  
  newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid)
  
  instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where
    null :: WrpMonNull a -> Bool
    null = (== mempty)
  
  deriving via (WrpMonNull Any) instance MonoidNull Any
  deriving via ()               instance MonoidNull ()
  deriving via Ordering         instance MonoidNull Ordering
  
  ----
  -- 6
  ----
  -- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635
  
  class Lattice a where
    sup   :: a -> a -> a
    (.>=) :: a -> a -> Bool
    (.>)  :: a -> a -> Bool
  
  newtype WrapOrd a = WrappedOrd a
    deriving newtype (Eq, Ord)
  
  instance Ord a => Lattice (WrapOrd a) where
    sup   = max
    (.>=) = (>=)
    (.>)  = (>)
  
  deriving via [a]    instance Ord a          => Lattice [a]
  deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b)
  --mkLattice_(Bool)
  deriving via Bool instance Lattice Bool
  --mkLattice_(Char)
  deriving via Char instance Lattice Char
  --mkLattice_(Int)
  deriving via Int instance Lattice Int
  --mkLattice_(Integer)
  deriving via Integer instance Lattice Integer
  --mkLattice_(Float)
  deriving via Float instance Lattice Float
  --mkLattice_(Double)
  deriving via Double instance Lattice Double
  --mkLattice_(Rational)
  deriving via Rational instance Lattice Rational
  
  ----
  -- 7
  ----
  -- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html
  
  class Functor f => Additive f where
    zero :: Num a => f a
    (^+^) :: Num a => f a -> f a -> f a
    (^+^) = liftU2 (+)
    (^-^) :: Num a => f a -> f a -> f a
    x ^-^ y = x ^+^ fmap negate y
    liftU2 :: (a -> a -> a) -> f a -> f a -> f a
  
  instance Additive [] where
    zero = []
    liftU2 f = go where
      go (x:xs) (y:ys) = f x y : go xs ys
      go [] ys = ys
      go xs [] = xs
  
  instance Additive Maybe where
    zero = Nothing
    liftU2 f (Just a) (Just b) = Just (f a b)
    liftU2 _ Nothing ys = ys
    liftU2 _ xs Nothing = xs
  
  instance Applicative f => Additive (WrapApplicative f) where
    zero   = pure 0
    liftU2 = liftA2
  
  deriving via (WrapApplicative ((->) a)) instance Additive ((->) a)
  deriving via (WrapApplicative Complex)  instance Additive Complex
  deriving via (WrapApplicative Identity) instance Additive Identity
  
  instance Additive ZipList where
    zero = ZipList []
    liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)
  
  class Additive (Diff p) => Affine p where
    type Diff p :: Type -> Type
  
    (.-.) :: Num a => p a -> p a -> Diff p a
    (.+^) :: Num a => p a -> Diff p a -> p a
    (.-^) :: Num a => p a -> Diff p a -> p a
    p .-^ v = p .+^ fmap negate v
  
  -- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
  --   (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
  --   (.-^) = (^-^) ; {-# INLINE (.-^) #-}
  -- #define ADDITIVE(T) ADDITIVEC((), T)
  newtype WrapAdditive f a = WrappedAdditive (f a)
  
  instance Additive f => Affine (WrapAdditive f) where
    type Diff (WrapAdditive f) = f
  
    WrappedAdditive a .-. WrappedAdditive b = a ^-^ b
    WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b)
    WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b)
  
  -- ADDITIVE(((->) a))
  deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)
  -- ADDITIVE([])
  deriving via (WrapAdditive [])       instance Affine []
  -- ADDITIVE(Complex)
  deriving via (WrapAdditive Complex)  instance Affine Complex
  -- ADDITIVE(Maybe)
  deriving via (WrapAdditive Maybe)    instance Affine Maybe
  -- ADDITIVE(ZipList)
  deriving via (WrapAdditive ZipList)  instance Affine ZipList
  -- ADDITIVE(Identity)
  deriving via (WrapAdditive Identity) instance Affine Identity
  
  ----
  -- 8
  ----
  
  class C2 a b c where
    c2 :: a -> b -> c
  
  instance C2 a b (Const a b) where
    c2 x _ = Const x
  
  newtype Fweemp a = Fweemp a
    deriving (C2 a b)
         via (Const a (b :: Type))
  
  