Using constrained traversals for resource management

TraversalC.hs

{-# LANGUAGE
    DataKinds
  , DeriveGeneric
  , DerivingStrategies
  , FlexibleInstances
  , FunctionalDependencies
  , NamedFieldPuns
  , RecordWildCards
  , ScopedTypeVariables
  , TypeApplications
  , TypeFamilies
  , TypeOperators
  , UndecidableInstances
#-}

module TraversalC where

-- base
import Data.Foldable
  ( traverse_ )
import Data.Functor
  ( ($>) )
import Data.Kind
  ( Type )
import Data.Monoid
  ( Ap(..) )
import Foreign.Marshal.Alloc
  ( malloc, free )
import Foreign.Ptr
  ( Ptr )
import Foreign.Storable
  ( Storable(poke) )
import GHC.Generics
  ( Generic )
import GHC.TypeLits
  ( TypeError, ErrorMessage(..) )
import System.IO
  ( Handle, openFile, hClose, IOMode(ReadWriteMode) )

-- generic-lens
import Data.Generics.Product.Constraints
  ( HasConstraints(constraints) )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO(liftIO) )

-------------------------------------------------------------------
-- Basic resource status tracking system.

data ResourceStatus
  = Initialisable
  | Usable
  | Freed

data family Resource res (st :: ResourceStatus)
data instance Resource res Freed = ResourceFreed
-- ^ Could allow some information to be returned after freeing resources, but just returning a unit type for the moment.

class InitialiseResource ( m :: Type -> Type ) ( res :: Type ) ( st :: ResourceStatus ) where
  initialiseResource :: Resource res st -> m ( Resource res Usable )

instance Applicative m => InitialiseResource m res Usable where
  initialiseResource = pure
instance
  TypeError
    (    Text "Cannot initialise resource " :<>: ShowType res :<>: Text ":"
    :$$: Text "  resource has already been freed."
    )
  => InitialiseResource m res Freed where
  initialiseResource _ = error "unreachable"

class FreeResource ( m :: Type -> Type ) ( res :: Type ) ( st :: ResourceStatus ) where
  freeResource :: Resource res st -> m ( Resource res Freed )
instance Applicative m => FreeResource m res Initialisable where
  freeResource _ = pure ResourceFreed
instance Applicative m => FreeResource m res Freed where
  freeResource _ = pure ResourceFreed


-- Helper type classes for constrained traversals.

class    InitialiseIn ( m :: Type -> Type ) r1 r2 | r1 -> r2 where
  initialiseRes :: r1 -> m r2
instance ( r1 ~ Resource res st, r2 ~ Resource res Usable, InitialiseResource m res st )
      => InitialiseIn m r1 r2
      where
  initialiseRes = initialiseResource

class    FreeIn ( m :: Type -> Type ) r1 r2 | r1 -> r2 where
  freeRes :: r1 -> m r2
instance ( r1 ~ Resource res st, r2 ~ Resource res Freed, FreeResource m res st )
      => FreeIn m r1 r2
      where
  freeRes = freeResource

-------------------------------------------------------------------
-- Simple resource: storable type.

data Stored a
newtype instance Resource ( Stored a ) Initialisable = Store a
newtype instance Resource ( Stored a ) Usable        = StoredPtr ( Ptr a )

instance ( MonadIO m, Storable a ) => InitialiseResource m ( Stored a ) Initialisable where
  initialiseResource ( Store a ) = liftIO $ do
    ptr <- malloc
    poke ptr a
    pure ( StoredPtr ptr )
instance MonadIO m => FreeResource m ( Stored a ) Usable where
  freeResource ( StoredPtr ptr ) = liftIO ( free ptr ) $> ResourceFreed

-------------------------------------------------------------------
-- Simple resource: file handle.

data File

newtype instance Resource File Initialisable = FilePath   FilePath
newtype instance Resource File Usable        = FileHandle Handle

instance MonadIO m => InitialiseResource m File Initialisable where
  initialiseResource ( FilePath path ) = FileHandle <$> liftIO ( openFile path ReadWriteMode )
instance MonadIO m => FreeResource m File Usable where
  freeResource ( FileHandle handle ) = liftIO ( hClose handle ) $> ResourceFreed

-------------------------------------------------------------------
-- Traversable collection of resources.

newtype instance Resource ( Ap f a ) Initialisable = ApResI ( f ( Resource a Initialisable ) )
newtype instance Resource ( Ap f a ) Usable        = ApResU ( f ( Resource a Usable ) )

instance ( InitialiseResource m a Initialisable, Traversable f, Applicative m )
      => InitialiseResource m ( Ap f a ) Initialisable where
  initialiseResource ( ApResI resources ) =
    ApResU <$> traverse ( initialiseResource @m @a @Initialisable ) resources
instance ( FreeResource m a Usable, Foldable f, Applicative m )
      => FreeResource m ( Ap f a ) Usable where
  freeResource ( ApResU resources ) =
    traverse_ ( freeResource @m @a @Usable ) resources $> ResourceFreed

-------------------------------------------------------------------
-- Traversing collections of resources using @generic-lens@.

data Resources (st :: ResourceStatus) = Resources
  { resource1 :: Resource ( Stored Float ) st
  , resource2 :: Resource ( Ap [] ( Stored Double ) ) st
  }
  deriving stock Generic

initialResources :: Resources Initialisable
initialResources =
  Resources
    { resource1 = Store 0.11
    , resource2 = ApResI [ Store 6, Store 2, Store 8, Store 3, Store 1 ]
    }

example :: IO ()
example = do
  ( usableResources :: Resources Usable ) <-
    constraints @( InitialiseIn IO ) initialiseRes initialResources
  -- ... do things with resources
  ( _freedResources :: Resources Freed )
    <- constraints @( FreeIn IO ) freeRes usableResources
  pure ()