module HsBindgen.Eff (
    Eff     -- opaque
  , Support -- opaque
  , wrapEff
  , unwrapEff
  , runFoldIdentity
  , runFoldReader
  , runFoldState
  , assertEff
  ) where

import Control.Monad.Reader (MonadReader, Reader, ReaderT (..))
import Control.Monad.State (MonadState (state), State)
import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
import Data.Tuple (swap)

import HsBindgen.Errors
import HsBindgen.Imports

{-------------------------------------------------------------------------------
  'Eff' monad

  We work mostly in @IO@, and limited by @MonadUnliftIO@,
  but sometimes we need more effects: @Eff@ wrapping @ReaderT r IO@
  pattern can mimick many other monads.

  NOTE: This is intentionally /not/ a member of 'MonadCatch'. We use 'Eff'
  primarily for folding, and exception handling in folding requires special
  care. See detailed discussion of 'foldWithHandler' in the @clang@ bindings.
-------------------------------------------------------------------------------}

newtype Eff m a = Eff (ReaderT (Support m) IO a)
  deriving newtype (
      Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadUnliftIO
    )

getEff :: Eff m a -> ReaderT (Support m) IO a
getEff (Eff ma) = ma

wrapEff :: (Support m -> IO a) -> Eff m a
wrapEff = Eff . ReaderT

unwrapEff :: Eff m a -> Support m -> IO a
unwrapEff = runReaderT . getEff

assertEff :: Bool -> String -> Eff m ()
assertEff True  _   = return ()
assertEff False msg = panicIO msg

-- | 'ReaderT' argument required to support @m@
type family Support (m :: Star -> Star) :: Star

--
-- 'Identity'
--

type instance Support Identity = ()

runFoldIdentity :: Eff Identity a -> IO a
runFoldIdentity = ($ ()) . unwrapEff

--
-- 'Reader'
--

type instance Support (Reader r) = r

deriving newtype instance MonadReader r (Eff (Reader r))

runFoldReader :: r -> Eff (Reader r) a -> IO a
runFoldReader env = ($ env) . unwrapEff

--
-- 'State'
--

type instance Support (State s) = IORef s

instance MonadState s (Eff (State s)) where
  state f = wrapEff $ \ref -> atomicModifyIORef ref (swap . f)

runFoldState :: s -> Eff (State s) a -> IO (a, s)
runFoldState s f = do
    ref <- newIORef s
    a   <- unwrapEff f ref
    (a,) <$> readIORef ref