{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language KindSignatures #-}
{-# language LambdaCase #-}
{-# language RankNTypes #-}
{-# language TypeOperators #-}

module IO.Effects.IORef
  ( -- * IORefs
    runIORefs
  , newIORef
  , readIORef
  , writeIORef
  , modifyIORef
  , modifyIORef'
  , atomicModifyIORef
  , atomicModifyIORef'

  , IORefs
  )
  where

import Data.IORef ( IORef )
import qualified Data.IORef
import IO.Effects.Internal


data IORefs m a where
  NewIORef :: a -> IORefs ( m :: * -> * ) ( IORef a )
  ReadIORef :: IORef a -> IORefs m a
  WriteIORef :: IORef a -> a -> IORefs m ()
  AtomicModifyIORef :: IORef a -> ( a -> ( a, b ) ) -> IORefs m b


runIORefs :: ProgramWithHandler IORefs es a -> Program es a
runIORefs =
  interpret \case
    NewIORef a ->
      Program ( Data.IORef.newIORef a )

    ReadIORef ref ->
      Program ( Data.IORef.readIORef ref )

    WriteIORef ref a ->
      Program ( Data.IORef.writeIORef ref a )

    AtomicModifyIORef ref f ->
      Program ( Data.IORef.atomicModifyIORef ref f )


newIORef :: Member IORefs es => a -> Program es ( IORef a )
newIORef =
  send . NewIORef


readIORef :: Member IORefs es => IORef a -> Program es a
readIORef =
  send . ReadIORef


writeIORef :: Member IORefs es => IORef a -> a -> Program es ()
writeIORef ref a =
  send ( WriteIORef ref a )


modifyIORef :: Member IORefs es => IORef a -> ( a -> a ) -> Program es ()
modifyIORef ref f =
  readIORef ref >>= writeIORef ref . f


modifyIORef' :: Member IORefs es => IORef a -> ( a -> a ) -> Program es ()
modifyIORef' ref f = do
  x <-
    readIORef ref

  let
    x' =
      f x

  x' `seq` writeIORef ref x'


atomicModifyIORef
  :: Member IORefs es
  => IORef a -> ( a -> ( a, b ) ) -> Program es b
atomicModifyIORef ref f =
  send ( AtomicModifyIORef ref f )


atomicModifyIORef'
  :: Member IORefs es
  => IORef a -> ( a -> ( a, b ) ) -> Program es b
atomicModifyIORef' ref f = do
  b <-
    atomicModifyIORef ref \a ->
      case f a of
        v@( a',_ ) ->
          a' `seq` v

  b `seq` return b