{-# LANGUAGE ScopedTypeVariables, TypeFamilies, PolyKinds, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, TypeOperators, MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications, RankNTypes, DataKinds, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Control.Effects.Generic where

import qualified GHC.Generics as Gen
import GHC.Generics
import Control.Monad.Trans
import Data.Proxy
import GHC.TypeLits

data M a

class (Generic (a m), Generic (a (t m)), Generic (a M)) => SimpleMethods a m t where
    liftSimple :: a m -> a (t m)

instance
    ( Rep (a m) ~ D1 m1 (C1 m2 p)
    , Rep (a M) ~ D1 m1 (C1 m2 pM)
    , Rep (a (t m)) ~ D1 m1 (C1 m2 (LiftedProducts p pM m t))
    , ProductOfSimpleMethods p pM m t
    , Generic (a m), Generic (a (t m)), Generic (a M) )
    => SimpleMethods a m t where
    liftSimple a = case Gen.from a of
        M1 (M1 p) -> Gen.to (M1 (M1 (liftProducts (Proxy @m) (Proxy @t) (Proxy @pM) p)))
    {-# INLINE liftSimple #-}

class ProductOfSimpleMethods p pM m t where
    type LiftedProducts p pM m t :: * -> *
    liftProducts :: Proxy m -> Proxy t -> Proxy pM -> p x -> LiftedProducts p pM m t x

instance SimpleMethod f fM m t => ProductOfSimpleMethods (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) m t where
    type LiftedProducts (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) m t =
        (S1 m1 (Rec0 (LiftedMethod f fM m t)))
    liftProducts p1 p2 _ (M1 (K1 f)) = M1 (K1 (liftMethod p1 p2 (Proxy @fM) f))
    {-# INLINE liftProducts #-}
instance
    (ProductOfSimpleMethods f1 f1M m t, ProductOfSimpleMethods f2 f2M m t)
    => ProductOfSimpleMethods (f1 :*: f2) (f1M :*: f2M) m t where
    type LiftedProducts (f1 :*: f2) (f1M :*: f2M) m t =
        LiftedProducts f1 f1M m t :*: LiftedProducts f2 f2M m t
    liftProducts p1 p2 _ (f1 :*: f2) =
        liftProducts p1 p2 (Proxy @f1M) f1 :*: liftProducts p1 p2 (Proxy @f2M) f2
    {-# INLINE liftProducts #-}

class (MonadTrans t, Monad m) => SimpleMethod f fM (m :: * -> *) (t :: (* -> *) -> * -> *) where
    type LiftedMethod f fM m t
    liftMethod :: Proxy m -> Proxy t -> Proxy fM -> f -> LiftedMethod f fM m t
instance (MonadTrans t, Monad m, a ~ m x) => SimpleMethod a (M x) m t where
    type LiftedMethod a (M x) m t = t m x
    liftMethod _ _ _ = lift @t
    {-# INLINE liftMethod #-}
type family FuncRes f where
    FuncRes (a -> b) = b
instance (f ~ (a -> b), SimpleMethod b bM m t, IndependentOfM a m) => SimpleMethod f (a -> bM) m t where
    type LiftedMethod f (a -> bM) m t = a -> LiftedMethod (FuncRes f) bM m t
    liftMethod p1 p2 _ f a = liftMethod p1 p2 (Proxy @bM) (f a :: b)
    {-# INLINE liftMethod #-}
instance {-# OVERLAPPABLE #-}
    ( TypeError ('Text "Effect methods must be monadic actions or functions resulting in monadic actions")
    , Monad m, MonadTrans t )
    => SimpleMethod a b m t

class IndependentOfM (a :: k) (m :: * -> *) where
instance
    (IndependentOfM a m, IndependentOfM b m)
    => IndependentOfM (a b) m
instance
    TypeError
        ('Text "Parameters of methods can't depend on the monadic context ("
        ':<>: 'ShowType m
        ':<>: 'Text ")")
    => IndependentOfM M m
instance {-# OVERLAPPABLE #-}
    IndependentOfM (a :: k) m

genericLiftThrough ::
    forall t e m. (MonadTrans t, Monad m, Monad (t m), SimpleMethods e m t)
    => e m -> e (t m)
genericLiftThrough = liftSimple
{-# INLINE genericLiftThrough #-}



class MonadicMethods a m where
    mergeMonadicMethods :: m (a m) -> a m
instance
    ( Rep (a m) ~ D1 m1 (C1 m2 p)
    , Rep (a M) ~ D1 m1 (C1 m2 pM)
    , ProductOfMonadicMethods p pM a m
    , Generic (a m), Generic (a M) )
    => MonadicMethods a m where
    mergeMonadicMethods a = Gen.to (M1 (M1 (mergeMonadicProducts (Proxy @p) (Proxy @pM) a f)))
        where
        f (Gen.from -> M1 (M1 p)) = p
    {-# INLINE mergeMonadicMethods #-}

class ProductOfMonadicMethods p pM a m where
    mergeMonadicProducts :: Proxy p -> Proxy pM -> m (a m) -> (a m -> p x) -> p x
instance MonadicMethod a f fM m => ProductOfMonadicMethods (S1 m1 (Rec0 f)) (S1 m1 (Rec0 fM)) a m where
    mergeMonadicProducts _ _ ma f = M1 (K1 (mergeMethod (Proxy @fM) (g . f) ma))
        where
        g (M1 (K1 x)) = x
    {-# INLINE mergeMonadicProducts #-}
instance
    (ProductOfMonadicMethods f1 f1M a m, ProductOfMonadicMethods f2 f2M a m)
    => ProductOfMonadicMethods (f1 :*: f2) (f1M :*: f2M) a m where
    mergeMonadicProducts _ _ ma f =
        mergeMonadicProducts (Proxy @f1) (Proxy @f1M) ma (g1 . f)
        :*: mergeMonadicProducts (Proxy @f2) (Proxy @f2M) ma (g2 . f)
        where
        g1 (x :*: _) = x
        g2 (_ :*: x) = x
    {-# INLINE mergeMonadicProducts #-}

class Monad m => MonadicMethod a f fM m where
    mergeMethod :: Proxy fM -> (a m -> f) -> m (a m) -> f
instance (b ~ m x, Monad m) => MonadicMethod a b (M x) m where
    mergeMethod _ f ma = do
        a <- ma
        f a
    {-# INLINE mergeMethod #-}
instance (f ~ (b -> c), Monad m, MonadicMethod a c cM m) => MonadicMethod a f (bM -> cM) m where
    mergeMethod _ f ma b = mergeMethod (Proxy @cM) (g . f) ma
        where
        g = ($ b)
    {-# INLINE mergeMethod #-}
instance {-# OVERLAPPABLE #-}
    ( TypeError ('Text "Effect methods must be monadic actions or functions resulting in monadic actions")
    , Monad m )
    => MonadicMethod a f fM m

genericMergeContext :: MonadicMethods a m => m (a m) -> a m
genericMergeContext = mergeMonadicMethods
{-# INLINE genericMergeContext #-}