Resource.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}

-- | The contract a user resource type implements to participate in the graph.
module Fragr.Resource
  ( Resource (..)
  , Access (..)
  , accessId
  ) where

import Data.Text (Text)
import Type.Reflection

import Fragr.Types (Handle (..), QueueId, handleId)

{- |
The contract a user resource type must satisfy to participate in the
graph. @r@ is the resource object (e.g. a texture wrapper); 'Desc' is its
plain-data allocation descriptor; 'Alloc' and 'Ctx' are the opaque user
values forwarded from 'execute' to allocation and hooks respectively;
'Flags' is the per-access payload its hooks receive.

The hooks ('preRead', 'preWrite', 'preAcquire', 'preRelease'),
'isShared' and 'describeDesc' are optional; their defaults do nothing,
report unshared, and return the empty string.
-}
class (Typeable r, Ord (Flags r), Show (Flags r)) => Resource r where
  -- | Allocation descriptor (extent, format, size, ...). Immutable.
  type Desc r

  -- | Opaque allocator value passed through from 'execute'.
  type Alloc r

  -- | Opaque context value passed through from 'execute'.
  type Ctx r

  {- | Per-access flags handed to this resource's hooks: an image layout,
  a stage/access mask pair, whatever the backend diffs against. Any type
  with 'Ord' and 'Show' will do; defaults to @()@ for resources whose
  hooks need no payload.
  -}
  type Flags r

  type Flags r = ()

  {- | Materialize the resource. Called by the graph during 'execute',
  before the first pass that uses the resource.
  -}
  createResource :: Desc r -> Alloc r -> IO r

  {- | Release the resource. Called by the graph after the last pass that
  uses the resource.
  -}
  destroyResource :: Desc r -> Alloc r -> r -> IO ()

  {- | Hook invoked before a pass's execution callback, once per declared
  read with flags ('readWith'). The 'Handle' names the version node the
  access is behind — the same identity the schedule's 'Access' lists carry
  ('Fragr.Resource.accessId'), so a backend can key per-node decisions.
  -}
  preRead :: Handle r -> Desc r -> Flags r -> Ctx r -> r -> IO ()
  preRead _ _ _ _ _ = pure ()

  -- | Same as 'preRead', for declared writes ('writeWith').
  preWrite :: Handle r -> Desc r -> Flags r -> Ctx r -> r -> IO ()
  preWrite _ _ _ _ _ = pure ()

  {- | Hook invoked by 'executeQueued' on the consuming side of a
  cross-queue hand-off, before the pass's execution callback, once per
  'acquires' entry carrying flags. The 'QueueId' is the peer — the queue
  the resource is coming from — so a backend can name both sides of an
  ownership transfer.
  -}
  preAcquire :: Handle r -> Desc r -> Flags r -> QueueId -> Ctx r -> r -> IO ()
  preAcquire _ _ _ _ _ _ = pure ()

  {- | Hook invoked by 'executeQueued' on the producing side of a
  cross-queue hand-off, after the pass's execution callback, once per
  'releases' entry carrying flags — the consuming access's, so the
  producer knows the target state to release into. The 'QueueId' is the
  peer: the queue the resource is going to.
  -}
  preRelease :: Handle r -> Desc r -> Flags r -> QueueId -> Ctx r -> r -> IO ()
  preRelease _ _ _ _ _ _ = pure ()

  {- | Whether the allocation tolerates concurrent access from several
  queue families at once (Vulkan @CONCURRENT@ sharing). Imports read it
  off the object to exempt the entry from single-owner validation; a
  created transient has no object at registration, so mark those with
  'Fragr.Graph.markShared'.
  -}
  isShared :: r -> Bool
  isShared _ = False

  {- | Human-readable descriptor summary for visualization output.
  Call with an explicit type application: @describeDesc \@r desc@.
  -}
  describeDesc :: Desc r -> Text
  describeDesc _ = ""

{- | One declared access: a handle with the declaration's flags
('Nothing' for the flagless 'Fragr.Builder.read' / 'Fragr.Builder.write').
The handle's resource type is erased but keeps its flags honest.
-}
data Access = forall r. (Resource r) => Access
  { handle :: Handle r
  , flags :: Maybe (Flags r)
  }

-- | The node id behind the access's handle.
accessId :: Access -> Int
accessId Access{handle} = handleId handle

instance Eq Access where
  a == b = compare a b == EQ

-- Node id first; equal ids name one entry, hence one resource type, so
-- the flags tie-break always finds the 'HRefl' for honest handles.
instance Ord Access where
  compare (Access (h1 :: Handle r1) f1) (Access (h2 :: Handle r2) f2) =
    compare (handleId h1) (handleId h2) <> case eqTypeRep (typeRep @r1) (typeRep @r2) of
      Just HRefl -> compare f1 f2
      Nothing -> compare (SomeTypeRep (typeRep @r1)) (SomeTypeRep (typeRep @r2))

instance Show Access where
  showsPrec d (Access h f) =
    showParen (d > 10) $
      showString "Access {handle = "
        . shows h
        . showString ", flags = "
        . shows f
        . showString "}"