{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-# OPTIONS_HADDOCK hide #-}

module Capability.Source.Internal.Strategies
  ( MonadReader(..)
  , ReadStatePure(..)
  , ReadState(..)
  , MonadState(..)
  , ReaderIORef(..)
  , ReaderRef(..)
  ) where

import Capability.Source.Internal.Class
import Capability.State.Internal.Class
import Capability.State.Internal.Strategies.Common
import Capability.Accessors
import Control.Lens (view)
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Reader.Class as Reader
import qualified Control.Monad.State.Class as State
import Control.Monad.Trans.Class (MonadTrans, lift)
import Data.Coerce (Coercible, coerce)
import Data.IORef
import Data.Kind (Type)
import Data.Mutable
import qualified Data.Generics.Product.Fields as Generic
import qualified Data.Generics.Product.Positions as Generic

--------------------------------------------------------------------------------

-- | Derive 'HasSource' from @m@'s 'Control.Monad.Reader.Class.MonadReader'
-- instance.
newtype MonadReader (m :: Type -> Type) (a :: Type) = MonadReader (m a)
  deriving (Functor, Applicative, Monad, MonadIO, PrimMonad)

instance Reader.MonadReader r m => HasSource tag r (MonadReader m) where
  await_ _ = coerce @(m r) Reader.ask
  {-# INLINE await_ #-}

-- | Convert a /pure/ state monad into a reader monad.
--
-- /Pure/ meaning that the monad stack does not allow catching exceptions.
-- Otherwise, an exception occurring in the action passed to 'local' could cause
-- the context to remain modified outside of the call to 'local'. E.g.
--
-- > local @tag (const r') (throw MyException)
-- > `catch` \MyException -> ask @tag
--
-- returns @r'@ instead of the previous value.
--
-- Note, that no @MonadIO@ instance is provided, as this would allow catching
-- exceptions.
--
-- See 'ReadState'.
newtype ReadStatePure (m :: Type -> Type) (a :: Type) = ReadStatePure (m a)
  deriving (Functor, Applicative, Monad)

instance HasState tag r m => HasSource tag r (ReadStatePure m) where
  await_ _ = coerce @(m r) $ get @tag
  {-# INLINE await_ #-}

-- | Convert a state monad into a reader monad.
--
-- Use this if the monad stack allows catching exceptions.
--
-- See 'ReadStatePure'.
newtype ReadState (m :: Type -> Type) (a :: Type) = ReadState (m a)
  deriving (Functor, Applicative, Monad, MonadIO, PrimMonad)

instance
  (HasState tag r m, MonadMask m)
  => HasSource tag r (ReadState m)
  where
    await_ _ = coerce @(m r) $ get @tag
    {-# INLINE await_ #-}

instance
  ( tag ~ pos, Generic.HasPosition' pos struct v, HasSource oldtag struct m )
  => HasSource tag v (Pos pos oldtag m)
  where
    await_ _ = coerce @(m v) $
      awaits @oldtag $ view (Generic.position' @pos)
    {-# INLINE await_ #-}

deriving via ((t2 :: (Type -> Type) -> Type -> Type) ((t1 :: (Type -> Type) -> Type -> Type) m))
  instance
  ( forall x. Coercible (m x) (t2 (t1 m) x)
  , Monad m, HasSource tag r (t2 (t1 m)) )
  => HasSource tag r ((t2 :.: t1) m)

instance
  ( Coercible from to, HasSource tag from m
  , forall x y. Coercible x y => Coercible (m x) (m y) )
  => HasSource tag to (Coerce to m)
  where
    await_ tag = coerce @(m from) $ await_ tag
    {-# INLINE await_ #-}

-- | Rename the tag.
instance HasSource oldtag r m => HasSource newtag r (Rename oldtag m) where
  await_ _ = coerce @(m r) $ await @oldtag
  {-# INLINE await_ #-}

instance
  ( tag ~ field, Generic.HasField' field record v, HasSource oldtag record m )
  => HasSource tag v (Field field oldtag m)
  where
    await_ _ = coerce @(m v) $
      awaits @oldtag $ view (Generic.field' @field)
    {-# INLINE await_ #-}

instance (HasSource tag r m, MonadTrans t, Monad (t m))
  => HasSource tag r (Lift (t m))
  where
    await_ _ = coerce $ lift @t @m $ await @tag @r
    {-# INLINE await_ #-}

--------------------------------------------------------------------------------

instance State.MonadState s m => HasSource tag s (MonadState m) where
  await_ _ = coerce @(m s) State.get
  {-# INLINE await_ #-}

instance
  (HasSource tag (IORef s) m, MonadIO m)
  => HasSource tag s (ReaderIORef m)
  where
    await_ _ = ReaderIORef $ do
      ref <- await @tag
      liftIO $ readIORef ref
    {-# INLINE await_ #-}

instance
  ( MutableRef ref, RefElement ref ~ s
  , HasSource tag ref m, PrimMonad m, PrimState m ~ MCState ref )
  => HasSource tag s (ReaderRef m)
  where
    await_ _ = ReaderRef $ do
      ref <- await @tag
      readRef ref
    {-# INLINE await_ #-}