Change type of bracketing functions

They can now be used with more exception/resource libraries

They now take as their first argument a function with the shape of "bracket" or "allocate"

generate-new/src/Bracket.hs

@@ -1,34 +1,32 @@
 module Bracket
   where
 
-import           Relude                  hiding ( Handle
-                                                , Type
-                                                )
-import           Data.List.Extra                ( nubOrd
-                                                , elemIndex
+import           Data.List.Extra                ( elemIndex
+                                                , nubOrd
                                                 )
 import qualified Data.Text.Extra               as T
-import           Language.Haskell.TH            ( mkName )
 import           Data.Text.Prettyprint.Doc
                                          hiding ( brackets
                                                 , plural
                                                 )
+import           Language.Haskell.TH            ( mkName )
 import           Polysemy
 import           Polysemy.Input
+import           Relude                  hiding ( Handle
+                                                , Type
+                                                )
 
-import qualified Control.Exception
-
-import           Render.Element
-import           Render.Utils
-import           Render.SpecInfo
-import           Render.Command
-import           Render.Names
-import           Spec.Parse
-import           Haskell                       as H
 import           Error
-import           Marshal.Scheme
+import           Haskell                       as H
 import           Marshal.Command
+import           Marshal.Scheme
+import           Render.Command
+import           Render.Element
+import           Render.Names
 import           Render.Scheme
+import           Render.SpecInfo
+import           Render.Utils
+import           Spec.Parse
 
 data Bracket = Bracket
   { bInnerTypes          :: [MarshalScheme Parameter]
@@ -163,31 +161,33 @@ renderBracket paramName b@Bracket {..} =
           <=< schemeTypeNegative
           )
           [ t | Provided _ t <- arguments ]
-        let argHsVars = [ pretty (paramName v) | Provided v _ <- arguments ]
+        let argHsVars =
+              "b" : [ pretty (paramName v) | Provided v _ <- arguments ]
         innerHsType <- do
           ts <- traverse
             (   note "Inner type has no representation in a negative position"
             <=< schemeTypeNegative
             )
             bInnerTypes
           pure $ foldl' (:@) (TupleT (length ts)) ts
-        let noDestructorResource = not (any isResource bDestroyArguments)
-            noResource           = null bInnerTypes && noDestructorResource
-            cont                 = if noResource
-              then ConT ''IO :@ VarT (mkName "r")
-              else innerHsType ~> ConT ''IO :@ VarT (mkName "r")
-            wrapperType = foldr (~>)
-                                (ConT ''IO :@ VarT (mkName "r"))
-                                (argHsTypes ++ [cont])
-        constrainedType <- constrainStructVariables wrapperType
-        wrapperTDoc     <- renderType constrainedType
-        bracketDoc      <- if noResource
-          then do
-            tellImport 'Control.Exception.bracket_
-            pure "bracket_"
-          else do
-            tellImport 'Control.Exception.bracket
-            pure "bracket"
+        let
+          noDestructorResource = not (any isResource bDestroyArguments)
+          noResource           = null bInnerTypes && noDestructorResource
+          ioVar                = VarT (mkName "io")
+          rVar                 = VarT (mkName "r")
+          bracketTy            = if noResource
+            then (ioVar :@ innerHsType ~> (ioVar :@ ConT ''()) ~> rVar)
+            else
+              (  ioVar
+              :@ innerHsType
+              ~> (innerHsType ~> ioVar :@ ConT ''())
+              ~> rVar
+              )
+          wrapperType   = foldr (~>) rVar (bracketTy : argHsTypes)
+          bracketSuffix = bool "" "_" noResource
+        constrainedType <- addConstraints [ConT ''MonadIO :@ ioVar]
+          <$> constrainStructVariables wrapperType
+        wrapperTDoc <- renderType constrainedType
 
         --
         -- The actual function
@@ -197,29 +197,27 @@ renderBracket paramName b@Bracket {..} =
         tellDoc $ vsep
           [ comment
             (T.unlines
-              (  [ "A safe wrapper for '"
-                   <> unName create
-                   <> "' and '"
-                   <> unName destroy
-                   <> "' using '"
-                   <> bracketDoc
-                   <> "'"
-                 ]
-              <> bool
-                   [ ""
-                   , "The allocated value must not be returned from the provided computation"
-                   ]
-                   []
-                   noResource
+              ([ "A convenience wrapper to make a compatible pair of calls to '"
+               <> unName create
+               <> "' and '"
+               <> unName destroy
+               <> "'"
+               , ""
+               , "To ensure that '"
+               <> unName destroy
+               <> "' is always called: pass 'Control.Exception.bracket"
+               <> bracketSuffix
+               <> "' (or the allocate function from your favourite resource management library) as the first argument."
+               , "To just extract the pair pass '(,)' as the first argument."
+               , ""
+               ]
+              <> [ "Note that there is no inner resource" | noResource ]
               )
             )
           , pretty wrapperName <+> "::" <+> wrapperTDoc
           , pretty wrapperName <+> sep argHsVars <+> "=" <> line <> indent
             2
-            (pretty bracketDoc <> line <> indent
-              2
-              (vsep [parens createCall, parens destroyCall])
-            )
+            ("b" <+> indent 0 (vsep [parens createCall, parens destroyCall]))
           ]
 
 renderCreate

generate-new/src/Render/Command.hs

@@ -2,6 +2,7 @@
 module Render.Command
   ( renderCommand
   , constrainStructVariables
+  , addConstraints
   ) where
 
 import           Relude                  hiding ( Type
@@ -764,6 +765,8 @@ addMonadIO = addConstraints
 ioVar :: Name
 ioVar = mkName "io"
 
+-- | Any extensible structs have 'PokeChain' or 'PeekChain' constraints added
+-- depending on their position polarity.
 constrainStructVariables
   :: (HasErr r, HasRenderParams r, HasRenderElem r, HasRenderedNames r)
   => Type
@@ -778,6 +781,8 @@ constrainStructVariables t = do
     )
     t
 
+-- | Add constraints to a type, folding them into an existing forall if
+-- possible
 addConstraints :: [Pred] -> Type -> Type
 addConstraints new = quantifyType . \case
   ForallT vs ctx ty -> ForallT vs (ctx <> new) ty

src/Graphics/Vulkan/Core10/Buffer.hs

@@ -148,13 +148,17 @@ createBuffer device createInfo allocator = liftIO . evalContT $ do
   pBuffer <- lift $ peek @Buffer pPBuffer
   pure $ (pBuffer)
 
--- | A safe wrapper for 'createBuffer' and 'destroyBuffer' using 'bracket'
+-- | A convenience wrapper to make a compatible pair of 'createBuffer' and
+-- 'destroyBuffer'
 --
--- The allocated value must not be returned from the provided computation
-withBuffer :: forall a r . PokeChain a => Device -> BufferCreateInfo a -> Maybe AllocationCallbacks -> ((Buffer) -> IO r) -> IO r
-withBuffer device pCreateInfo pAllocator =
-  bracket
-    (createBuffer device pCreateInfo pAllocator)
+-- To ensure that 'destroyBuffer' is always called: pass
+-- 'Control.Exception.bracket' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+withBuffer :: forall a io r . (PokeChain a, MonadIO io) => (io (Buffer) -> ((Buffer) -> io ()) -> r) -> Device -> BufferCreateInfo a -> Maybe AllocationCallbacks -> r
+withBuffer b device pCreateInfo pAllocator =
+  b (createBuffer device pCreateInfo pAllocator)
     (\(o0) -> destroyBuffer device o0 pAllocator)
 
 

src/Graphics/Vulkan/Core10/BufferView.hs

@@ -120,14 +120,17 @@ createBufferView device createInfo allocator = liftIO . evalContT $ do
   pView <- lift $ peek @BufferView pPView
   pure $ (pView)
 
--- | A safe wrapper for 'createBufferView' and 'destroyBufferView' using
--- 'bracket'
---
--- The allocated value must not be returned from the provided computation
-withBufferView :: forall r . Device -> BufferViewCreateInfo -> Maybe AllocationCallbacks -> ((BufferView) -> IO r) -> IO r
-withBufferView device pCreateInfo pAllocator =
-  bracket
-    (createBufferView device pCreateInfo pAllocator)
+-- | A convenience wrapper to make a compatible pair of 'createBufferView'
+-- and 'destroyBufferView'
+--
+-- To ensure that 'destroyBufferView' is always called: pass
+-- 'Control.Exception.bracket' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+withBufferView :: forall io r . MonadIO io => (io (BufferView) -> ((BufferView) -> io ()) -> r) -> Device -> BufferViewCreateInfo -> Maybe AllocationCallbacks -> r
+withBufferView b device pCreateInfo pAllocator =
+  b (createBufferView device pCreateInfo pAllocator)
     (\(o0) -> destroyBufferView device o0 pAllocator)
 
 

src/Graphics/Vulkan/Core10/CommandBuffer.hs

@@ -12,7 +12,6 @@ module Graphics.Vulkan.Core10.CommandBuffer  ( allocateCommandBuffers
                                              ) where
 
 import Control.Exception.Base (bracket)
-import Control.Exception.Base (bracket_)
 import Control.Monad.IO.Class (liftIO)
 import Data.Typeable (eqT)
 import Foreign.Marshal.Alloc (allocaBytesAligned)
@@ -180,14 +179,17 @@ allocateCommandBuffers device allocateInfo = liftIO . evalContT $ do
     pure $ (\h -> CommandBuffer h cmds ) pCommandBuffersElem)
   pure $ (pCommandBuffers)
 
--- | A safe wrapper for 'allocateCommandBuffers' and 'freeCommandBuffers'
--- using 'bracket'
+-- | A convenience wrapper to make a compatible pair of
+-- 'allocateCommandBuffers' and 'freeCommandBuffers'
 --
--- The allocated value must not be returned from the provided computation
-withCommandBuffers :: forall r . Device -> CommandBufferAllocateInfo -> ((Vector CommandBuffer) -> IO r) -> IO r
-withCommandBuffers device pAllocateInfo =
-  bracket
-    (allocateCommandBuffers device pAllocateInfo)
+-- To ensure that 'freeCommandBuffers' is always called: pass
+-- 'Control.Exception.bracket' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+withCommandBuffers :: forall io r . MonadIO io => (io (Vector CommandBuffer) -> ((Vector CommandBuffer) -> io ()) -> r) -> Device -> CommandBufferAllocateInfo -> r
+withCommandBuffers b device pAllocateInfo =
+  b (allocateCommandBuffers device pAllocateInfo)
     (\(o0) -> freeCommandBuffers device (commandPool (pAllocateInfo :: CommandBufferAllocateInfo)) o0)
 
 
@@ -351,12 +353,18 @@ beginCommandBuffer commandBuffer beginInfo = liftIO . evalContT $ do
   r <- lift $ vkBeginCommandBuffer' (commandBufferHandle (commandBuffer)) pBeginInfo
   lift $ when (r < SUCCESS) (throwIO (VulkanException r))
 
--- | A safe wrapper for 'beginCommandBuffer' and 'endCommandBuffer' using
--- 'bracket_'
-useCommandBuffer :: forall a r . PokeChain a => CommandBuffer -> CommandBufferBeginInfo a -> IO r -> IO r
-useCommandBuffer commandBuffer pBeginInfo =
-  bracket_
-    (beginCommandBuffer commandBuffer pBeginInfo)
+-- | A convenience wrapper to make a compatible pair of 'beginCommandBuffer'
+-- and 'endCommandBuffer'
+--
+-- To ensure that 'endCommandBuffer' is always called: pass
+-- 'Control.Exception.bracket_' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+-- Note that there is no inner resource
+useCommandBuffer :: forall a io r . (PokeChain a, MonadIO io) => (io () -> io () -> r) -> CommandBuffer -> CommandBufferBeginInfo a -> r
+useCommandBuffer b commandBuffer pBeginInfo =
+  b (beginCommandBuffer commandBuffer pBeginInfo)
     (endCommandBuffer commandBuffer)
 
 

src/Graphics/Vulkan/Core10/CommandBufferBuilding.hs

@@ -57,7 +57,6 @@ module Graphics.Vulkan.Core10.CommandBufferBuilding  ( cmdBindPipeline
                                                      , ClearAttachment(..)
                                                      ) where
 
-import Control.Exception.Base (bracket_)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Typeable (eqT)
@@ -6618,11 +6617,18 @@ cmdBeginQuery commandBuffer queryPool query flags = liftIO $ do
   vkCmdBeginQuery' (commandBufferHandle (commandBuffer)) (queryPool) (query) (flags)
   pure $ ()
 
--- | A safe wrapper for 'cmdBeginQuery' and 'cmdEndQuery' using 'bracket_'
-cmdWithQuery :: forall r . CommandBuffer -> QueryPool -> Word32 -> QueryControlFlags -> IO r -> IO r
-cmdWithQuery commandBuffer queryPool query flags =
-  bracket_
-    (cmdBeginQuery commandBuffer queryPool query flags)
+-- | A convenience wrapper to make a compatible pair of 'cmdBeginQuery' and
+-- 'cmdEndQuery'
+--
+-- To ensure that 'cmdEndQuery' is always called: pass
+-- 'Control.Exception.bracket_' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+-- Note that there is no inner resource
+cmdWithQuery :: forall io r . MonadIO io => (io () -> io () -> r) -> CommandBuffer -> QueryPool -> Word32 -> QueryControlFlags -> r
+cmdWithQuery b commandBuffer queryPool query flags =
+  b (cmdBeginQuery commandBuffer queryPool query flags)
     (cmdEndQuery commandBuffer queryPool query)
 
 
@@ -7555,12 +7561,18 @@ cmdBeginRenderPass commandBuffer renderPassBegin contents = liftIO . evalContT $
   lift $ vkCmdBeginRenderPass' (commandBufferHandle (commandBuffer)) pRenderPassBegin (contents)
   pure $ ()
 
--- | A safe wrapper for 'cmdBeginRenderPass' and 'cmdEndRenderPass' using
--- 'bracket_'
-cmdWithRenderPass :: forall a r . PokeChain a => CommandBuffer -> RenderPassBeginInfo a -> SubpassContents -> IO r -> IO r
-cmdWithRenderPass commandBuffer pRenderPassBegin contents =
-  bracket_
-    (cmdBeginRenderPass commandBuffer pRenderPassBegin contents)
+-- | A convenience wrapper to make a compatible pair of 'cmdBeginRenderPass'
+-- and 'cmdEndRenderPass'
+--
+-- To ensure that 'cmdEndRenderPass' is always called: pass
+-- 'Control.Exception.bracket_' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+-- Note that there is no inner resource
+cmdWithRenderPass :: forall a io r . (PokeChain a, MonadIO io) => (io () -> io () -> r) -> CommandBuffer -> RenderPassBeginInfo a -> SubpassContents -> r
+cmdWithRenderPass b commandBuffer pRenderPassBegin contents =
+  b (cmdBeginRenderPass commandBuffer pRenderPassBegin contents)
     (cmdEndRenderPass commandBuffer)
 
 

src/Graphics/Vulkan/Core10/CommandPool.hs

@@ -127,14 +127,17 @@ createCommandPool device createInfo allocator = liftIO . evalContT $ do
   pCommandPool <- lift $ peek @CommandPool pPCommandPool
   pure $ (pCommandPool)
 
--- | A safe wrapper for 'createCommandPool' and 'destroyCommandPool' using
--- 'bracket'
---
--- The allocated value must not be returned from the provided computation
-withCommandPool :: forall r . Device -> CommandPoolCreateInfo -> Maybe AllocationCallbacks -> ((CommandPool) -> IO r) -> IO r
-withCommandPool device pCreateInfo pAllocator =
-  bracket
-    (createCommandPool device pCreateInfo pAllocator)
+-- | A convenience wrapper to make a compatible pair of 'createCommandPool'
+-- and 'destroyCommandPool'
+--
+-- To ensure that 'destroyCommandPool' is always called: pass
+-- 'Control.Exception.bracket' (or the allocate function from your
+-- favourite resource management library) as the first argument.
+-- To just extract the pair pass '(,)' as the first argument.
+--
+withCommandPool :: forall io r . MonadIO io => (io (CommandPool) -> ((CommandPool) -> io ()) -> r) -> Device -> CommandPoolCreateInfo -> Maybe AllocationCallbacks -> r
+withCommandPool b device pCreateInfo pAllocator =
+  b (createCommandPool device pCreateInfo pAllocator)
     (\(o0) -> destroyCommandPool device o0 pAllocator)