keid-core 0.1.6.0 → 0.1.6.1

raw patch · 21 files changed

+546/−87 lines, 21 filesdep −adjunctionsdep −distributivedep ~vulkanPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: adjunctions, distributive

Dependency ranges changed: vulkan

API changes (from Hackage documentation)

Files

• ChangeLog.md +19/−0
• keid-core.cabal +6/−4
• src/Engine/Frame.hs +21/−9
• src/Engine/Render.hs +4/−4
• src/Engine/Run.hs +30/−17
• src/Engine/Setup.hs +8/−7
• src/Engine/Types.hs +3/−1
• src/Engine/Types/Options.hs +9/−3
• src/Engine/UI/Layout.hs +4/−15
• src/Engine/UI/Layout/Linear.hs +129/−0
• src/Engine/Vulkan/Pipeline.hs +1/−1
• src/Engine/Window/MouseButton.hs +51/−0
• src/Engine/Worker.hs +8/−8
• src/Render/Samplers.hs +3/−9
• src/Resource/Buffer.hs +36/−0
• src/Resource/Collection.hs +18/−2
• src/Resource/Collection/Generic.hs +64/−0
• src/Resource/Image/Atlas.hs +52/−0
• src/Resource/Region.hs +71/−0
• src/Resource/Source.hs +7/−6
• src/Resource/Texture.hs +2/−1

@@ -1,5 +1,24 @@ # Changelog for keid-core +## 0.1.6.1++- Minimal `vulkan` version is now 3.17.+- Fixed VMA setup for headless rendering.+- Add `Generically1` from `base-4.17` to replace `distributive`/`repesentable`.+- `Engine.Worker.Cell` instances generalized to arbitrary pairs.+  * I.e. `(Var i, Var o)` is a `Cell`-like structure that can be driven externally+    while retaining the `Var` and `Observer` machinery.+- `withFrozenCallStack` fixes for GHC-9.0.+- `Engine.Worker` boilerplate for coherent `Resource.Buffer`.+- Added `Resource.Image.Atlas` experimental container for tile atlases.+- Added `Resource.Region` for detachable allocation scopes.+- Added `Engine.Window.MouseButton.Collection` to facilitate button-related dispatch.+- Added a shortcut around loop when a window is quitting.+  * Skips allocation of loop resources that wouldn't be used.+  * Sidesteps a race before release/allocate chain when unwinding stages leading to crashes.+- Added `Engine.UI.Layout.Linear`.+  * Experimental for now, but require no workers and FRP-compatible.+ ## 0.1.6.0  - Added `Engine.Camera` with projection and view controls.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.6.0+version:        0.1.6.1 synopsis:       Core parts of Keid engine. category:       Game Engine homepage:       https://keid.haskell-game.dev@@ -48,6 +48,7 @@       Engine.Types.Options       Engine.Types.RefCounted       Engine.UI.Layout+      Engine.UI.Layout.Linear       Engine.Vulkan.DescSets       Engine.Vulkan.Pipeline       Engine.Vulkan.Pipeline.Compute@@ -68,15 +69,18 @@       Render.Samplers       Resource.Buffer       Resource.Collection+      Resource.Collection.Generic       Resource.Combined.Textures       Resource.CommandBuffer       Resource.Compressed.Zstd       Resource.DescriptorSet       Resource.Image+      Resource.Image.Atlas       Resource.Mesh.Codec       Resource.Mesh.Types       Resource.Mesh.Utils       Resource.Model+      Resource.Region       Resource.Source       Resource.Static       Resource.Texture@@ -147,14 +151,12 @@       GLFW-b     , StateVar     , VulkanMemoryAllocator-    , adjunctions     , base >=4.7 && <5     , binary     , bytestring     , cryptohash-md5     , derive-storable     , derive-storable-plugin-    , distributive     , file-embed     , foldl     , geomancy@@ -173,7 +175,7 @@     , unagi-chan     , unliftio     , vector-    , vulkan+    , vulkan >=3.17     , vulkan-utils     , zstd   default-language: Haskell2010

