{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module RIO.Prelude.RIO
  ( RIO (..)
  , runRIO
  , liftRIO
  -- * SomeRef for Writer/State interfaces
  , SomeRef
  , HasStateRef (..)
  , HasWriteRef (..)
  , newSomeRef
  , newUnboxedSomeRef
  , readSomeRef
  , writeSomeRef
  , modifySomeRef
  ) where

import GHC.Exts (RealWorld)

import RIO.Prelude.Lens
import RIO.Prelude.URef
import RIO.Prelude.Reexports
import Control.Monad.State (MonadState(..))
import Control.Monad.Writer (MonadWriter(..))

-- | The Reader+IO monad. This is different from a 'ReaderT' because:
--
-- * It's not a transformer, it hardcodes IO for simpler usage and
-- error messages.
--
-- * Instances of typeclasses like 'MonadLogger' are implemented using
-- classes defined on the environment, instead of using an
-- underlying monad.
newtype RIO env a = RIO { unRIO :: ReaderT env IO a }
  deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow)

runRIO :: MonadIO m => env -> RIO env a -> m a
runRIO env (RIO (ReaderT f)) = liftIO (f env)

liftRIO :: (MonadIO m, MonadReader env m) => RIO env a -> m a
liftRIO rio = do
  env <- ask
  runRIO env rio

instance MonadUnliftIO (RIO env) where
    askUnliftIO = RIO $ ReaderT $ \r ->
                  withUnliftIO $ \u ->
                  return (UnliftIO (unliftIO u . flip runReaderT r . unRIO))

instance PrimMonad (RIO env) where
    type PrimState (RIO env) = PrimState IO
    primitive = RIO . ReaderT . const . primitive

-- | Abstraction over how to read from and write to a mutable reference
--
-- @since 0.1.4.0
data SomeRef a
  = SomeRef !(IO a) !(a -> IO ())

-- | Read from a SomeRef
--
-- @since 0.1.4.0
readSomeRef :: MonadIO m => SomeRef a -> m a
readSomeRef (SomeRef x _) = liftIO x

-- | Write to a SomeRef
--
-- @since 0.1.4.0
writeSomeRef :: MonadIO m => SomeRef a -> a -> m ()
writeSomeRef (SomeRef _ x) = liftIO . x

-- | Modify a SomeRef
-- This function is subject to change due to the lack of atomic operations
--
-- @since 0.1.4.0
modifySomeRef :: MonadIO m => SomeRef a -> (a -> a) -> m ()
modifySomeRef (SomeRef read' write) f =
  liftIO $ (f <$> read') >>= write

ioRefToSomeRef :: IORef a -> SomeRef a
ioRefToSomeRef ref = do
  SomeRef (readIORef ref)
          (\val -> modifyIORef' ref (\_ -> val))

uRefToSomeRef :: Unbox a => URef RealWorld a -> SomeRef a
uRefToSomeRef ref = do
  SomeRef (readURef ref) (writeURef ref)

-- | Environment values with stateful capabilities to SomeRef
--
-- @since 0.1.4.0
class HasStateRef s env | env -> s where
  stateRefL :: Lens' env (SomeRef s)

-- | Identity state reference where the SomeRef is the env
--
-- @since 0.1.4.0
instance HasStateRef a (SomeRef a) where
  stateRefL = lens id (\_ x -> x)

-- | Environment values with writing capabilities to SomeRef
--
-- @since 0.1.4.0
class HasWriteRef w env | env -> w where
  writeRefL :: Lens' env (SomeRef w)

-- | Identity write reference where the SomeRef is the env
--
-- @since 0.1.4.0
instance HasWriteRef a (SomeRef a) where
  writeRefL = lens id (\_ x -> x)

instance HasStateRef s env => MonadState s (RIO env) where
  get = do
    ref <- view stateRefL
    liftIO $ readSomeRef ref
  put st = do
    ref <- view stateRefL
    liftIO $ writeSomeRef ref st

instance (Monoid w, HasWriteRef w env) => MonadWriter w (RIO env) where
  tell value = do
    ref <- view writeRefL
    liftIO $ modifySomeRef ref (`mappend` value)

  listen action = do
    w1 <- view writeRefL >>= liftIO . readSomeRef
    a <- action
    w2 <- do
      refEnv <- view writeRefL
      v <- liftIO $ readSomeRef refEnv
      _ <- liftIO $ writeSomeRef refEnv w1
      return v
    return (a, w2)

  pass action = do
    (a, transF) <- action
    ref <- view writeRefL
    liftIO $ modifySomeRef ref transF
    return a

-- | create a new boxed SomeRef
--
-- @since 0.1.4.0
newSomeRef :: MonadIO m => a -> m (SomeRef a)
newSomeRef a = do
  ioRefToSomeRef <$> newIORef a

-- | create a new unboxed SomeRef
--
-- @since 0.1.4.0
newUnboxedSomeRef :: (MonadIO m, Unbox a) => a -> m (SomeRef a)
newUnboxedSomeRef a =
  uRefToSomeRef <$> (liftIO $ newURef a)