{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE BlockArguments #-}
module ScopedCont where

import System.IO qualified
import Control.Monad.Codensity
import UnliftIO (MonadIO, IOMode (WriteMode), liftIO)
import Data.Kind
import Control.Monad.Trans (MonadTrans, lift)

newtype SCod s (m :: k -> Type) a = MkSCod {unSCod :: forall b. (a -> m b) -> m b}
  deriving (Functor, Applicative, Monad) via (Codensity m)
  deriving MonadTrans via Codensity

instance MonadIO m => MonadIO (SCod s m) where 
  liftIO = lift . liftIO


runSCod :: (Applicative m) => (forall s. SCod s m r) -> m r
runSCod k = unSCod k pure

data Handle s = MkHandle {handleName :: String, unsafeGetHandle :: System.IO.Handle}

withFile :: FilePath -> System.IO.IOMode -> SCod s IO (Handle s)
withFile fp md = MkSCod (\k -> putStrLn ("allocating " <> fp) *> System.IO.withFile fp md (k . MkHandle fp) <* putStrLn ("deallocated " <> fp))

hPutStrLn :: Handle s -> String -> IO ()
hPutStrLn (MkHandle fp hdl) s = putStrLn ("writing to handle " <> fp) *> System.IO.hPutStrLn hdl s <* putStrLn ("wrote to handle " <> fp)

scoped :: Monad m => (forall s. SCod s m r) -> SCod s' m r
scoped act = lift (runSCod act)

x :: IO ()
x = runSCod do
  bla <- withFile "bla" WriteMode
  liftIO $ hPutStrLn bla "test"
  scoped do 
    foo <- withFile "foo" WriteMode
    liftIO $ hPutStrLn bla "test3!"
    liftIO $ hPutStrLn foo "woop"
  blup <- withFile "blup" WriteMode
  liftIO $ hPutStrLn blup "test2"

{-
allocating bla
writing to handle bla
wrote to handle bla
allocating foo
writing to handle bla
wrote to handle bla
writing to handle foo
wrote to handle foo
deallocated foo
allocating blup
writing to handle blup
wrote to handle blup
deallocated blup
deallocated bla
-}