region_effect.hs

{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances,
             GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, Rank2Types, StandaloneDeriving,
             TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}

module Control.Effect.Region.IO.Text
  ( module Control.Effect.Region
  , module Control.Effect.Region.IO
  , newHandle
  , runFileRegion
  ) where

import           Control.Effect
import           Control.Effect.Carrier
import           Control.Effect.Region
import           Control.Effect.Region.IO
import           Control.Effect.Resource
import           Control.Effect.State
import           Control.Effect.Sum
import           Data.Coerce
import           Control.Monad.IO.Class
import           Data.Foldable
import           Data.Proxy
import GHC.TypeLits
import qualified System.Path.Posix as Path
import qualified System.Path.IO as Path

data Region s (m :: * -> *) k
  = forall mode . New Path.IOMode Path.AbsRelFile (Handle s -> k)

deriving instance Functor (Region s m)

instance HFunctor (Region s) where hmap _ = coerce

newtype Handle s = Handle Path.Handle
data SomeHandle = forall s . SomeHandle (Handle s)

-- TODO error message?
type family Ancestor (n :: Nat) (lst :: * -> *) where
  Ancestor 0 (FileRegionC s m) = s
  Ancestor n (FileRegionC s m) = Ancestor (n - 1) m
  Ancestor n (t m)             = Ancestor n m
  Ancestor n _                 = TypeError "oops"

primCloseHandle' :: SomeHandle -> IO ()
primCloseHandle' (SomeHandle s) = primCloseHandle s

primCloseHandle :: Handle s -> IO ()
primCloseHandle = coerce Path.hClose

newHandle' :: ( s ~ Ancestor n m
              , Member (Region s) sig
              , Carrier sig m, MonadIO m
              )
           => Proxy n
           -> Path.IOMode
           -> Path.AbsRelFile
           -> m (Handle s)
newHandle' _ mode p = send (New mode p pure)

newHandle :: ( s ~ Ancestor 0 m
             , Member (Region s) sig
             , Carrier sig m, MonadIO m
             )
          => Path.IOMode
          -> Path.AbsRelFile
          -> m (Handle s)
newHandle = newHandle' (Proxy @0)

-- assuming no thread safety shenanigans
newtype FileRegionC s m a = FileRegionC (StateC [SomeHandle] m a)
  deriving (Applicative, Functor, Monad, MonadIO)

drain :: forall s sig m . (Member (State [SomeHandle]) sig, Carrier sig m, MonadIO m) => m ()
drain = get @[SomeHandle] >>= traverse_ (liftIO . primCloseHandle')

runFileRegion :: ( Member Resource sig
                 , Effect sig, Carrier sig m, MonadIO m
                 )
              => (forall s . FileRegionC s m a)
              -> m a
runFileRegion (FileRegionC s) = evalState (mempty :: [SomeHandle]) (s `onException` drain)

instance (Effect sig, Carrier sig m, MonadIO m) => Carrier (Region s :+: sig) (FileRegionC s m) where
  eff (L (New mode path k)) = do
    syshandle <- fmap Handle . liftIO $ Path.openFile path mode
    FileRegionC (modify (SomeHandle syshandle:))
    k syshandle


  eff (R other) = FileRegionC (eff (R (handleCoercible other)))