@@ -16,6 +16,7 @@ import Control.Monad.Trans.Resource qualified as ResourceT import GHC.IO.Exception (IOErrorType(TimeExpired), IOException(IOError)) import RIO.App (appEnv)+import RIO.Text qualified as Text import RIO.Vector qualified as Vector import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk@@ -138,10 +139,19 @@    -- Handle mvar indefinite timeout exception here:   -- https://github.com/expipiplus1/vulkan/issues/236-  fRecycledResources <- liftIO $-    waitDumped >>= \case+  fRecycledResources <-+    liftIO waitDumped >>= \case       Left block ->-        block+        timeout 15e6 (liftIO block) >>= \case+          Nothing -> do+            logError . display $ Text.unwords+              [ "Timed out waiting for recycled resources."+              , "A recycler thread is stuck on timeline semaphore or something."+              , "Try running with --recycler-wait 15000 or a similar value."+              ]+            exitFailure+          Just rr ->+            pure rr       Right rs ->         pure rs @@ -196,29 +206,31 @@      , MonadResource (RIO env)      )   => (RecycledResources rr -> IO ())+  -> Maybe Int   -> RIO (env, Frame rp p rr) a   -> Frame rp p rr   -> RIO env a-run recycle render frame@Frame{..} = do+run recycle recyclerWait render frame@Frame{..} = do   env <- ask   runRIO (env, frame) render `finally` void (spawn flush)   where     flush = do       device <- asks getDevice       waits <- readIORef fGPUWork-      let oneSecondKhr = 1e9+      let tenSecondsKhr = 10e9       -- logDebug $ "Waiting Frame " <> displayShow fIndex        unless (null waits) do+        traverse_ threadDelay recyclerWait         let           waitInfo = zero             { Vk12.semaphores = Vector.fromList (map fst waits)             , Vk12.values     = Vector.fromList (map snd waits)             }-        waitTwice waitInfo oneSecondKhr >>= \case+        waitTwice waitInfo tenSecondsKhr >>= \case           Vk.TIMEOUT -> do-            logError "Time out (1s) waiting for frame to finish on Device"-            timeoutError "Time out (1s) waiting for frame to finish on Device"+            logError "Time out (10s) waiting for frame to finish on Device"+            timeoutError "Time out (10s) waiting for frame to finish on Device"             {-               XXX: recycler thread will crash now, never recycling its resources,               resulting in an indefinite MVar block.@@ -317,7 +329,7 @@   device <- asks getDevice   Vk12.waitSemaphoresSafe device waitInfo t >>= \case     Vk.TIMEOUT -> do-      r <- Vk12.waitSemaphores device waitInfo 0+      r <- Vk12.waitSemaphoresSafe device waitInfo 1e3       logWarn $ mconcat         [ "waiting a second time on " <> displayShow waitInfo         , " got " <> displayShow r

@@ -112,10 +112,10 @@         Vk.SUCCESS ->           pure ()         Vk.SUBOPTIMAL_KHR -> do-          logWarn "[present] Swapchain is suboptimal, forcing update."+          logDebug "[present] Swapchain is suboptimal, forcing update."           throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR         _ ->-          -- TODO: check for SUBOPTIMAL_KHR+          -- TODO: check for ERROR_OUT_OF_DATE_KHR           logWarn $ "Presenting wasn't quite successful: " <> displayShow presentRes    case res of@@ -131,14 +131,14 @@         Throwing an exception for 'Engine.Vulkan.Swapchain.threwSwapchainError' to catch.         See also: 'Engine.Run.step'.       -}-      logWarn "Swapchain out of date"+      logDebug "[acquire] Swapchain out of date"       throwM $ VulkanException res      Vk.SUBOPTIMAL_KHR -> do       {- XXX:         Converting 'Vk.SUBOPTIMAL_KHR' error to OOD to trigger swapchain update.       -}-      logWarn "[acquire] Swapchain is suboptimal, forcing update."+      logDebug "[acquire] Swapchain is suboptimal, forcing update."       throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR      _ -> do

