region.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeInType, TypeFamilies #-}

import Control.Monad
import Control.Monad.IO.Class

import Data.Kind

import System.IO

type family OnStack (pr :: Type -> Type) (cr :: Type -> Type) where
    OnStack (RegionT s m) (RegionT s m) = True
    OnStack pr            (t cr)        = OnStack pr cr
    OnStack _             _             = False

type family DownStack (reg :: Type -> Type) :: Type -> Type where
    DownStack (RegionT s m) = NextLayer m
    DownStack (t m)         = DownStack m

type family NextLayer (reg :: Type -> Type) :: Type -> Type where
    NextLayer (RegionT s m) = RegionT s m
    NextLayer (t m)         = NextLayer m

newtype RegionT s pr a = RegionT { unRegionT :: pr a }
    deriving (Applicative, Functor, Monad, MonadIO)

region :: (forall s. RegionT s pr a) -> pr a
region (RegionT s) = s

class Dup h where
    dup :: (Monad m, NextLayer m ~ pr) => h pr -> m (h (DownStack pr))



newtype Trans m a = Trans { unTrans :: m a }
    deriving (Applicative, Functor, Monad, MonadIO)

newtype SHandle s = SHandle Handle

safeOpenFile :: MonadIO pr => FilePath -> IOMode -> RegionT s pr (SHandle (RegionT s pr))
safeOpenFile fp iom = SHandle <$> liftIO (openFile fp iom)

shPutStrLn :: (MonadIO cr, OnStack pr cr ~ True) => SHandle pr -> String -> cr ()
shPutStrLn (SHandle s) str = liftIO $ hPutStrLn s str

data Res s = Res

instance Dup SHandle where
    dup (SHandle h) = pure (SHandle h)

instance Dup Res where
    dup Res = pure Res

newRes :: Applicative pr => RegionT s pr (Res (RegionT s pr))
newRes = pure Res

touchRes :: (Applicative cr, OnStack pr cr ~ True) => Res pr -> cr ()
touchRes _ = pure ()

main = do
    putStrLn "Test"
    region $ do
        res  <- newRes
        hnd  <- safeOpenFile "test.txt" WriteMode
        mres <- unTrans $ do
            Trans $ region $ unTrans $ do
                res' <- Trans newRes
                touchRes res
                touchRes res'
                shPutStrLn hnd "Пыщ!"
                if True
                    then pure Nothing
                    else Just <$> dup res'
        forM_ mres $
            \resFromOut -> touchRes resFromOut
        touchRes res