{-# 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 DerivingVia 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

data Foo a = MkFoo a a
               deriving Show via (Identity (Foo a))

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)

type MTrans = (Type -> Type) -> (Type -> Type)

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

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

newtype X a = X (a, a)
                deriving (Semigroup, Monoid) via (Product a, Sum a)
                deriving (Show, Eq) via (a, a)

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

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

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

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 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

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)

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))

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

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)

deriving via Bool instance Lattice Bool

deriving via Char instance Lattice Char

deriving via Int instance Lattice Int

deriving via Integer instance Lattice Integer

deriving via Float instance Lattice Float

deriving via Double instance Lattice Double

deriving via Rational instance Lattice Rational

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

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)

deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)

deriving via (WrapAdditive []) instance Affine []

deriving via (WrapAdditive Complex) instance Affine Complex

deriving via (WrapAdditive Maybe) instance Affine Maybe

deriving via (WrapAdditive ZipList) instance Affine ZipList

deriving via (WrapAdditive Identity) instance Affine Identity

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))