@@ -18,6 +18,8 @@ import Engine.Render (renderFrame) import Engine.StageSwitch (getNextStage) import Engine.Types (Frame, NextStage(..), RecycledResources, StageStack, StackStage(..), Stage(..), StageRIO)+import Engine.Types qualified as Engine+import Engine.Types.Options (optionsRecyclerWait) import Engine.Types.RefCounted (releaseRefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError) import Engine.Vulkan.Types (RenderPass, getDevice)@@ -109,23 +111,32 @@    startFrame <- Frame.initial oldSR (drDump recycler) stage -  logInfo $ "Entering stage loop: " <> display sTitle-  startTime <- getMonotonicTime-  (finalFrame, stageAction) <- bracket sBeforeLoop sAfterLoop \_stagePrivates ->-    stageLoop (step stKey stage recycler) startFrame-  endTime <- getMonotonicTime-  let-    frames  = Frame.fIndex finalFrame-    seconds = endTime - startTime+  Engine.GlobalHandles{ghWindow} <- asks appEnv+  quit <- liftIO $ GLFW.windowShouldClose ghWindow+  if quit then do+    logDebug $ "Forcing stage unwind for " <> display sTitle+    pure+      ( Frame.fSwapchainResources startFrame+      , StageDone+      )+  else do+    logInfo $ "Entering stage loop: " <> display sTitle+    startTime <- getMonotonicTime+    (finalFrame, stageAction) <- bracket sBeforeLoop sAfterLoop \_stagePrivates ->+      stageLoop (step stKey stage recycler) startFrame+    endTime <- getMonotonicTime+    let+      frames  = Frame.fIndex finalFrame+      seconds = endTime - startTime -  logInfo $ "Stage finished: " <> display sTitle-  logInfo $ "Running time: " <> display seconds-  logInfo $ "Average FPS: " <> display (fromIntegral frames / seconds)-  releaseRefCounted $ fst (Frame.fStageResources finalFrame)-  pure-    ( Frame.fSwapchainResources finalFrame-    , stageAction-    )+    logInfo $ "Stage finished: " <> display sTitle+    logInfo $ "Running time: " <> display seconds+    logInfo $ "Average FPS: " <> display (fromIntegral frames / seconds)+    releaseRefCounted $ fst (Frame.fStageResources finalFrame)+    pure+      ( Frame.fSwapchainResources finalFrame+      , stageAction+      )  step   :: RenderPass rp@@ -146,8 +157,10 @@     getNextStage >>= \case       Nothing -> do         needsNewSwapchain <- threwSwapchainError do+          Engine.GlobalHandles{ghOptions} <- asks appEnv+          let recyclerWait = optionsRecyclerWait ghOptions           rs <- get-          Frame.run drDump (renderFrame (sUpdateBuffers rs) sRecordCommands) frame+          Frame.run drDump recyclerWait (renderFrame (sUpdateBuffers rs) sRecordCommands) frame         nextFrame <- Frame.advance drWait frame needsNewSwapchain          pure $ LoopNextFrame nextFrame

