{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE BlockArguments #-}
module ScopedCont2 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 -> SCod s IO ()
hPutStrLn (MkHandle fp hdl) s = liftIO $ 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
  hPutStrLn bla "test"
  scoped do 
    foo <- withFile "foo" WriteMode
    hPutStrLn foo "woop"
  blup <- withFile "blup" WriteMode
  hPutStrLn blup "test2"

-- z :: IO (String -> IO ())
-- z = runSCod do 
--   hdl <- withFile "bla" WriteMode
--   pure (hPutStrLn hdl)


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