{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}

module Main (main) where

import Control.Monad.Scoped
import Control.Monad.Scoped.Internal
import Control.Monad.Trans.Class
import Test.Hspec
import UnliftIO
import UnliftIO.Concurrent

type TestResource s = ScopedResource s (MVar ())

data E = E
  deriving stock (Show)
  deriving anyclass (Exception)

acqireResource :: MonadIO m => MVar () -> Scoped s m (TestResource s)
acqireResource v =
  UnsafeMkScopedResource <$> lift do
    liftIO $ putStrLn "acquiring resource"
    putMVar v ()
    pure v

releaseResource :: MonadIO m => TestResource s -> m ()
releaseResource (UnsafeMkScopedResource res) = do
  takeMVar res
  liftIO $ putStrLn "released resource"

main :: IO ()
main = hspec do
  it "releases when the underlying monad fails" do
    v <- newEmptyMVar
    handle (\(_ :: SomeException) -> pure ()) $ scoped do
      res <- acqireResource v
      liftIO $
        tryReadMVar v
          >>= (`shouldBe` Just ())
      registerHandler (releaseResource res)
      liftIO do
        putStrLn "failing"
        fail "test"

    tryReadMVar v
      >>= (`shouldBe` Nothing)

  it "releases when the thread receives an async exception" do
    v <- newEmptyMVar
    x <- newEmptyMVar
    _ <- forkIO do
      i <- myThreadId
      _ <- forkIO do
        withMVar x \() -> do
          putStrLn "throwing"
          throwTo i E

      True <- handle
        ( \(e :: SomeAsyncException) -> case e of
            SomeAsyncException (toException -> (fromException -> Just E)) -> pure True
            _ -> fail "wrong exception"
        )
        $ scoped do
          res <- acqireResource v
          liftIO $
            tryReadMVar v
              >>= (`shouldBe` Just ())
          registerHandler (releaseResource res)
          putMVar x ()
          yield
          pure False
      pure ()

    tryReadMVar v
      >>= (`shouldBe` Nothing)