@@ -35,12 +35,12 @@      , MonadResource (RIO env)      )   => Options -> RIO env (GlobalHandles, Maybe SwapchainResources)-setup opts = do-  logDebug $ displayShow opts+setup ghOptions = do+  logDebug $ displayShow ghOptions    (windowReqs, ghWindow) <- Window.allocate-    (optionsFullscreen opts)-    (optionsDisplay opts)+    (optionsFullscreen ghOptions)+    (optionsDisplay ghOptions)     Window.pickLargest     "Keid Engine" @@ -128,9 +128,10 @@   let     allocatorCI :: VMA.AllocatorCreateInfo     allocatorCI = zero-      { VMA.physicalDevice = Vk.physicalDeviceHandle ghPhysicalDevice-      , VMA.device         = Vk.deviceHandle ghDevice-      , VMA.instance'      = Vk.instanceHandle ghInstance+      { VMA.physicalDevice  = Vk.physicalDeviceHandle ghPhysicalDevice+      , VMA.device          = Vk.deviceHandle ghDevice+      , VMA.instance'       = Vk.instanceHandle ghInstance+      , VMA.vulkanFunctions = Just $ vmaVulkanFunctions ghDevice ghInstance       }   (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate   toIO (logDebug "Releasing VMA") >>= Resource.register

@@ -20,12 +20,14 @@ import Engine.Vulkan.Types (HasVulkan(..)) import Engine.Vulkan.Types qualified as Vulkan import Engine.Worker qualified as Worker+import Engine.Types.Options (Options)  -- * App globals  -- | A bunch of global, unchanging state we cart around data GlobalHandles = GlobalHandles-  { ghWindow             :: GLFW.Window+  { ghOptions            :: Options+  , ghWindow             :: GLFW.Window   , ghSurface            :: Khr.SurfaceKHR   , ghInstance           :: Vk.Instance   , ghPhysicalDevice     :: Vk.PhysicalDevice

@@ -12,9 +12,10 @@  -- | Command line arguments data Options = Options-  { optionsVerbose    :: Bool-  , optionsFullscreen :: Bool-  , optionsDisplay    :: Natural+  { optionsVerbose      :: Bool+  , optionsFullscreen   :: Bool+  , optionsDisplay      :: Natural+  , optionsRecyclerWait :: Maybe Int   }   deriving (Show) @@ -52,6 +53,11 @@     [ Opt.long "display"     , Opt.help "Select display number"     , Opt.value 0+    ]++  optionsRecyclerWait <- Opt.optional . Opt.option Opt.auto $ mconcat+    [ Opt.long "recycler-wait"+    , Opt.help "Inject a delay before waiting for a timeline semaphore."     ]    pure Options{..}

@@ -343,18 +343,7 @@  pointInBox :: Vec2 -> Box -> Bool pointInBox point Box{..} =-  withVec2 point \px py ->-    withVec2 boxPosition \bx by ->-      withVec2 boxSize \w h ->-        let-          halfWidth  = w / 2-          halfHeight = h / 2-          left   = bx - halfWidth-          right  = bx + halfWidth-          top    = by - halfHeight-          bottom = by + halfHeight-        in-          px >= left &&-          px <= right &&-          py >= top &&-          py <= bottom+  withVec2 (point - boxPosition) \px py ->+    withVec2 (boxSize / 2) \hw hh ->+      px > -hw && px < hw &&+      py > -hh && py < hh

@@ -0,0 +1,129 @@+module Engine.UI.Layout.Linear+  ( hBoxShares+  , hBoxSplitRel++  , vBoxShares+  , vBoxSplitRel++  , placeBox+  , place++  , ranges+  , midpoints+  ) where++import RIO++import Data.Traversable (mapAccumL)+import Engine.UI.Layout qualified as Layout+import Geomancy (Vec2, vec2, withVec2, pattern WithVec2)++{-# INLINEABLE hBoxShares #-}+hBoxShares+  :: Traversable t+  => t Float+  -> Layout.Box+  -> t Layout.Box+hBoxShares items parent = fmap mkBox ranges'+  where+    mkBox (left, right) = Layout.Box+      { boxPosition =+          Layout.boxPosition parent ++          vec2 (midpoint * scale - parentWidth * 0.5) 0+      , boxSize =+          vec2 (size * scale) parentHeight+      }+      where+        size = right - left+        midpoint = right * 0.5 + left * 0.5++    (final, ranges') = ranges items+    scale = parentWidth / final+    WithVec2 parentWidth parentHeight = Layout.boxSize parent++{-# INLINEABLE hBoxSplitRel #-}+hBoxSplitRel :: Float -> Layout.Box -> (Layout.Box, Layout.Box)+hBoxSplitRel alpha parent =+  case hBoxShares @[] [alpha, 1 - alpha] parent of+    [left, right] ->+      (left, right)+    _ ->+      error "requesting a pair"++{-# INLINEABLE vBoxShares #-}+vBoxShares+  :: Traversable t+  => t Float+  -> Layout.Box+  -> t Layout.Box+vBoxShares items parent = fmap mkBox ranges'+  where+    mkBox (top, bottom) = Layout.Box+      { boxPosition =+          Layout.boxPosition parent ++          vec2 0 (midpoint * scale - parentHeight * 0.5)+      , boxSize =+          vec2 parentWidth (size * scale)+      }+      where+        size = bottom - top+        midpoint = bottom * 0.5 + top * 0.5++    (final, ranges') = ranges items+    scale = parentHeight / final+    WithVec2 parentWidth parentHeight = Layout.boxSize parent++{-# INLINEABLE vBoxSplitRel #-}+vBoxSplitRel :: Float -> Layout.Box -> (Layout.Box, Layout.Box)+vBoxSplitRel alpha parent =+  case vBoxShares @[] [alpha, 1 - alpha] parent of+    [top, bottom] ->+      (top, bottom)+    _ ->+      error "requesting a pair"++{-# INLINEABLE placeBox #-}+placeBox :: Vec2 -> Vec2 -> Layout.Box -> Layout.Box+placeBox alpha2 size parent =+  withVec2 alpha2 \ax ay ->+  withVec2 size \w h ->+  withVec2 (Layout.boxSize parent) \pw ph ->+  withVec2 (Layout.boxPosition parent) \px py ->+    let+      x = px + left * 0.5 - right * 0.5+      y = py + top * 0.5 - bottom * 0.5++      (left, right) = place ax w pw+      (top, bottom) = place ay h ph+    in+      Layout.Box+        { boxPosition = vec2 x y+        , boxSize     = size+        }++{-# INLINE place #-}+place :: Num b => b -> b -> b -> (b, b)+place alpha size target =+  ( leftovers * alpha+  , leftovers * (1 - alpha)+  )+  where+    leftovers = target - size++{-# INLINE midpoints #-}+midpoints :: (Functor f, Fractional a) => f (a, a) -> f a+midpoints =+  fmap \(begin, end) ->+    begin * 0.5 + end * 0.5++{-# INLINE ranges #-}+ranges :: (Traversable t, Num a) => t a -> (a, t (a, a))+ranges = mapAccumL f 0+  where+    f !begin size =+      let+        !end = begin + size+      in+        ( end+        , (begin, end)+        )

@@ -210,7 +210,7 @@       , Vk.vertexInputState   = Just cVertexInput       , Vk.inputAssemblyState = Just inputAsembly       , Vk.viewportState      = Just $ SomeStruct viewportState-      , Vk.rasterizationState = SomeStruct rasterizationState+      , Vk.rasterizationState = Just $ SomeStruct rasterizationState       , Vk.multisampleState   = Just $ SomeStruct multisampleState       , Vk.depthStencilState  = Just depthStencilState       , Vk.colorBlendState    = Just $ SomeStruct colorBlendState

@@ -7,6 +7,14 @@   , GLFW.ModifierKeys(..)    , mkCallback++  , mouseButtonState+  , whenPressed+  , whenReleased++  , Collection(..)+  , collectionGlfw+  , atGlfw   ) where  import RIO@@ -15,6 +23,7 @@ import RIO.App (appEnv) import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource+import Resource.Collection (Generic1, Generically1(..))  import Engine.Types (GlobalHandles(..), StageRIO) @@ -32,3 +41,45 @@ mkCallback (UnliftIO ul) action =   \_window button buttonState mods ->     ul $ action (mods, buttonState, button)++{-# INLINE mouseButtonState #-}+mouseButtonState :: a -> a -> GLFW.MouseButtonState -> a+mouseButtonState pressed released = \case+  GLFW.MouseButtonState'Pressed  -> pressed+  GLFW.MouseButtonState'Released -> released++{-# INLINE whenPressed #-}+whenPressed :: Applicative f => GLFW.MouseButtonState -> f () -> f ()+whenPressed mbs action = mouseButtonState action (pure ()) mbs++{-# INLINE whenReleased #-}+whenReleased :: Applicative f => GLFW.MouseButtonState -> f () -> f ()+whenReleased mbs action = mouseButtonState (pure ()) action mbs++data Collection a = Collection+  { mb1, mb2, mb3, mb4, mb5, mb6, mb7, mb8 :: a }+  deriving (Eq, Ord, Show, Generic1, Functor, Foldable, Traversable)+  deriving Applicative via Generically1 Collection++collectionGlfw :: Collection GLFW.MouseButton+collectionGlfw = Collection+  GLFW.MouseButton'1+  GLFW.MouseButton'2+  GLFW.MouseButton'3+  GLFW.MouseButton'4+  GLFW.MouseButton'5+  GLFW.MouseButton'6+  GLFW.MouseButton'7+  GLFW.MouseButton'8++{-# INLINE atGlfw #-}+atGlfw :: Collection a -> GLFW.MouseButton -> a+atGlfw Collection{..} = \case+  GLFW.MouseButton'1 -> mb1+  GLFW.MouseButton'2 -> mb2+  GLFW.MouseButton'3 -> mb3+  GLFW.MouseButton'4 -> mb4+  GLFW.MouseButton'5 -> mb5+  GLFW.MouseButton'6 -> mb6+  GLFW.MouseButton'7 -> mb7+  GLFW.MouseButton'8 -> mb8

@@ -135,12 +135,12 @@   type GetInput a   getInput :: a -> Var (GetInput a) -instance HasInput (TVar (Versioned a)) where-  type GetInput (TVar (Versioned a)) = a+instance HasInput (Var a) where+  type GetInput (Var a) = a   getInput = id -instance HasInput (Cell i o) where-  type GetInput (Cell i o) = i+instance HasInput a => HasInput (a, b) where+  type GetInput (a, b) = GetInput a   getInput = getInput . fst  {-# INLINEABLE pushInput #-}@@ -214,12 +214,12 @@   type GetOutput a   getOutput  :: a -> Var (GetOutput a) -instance HasOutput (TVar (Versioned a)) where-  type GetOutput (TVar (Versioned a)) = a+instance HasOutput (Var a) where+  type GetOutput (Var a) = a   getOutput = id -instance HasOutput (Var i, Merge o) where-  type GetOutput (Var i, Merge o) = o+instance HasOutput b => HasOutput (a, b) where+  type GetOutput (a, b) = GetOutput b   getOutput = getOutput . snd  {-# INLINEABLE pushOutput #-}

@@ -14,9 +14,6 @@ import RIO  import Control.Monad.Trans.Resource qualified as Resource-import Data.Distributive (Distributive(..))-import Data.Distributive.Generic (genericCollect)-import Data.Functor.Rep (Co(..), Representable) import GHC.Generics (Generic1) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::))@@ -24,6 +21,7 @@  import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan) import Resource.Collection qualified as Collection+import Resource.Collection (Generically1(..))  data Collection a = Collection   { linearMipRepeat  :: a -- 0@@ -35,12 +33,8 @@   , nearestRepeat    :: a -- 6   , nearest          :: a -- 7   }-  deriving stock (Show, Functor, Foldable, Traversable, Generic, Generic1)-  deriving Applicative via (Co Collection)-  deriving anyclass (Representable)--instance Distributive Collection where-  collect = genericCollect+  deriving stock (Show, Functor, Foldable, Traversable, Generic1)+  deriving Applicative via Generically1 Collection  type Params = (Vk.Filter, "LOD clamp" ::: Float, Vk.SamplerAddressMode) 

@@ -12,7 +12,9 @@ import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA +import Engine.Types (StageRIO) import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer))+import Engine.Worker qualified as Worker import Resource.CommandBuffer (oneshot_)  data Store = Staged | Coherent@@ -215,3 +217,37 @@   oneshot_ context commandQueues qTransfer \cmd ->     Vk.cmdCopyBuffer cmd src dst       (pure $ Vk.BufferCopy 0 0 sizeBytes)++type ObserverCoherent a = Worker.ObserverIO (Allocated 'Coherent a)++newObserverCoherent+  :: Storable a+  => Vk.BufferUsageFlagBits+  -> Int+  -> Resource.ResourceT (StageRIO st) (ObserverCoherent a)+newObserverCoherent usage initialSize = do+  context <- ask++  initialBuffer <- createCoherent context usage initialSize mempty+  observer <- Worker.newObserverIO initialBuffer++  void $! Resource.register do+    currentBuffer <- Worker.readObservedIO observer+    destroy context currentBuffer++  pure observer++{-# INLINE observeCoherentResize_ #-}+observeCoherentResize_+  :: ( HasVulkan env+     , Worker.HasOutput source+     , Worker.GetOutput source ~ VectorS.Vector output+     , Storable output+     )+  => source+  -> ObserverCoherent output+  -> RIO env ()+observeCoherentResize_ source observer = do+  context <- ask+  Worker.observeIO_ source observer $+    updateCoherentResize_ context

@@ -3,14 +3,18 @@   , size   , toVector   , toVectorStorable++  , Generic1+  , Generically1(..)   ) where  import RIO -import RIO.Vector qualified as Vector-import RIO.Vector.Storable qualified as VectorStorable import Data.List qualified as List import Data.Traversable (mapAccumL)+import Resource.Collection.Generic (Generic1, Generically1(..))+import RIO.Vector qualified as Vector+import RIO.Vector.Storable qualified as VectorStorable  {-# INLINE size #-} size :: (Foldable t, Num size) => t a -> size@@ -31,3 +35,15 @@   => collection a   -> VectorStorable.Vector a toVectorStorable = VectorStorable.fromList . toList++data Example a = Example+  { one :: a+  , two :: a+  -- , nay :: Bool+  , huh :: [Bool]+  }+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1)+  deriving Applicative via Generically1 Example++_example :: Example (Char, Int)+_example = (,) <$> pure '!' <*> pure 2

@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+  Compatibility copypasta from the future to derive Applicative without+  incurring dependency and boilerplate from "Distributive"/"Representable".+-}+module Resource.Collection.Generic+  ( Generic1(..)+  , Generically1(..)+  ) where++import RIO++import Control.Applicative (Alternative(..))+import Data.Kind (Type)+import GHC.Generics++#if !MIN_VERSION_base(4,17,0)++type    Generically1 :: forall k. (k -> Type) -> (k -> Type)+newtype Generically1 f a where+#if MIN_VERSION_base(4,16,0)+  -- Generically1 :: forall {k} f a. f a -> Generically1 @k f a+#endif+  Generically1 :: f a -> Generically1 f a++-- | @since 4.17.0.0+instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where+  fmap :: (a -> a') -> (Generically1 f a -> Generically1 f a')+  fmap f (Generically1 as) = Generically1+    (to1 (fmap f (from1 as)))++  (<$) :: a -> Generically1 f b -> Generically1 f a+  a <$ Generically1 as = Generically1+    (to1 (a <$ from1 as))++-- | @since 4.17.0.0+instance (Generic1 f, Applicative (Rep1 f)) => Applicative (Generically1 f) where+  pure :: a -> Generically1 f a+  pure a = Generically1+    (to1 (pure a))++  (<*>) :: Generically1 f (a1 -> a2) -> Generically1 f a1 -> Generically1 f a2+  Generically1 fs <*> Generically1 as = Generically1+    (to1 (from1 fs <*> from1 as))++  liftA2 :: (a1 -> a2 -> a3)+         -> (Generically1 f a1 -> Generically1 f a2 -> Generically1 f a3)+  liftA2 (·) (Generically1 as) (Generically1 bs) = Generically1+    (to1 (liftA2 (·) (from1 as) (from1 bs)))++-- | @since 4.17.0.0+instance (Generic1 f, Alternative (Rep1 f)) => Alternative (Generically1 f) where+  empty :: Generically1 f a+  empty = Generically1+    (to1 empty)++  (<|>) :: Generically1 f a -> Generically1 f a -> Generically1 f a+  Generically1 as1 <|> Generically1 as2 = Generically1+    (to1 (from1 as1 <|> from1 as2))++#endif

@@ -0,0 +1,52 @@+module Resource.Image.Atlas+  ( Atlas(..)+  , fromTileSize+  , fromImageSize+  ) where++import RIO++import Geomancy (UVec2, Vec2, uvec2, withUVec2, vec2)++-- | Regular grid atlas+data Atlas = Atlas+  { sizeTiles  :: UVec2+  , sizePx     :: UVec2+  , tileSizePx :: UVec2+  , marginPx   :: UVec2+  , uvScale    :: Vec2+  }+  deriving (Eq, Show, Generic)++fromTileSize :: UVec2 -> UVec2 -> UVec2 -> Atlas+fromTileSize sizeTiles tileSizePx marginPx = Atlas{..}+  where+    sizePx = sizeTiles * tileSizePx + (sizeTiles - 1) * marginPx+    uvScale = fromU tileSizePx / fromU sizePx++fromImageSize :: UVec2 -> UVec2 -> UVec2 -> Either UVec2 Atlas+fromImageSize sizePx tileSizePx marginPx =+  if leftovers == totalMargins then+    Right Atlas{..}+  else+    Left leftovers+  where+    totalMargins = (sizeTiles - 1) * marginPx++    (sizeTiles, leftovers) =+      withUVec2 sizePx \aw ah ->+      withUVec2 tileSizePx \tw th ->+        let+          (w, wRem) = aw `divMod` tw+          (h, hRem) = ah `divMod` th+        in+          ( uvec2 w h+          , uvec2 wRem hRem+          )++    uvScale = fromU tileSizePx / fromU sizePx++fromU :: UVec2 -> Vec2+fromU u =+  withUVec2 u \x y ->+    vec2 (fromIntegral x) (fromIntegral y)

@@ -0,0 +1,71 @@+module Resource.Region+  ( run+  , exec+  , eval++  , local+  , local_++  , register_+  , attach+  , attachAsync++  , logDebug++  , ReleaseKey+  , ResourceT.release+  ) where++import RIO hiding (local, logDebug)++import Control.Monad.Trans.Resource (MonadResource, ResourceT, ReleaseKey)+import Control.Monad.Trans.Resource qualified as ResourceT+import GHC.Stack (withFrozenCallStack)+import RIO qualified++run :: MonadResource m => ResourceT m a -> m (ReleaseKey, a)+run action = do+  regionResource <- ResourceT.createInternalState+  regionKey <- ResourceT.register $ ResourceT.closeInternalState regionResource+  resource <- ResourceT.runInternalState action regionResource+  pure (regionKey, resource)++exec :: MonadResource m => ResourceT m a -> m ReleaseKey+exec = fmap fst . run++eval :: MonadResource m => ResourceT m a -> m a+eval = fmap snd . run++local :: MonadResource m => m (ReleaseKey, a) -> ResourceT m a+local action = do+  (key, resource) <- lift action+  ResourceT.register $+    ResourceT.release key+  pure resource++local_ :: MonadResource m => m ReleaseKey -> ResourceT m ()+local_ action = do+  key <- lift action+  void . ResourceT.register $+    ResourceT.release key++register_ :: MonadUnliftIO m => IO () -> ResourceT m ()+register_ = void . ResourceT.register++attach :: MonadUnliftIO m => ReleaseKey -> ResourceT m ()+attach = register_ . ResourceT.release++attachAsync :: MonadUnliftIO m => Async a -> ResourceT m ()+attachAsync = register_ . cancel++logDebug+  :: ( MonadUnliftIO m+     , MonadReader env m, HasLogFunc env+     , HasCallStack+     )+  => Utf8Builder+  -> Utf8Builder+  -> ResourceT m ()+logDebug enter leave = withFrozenCallStack $ do+  RIO.logDebug enter+  toIO (RIO.logDebug leave) >>= register_

@@ -43,12 +43,13 @@   -> m a load action = \case   Bytes label !bytes -> do-    withFrozenCallStack . logDebug $-      case label of-        Nothing ->-          "Loading " <> displayShow (typeRep $ Proxy @a)-        Just someText ->-          "Loading " <> displayShow (typeRep $ Proxy @a) <> " from " <> display someText+    withFrozenCallStack $+      logDebug $+        case label of+          Nothing ->+            "Loading " <> displayShow (typeRep $ Proxy @a)+          Just someText ->+            "Loading " <> displayShow (typeRep $ Proxy @a) <> " from " <> display someText     action bytes    BytesZstd label !bytesZstd ->

@@ -116,7 +116,8 @@ debugNameCollection textures paths = do   device <- asks getDevice   for_ names \((ix, path), Texture{tAllocatedImage}) -> do-    withFrozenCallStack . logDebug $ displayShow (ix, path)+    withFrozenCallStack $+      logDebug $ displayShow (ix, path)     Debug.nameObject device (Image.aiImage tAllocatedImage) $       fromString $ show @Natural ix <> ":" <> takeBaseName path   where