packages feed

keid-core (empty) → 0.1.0.0

raw patch · 53 files changed

+6891/−0 lines, 53 filesdep +GLFW-bdep +StateVardep +VulkanMemoryAllocatorsetup-changed

Dependencies added: GLFW-b, StateVar, VulkanMemoryAllocator, adjunctions, base, binary, bytestring, cryptohash-md5, derive-storable, derive-storable-plugin, distributive, foldl, geomancy, ktx-codec, neat-interpolation, optparse-applicative, optparse-simple, resourcet, rio, rio-app, tagged, template-haskell, text, transformers, unagi-chan, unliftio, vector, vulkan, vulkan-utils, zstd

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for keid-core++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# Keid Engine Core
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keid-core.cabal view
@@ -0,0 +1,168 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           keid-core+version:        0.1.0.0+synopsis:       Core parts of Keid engine.+category:       Game Engine+author:         IC Rainbow+maintainer:     keid@aenor.ru+copyright:      2021 IC Rainbow+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/keid/engine++library+  exposed-modules:+      Engine.App+      Engine.Camera+      Engine.DataRecycler+      Engine.Events+      Engine.Events.CursorPos+      Engine.Events.MouseButton+      Engine.Events.Sink+      Engine.Frame+      Engine.Render+      Engine.Run+      Engine.Setup+      Engine.Setup.Device+      Engine.Setup.Window+      Engine.Stage.Bootstrap.Setup+      Engine.Stage.Bootstrap.Types+      Engine.StageSwitch+      Engine.Types+      Engine.Types.Options+      Engine.Types.RefCounted+      Engine.UI.Layout+      Engine.Vulkan.DescSets+      Engine.Vulkan.Pipeline+      Engine.Vulkan.Swapchain+      Engine.Vulkan.Types+      Engine.Window.CursorPos+      Engine.Window.Drop+      Engine.Window.Key+      Engine.Window.MouseButton+      Engine.Window.Scroll+      Engine.Worker+      Render.Code+      Render.Code.Noise+      Render.Draw+      Render.Samplers+      Resource.Buffer+      Resource.Collection+      Resource.Combined.Textures+      Resource.CommandBuffer+      Resource.Compressed.Zstd+      Resource.DescriptorSet+      Resource.Image+      Resource.Mesh.Codec+      Resource.Mesh.Types+      Resource.Mesh.Utils+      Resource.Model+      Resource.Static+      Resource.Texture+      Resource.Texture.Ktx1+  other-modules:+      Paths_keid_core+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstrainedClassMethods+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      EmptyCase+      EmptyDataDeriving+      ExistentialQuantification+      ExplicitForAll+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      HexFloatLiterals+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      NamedFieldPuns+      NamedWildCards+      NumDecimals+      NumericUnderscores+      OverloadedStrings+      PatternSynonyms+      PostfixOperators+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+  build-depends:+      GLFW-b+    , StateVar+    , VulkanMemoryAllocator+    , adjunctions+    , base >=4.7 && <5+    , binary+    , bytestring+    , cryptohash-md5+    , derive-storable+    , derive-storable-plugin+    , distributive+    , foldl+    , geomancy+    , ktx-codec+    , neat-interpolation+    , optparse-applicative+    , optparse-simple+    , resourcet+    , rio >=0.1.12.0+    , rio-app+    , tagged+    , template-haskell+    , text+    , transformers+    , unagi-chan+    , unliftio+    , vector+    , vulkan+    , vulkan-utils+    , zstd+  default-language: Haskell2010
+ src/Engine/App.hs view
@@ -0,0 +1,23 @@+module Engine.App+  ( engineMain+  , engineMainWith+  ) where++import RIO++import RIO.App (appMain)+import Engine.Run (runStack)+import Engine.Setup (setup)+import Engine.Types qualified as Engine+import Engine.Types.Options (Options(..), getOptions)+import Engine.Stage.Bootstrap.Setup qualified as Bootstrap++engineMain :: Engine.StackStage -> IO ()+engineMain initialStage = engineMainWith (\() -> initialStage) (pure ())++engineMainWith :: (a -> Engine.StackStage) -> Engine.StageSetupRIO a -> IO ()+engineMainWith handoff action =+  appMain getOptions optionsVerbose setup $ runStack+    [ -- XXX: run swapchain bootstrap and replace with next stage+      Bootstrap.stackStage handoff action+    ]
+ src/Engine/Camera.hs view
@@ -0,0 +1,94 @@+module Engine.Camera where++import RIO++import Geomancy (Transform(..), Vec3, vec3)+import Geomancy.Transform qualified as Transform+import Geomancy.Quaternion qualified as Quaternion+import Geomancy.Vec3 qualified as Vec3+import Geomancy.Vulkan.Projection qualified as Projection+import Geomancy.Vulkan.View qualified as View+import Vulkan.Core10 qualified as Vk++import Engine.Worker qualified as Worker++-- * Projection++data Projection = Projection+  { projectionPerspective :: Transform+  , projectionOrthoUI     :: Transform+  }+  deriving (Show)++instance Semigroup Projection where+  _a <> b = Projection+    { projectionPerspective = projectionPerspective b+    , projectionOrthoUI     = projectionOrthoUI     b+    }++instance Monoid Projection where+  mempty = Projection mempty mempty++type ProjectionProcess = Worker.Cell ProjectionInput Projection++data ProjectionInput = ProjectionInput+  { projectionFovRads :: Float+  , projectionScreen  :: Vk.Extent2D+  }+  deriving (Show)++mkProjection :: ProjectionInput -> Projection+mkProjection ProjectionInput{..} = Projection{..}+  where+    -- BUG: infinitePerspective gives huge clipping and effective FoV is different+    -- projectionPerspective = Projection.infinitePerspective projectionFovRads width height+    projectionPerspective = Projection.perspective projectionFovRads (1/2048) 16384 width height++    projectionOrthoUI = Projection.orthoOffCenter 0 1 width height++    Vk.Extent2D{width, height} = projectionScreen++-- * View++data View = View+  { viewTransform    :: Transform+  , viewTransformInv :: Transform+  , viewPosition     :: Vec3+  , viewDirection    :: Vec3+  }+  deriving (Show)++type ViewProcess = Worker.Cell ViewOrbitalInput View++-- | Camera orbiting its target+data ViewOrbitalInput = ViewOrbitalInput+  { orbitAzimuth  :: Float+  , orbitAscent   :: Float+  , orbitDistance :: Float+  , orbitScale    :: Float+  , orbitTarget   :: Vec3+  }+  deriving (Show)++mkViewOrbital :: Vec3 -> ViewOrbitalInput -> View+mkViewOrbital cameraTarget ViewOrbitalInput{..} = View{..}+  where+    viewTransform = View.lookAt viewPosition cameraTarget axisUp+    viewTransformInv = Transform.inverse viewTransform++    viewPosition =+      orbitTarget ++      Quaternion.rotate+        ( Quaternion.axisAngle axisUp orbitAzimuth *+          Quaternion.axisAngle axisRight orbitAscent+        )+        (vec3 0 0 $ orbitDistance * orbitScale)++    viewDirection = Vec3.normalize $ cameraTarget - viewPosition++    axisUp    = vec3 0 (-1) 0+    axisRight = vec3 1 0 0++{-# INLINE mkViewOrbital_ #-}+mkViewOrbital_ :: ViewOrbitalInput -> View+mkViewOrbital_ voi = mkViewOrbital (orbitTarget voi) voi
+ src/Engine/DataRecycler.hs view
@@ -0,0 +1,34 @@+module Engine.DataRecycler where++import RIO++import Control.Concurrent.Chan.Unagi qualified as Unagi++data DataRecycler a = DataRecycler+  { drDump :: DumpResource a+    {- ^+      Filled with resources which aren't destroyed after finishing a frame,+      but instead are used by another frame which executes after that one is+      retired, (taken from ghRecycleOut)++      Make sure not to pass any resources which were created with a frame-only+      scope however!+    -}+  , drWait :: WaitResource a+    -- ^ The resources of prior frames waiting to be taken+  }++type DumpResource a = a -> IO ()++type WaitResource a = IO (Either (IO a) a)++new :: MonadIO m => m (DataRecycler a)+new = do+  (recycleWrite, recycleRead) <- liftIO Unagi.newChan+  pure DataRecycler+    { drDump = Unagi.writeChan recycleWrite+    , drWait = do+        (tryOp, blockOp) <- Unagi.tryReadChan recycleRead+        res <- Unagi.tryRead tryOp+        pure $ maybe (Left blockOp) Right res+    }
+ src/Engine/Events.hs view
@@ -0,0 +1,32 @@+module Engine.Events+  ( Sink(..)+  , spawn+  , registerMany+  ) where++import RIO++import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Events.Sink (Sink)+import Engine.Events.Sink qualified as Sink+import Engine.Types (StageRIO)++spawn+  :: (event -> StageRIO st ())+  -> [Sink event st -> StageRIO st ReleaseKey]+  -> StageRIO st (ReleaseKey, Sink event st)+spawn handleEvent sources = do+  (sinkKey, sink) <- Sink.spawn handleEvent++  key <- registerMany $+    pure sinkKey :+    map ($ sink) sources++  pure (key, sink)++registerMany :: [StageRIO st ReleaseKey] -> StageRIO st ReleaseKey+registerMany actions =+  sequenceA actions >>=+    Resource.register . traverse_ Resource.release
+ src/Engine/Events/CursorPos.hs view
@@ -0,0 +1,35 @@+module Engine.Events.CursorPos where++import RIO++import Geomancy (Vec2, vec2)+import GHC.Float (double2Float)+import UnliftIO.Resource (ReleaseKey)++import Engine.Types (StageRIO)+import Engine.Window.CursorPos qualified as CursorPos+import Engine.Worker qualified as Worker++import Engine.Events (Sink)++callback+  :: ( Worker.HasInput cursor+     , Worker.GetInput cursor ~ Vec2+     )+  => cursor+  -------------------------+  -> Sink e rs+  -> StageRIO rs ReleaseKey+callback cursorVar = CursorPos.callback . handler cursorVar++handler+  :: ( Worker.HasInput cursor+     , Worker.GetInput cursor ~ Vec2+     )+  => cursor+  -> Sink e rs+  -> CursorPos.Callback rs+handler cursorVar _sink windowX windowY = do+  -- logDebug $ "CursorPos event: " <> displayShow (windowX, windowY)+  Worker.pushInput cursorVar \_old ->+    vec2 (double2Float windowX) (double2Float windowY)
+ src/Engine/Events/MouseButton.hs view
@@ -0,0 +1,47 @@+module Engine.Events.MouseButton+  ( ClickHandler+  , callback+  , handler+  ) where++import RIO++import Geomancy (Vec2)+import UnliftIO.Resource (ReleaseKey)++import Engine.Events.Sink (Sink)+import Engine.Types (StageRIO)+import Engine.Window.MouseButton (ModifierKeys, MouseButton, MouseButtonState)+import Engine.Window.MouseButton qualified as MouseButton+import Engine.Worker qualified as Worker++type ClickHandler e st =+  Sink e st ->+  Vec2 ->+  (ModifierKeys, MouseButtonState, MouseButton) ->+  StageRIO st ()++callback+  :: ( Worker.HasOutput cursor+     , Worker.GetOutput cursor ~ Vec2+     )+  => cursor+  -> ClickHandler e st+  -------------------------+  -> Sink e st+  -> StageRIO st ReleaseKey+callback cursorP eventHandler = MouseButton.callback . handler cursorP eventHandler++handler+  :: ( Worker.HasOutput cursor+     , Worker.GetOutput cursor ~ Vec2+     )+  => cursor+  -> ClickHandler e st+  -> Sink e st+  -> (ModifierKeys, MouseButtonState, MouseButton)+  -> StageRIO st ()+handler cursorP eventHandler sink buttonEvent = do+  cursorPos <- Worker.getOutputData cursorP+  logDebug $ "MouseButton event: " <> displayShow (cursorPos, buttonEvent)+  eventHandler sink cursorPos buttonEvent
+ src/Engine/Events/Sink.hs view
@@ -0,0 +1,42 @@+module Engine.Events.Sink+  ( Sink(..)+  , spawn+  ) where++import RIO++import Control.Concurrent.Chan.Unagi qualified as Unagi+import Control.Exception (AsyncException(ThreadKilled))+import UnliftIO.Concurrent (forkFinally, killThread)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (StageRIO)++newtype Sink event st = Sink+  { signal :: event -> StageRIO st ()+  }++spawn+  :: (event -> StageRIO rs ())+  -> StageRIO rs (ReleaseKey, Sink event rs)+spawn handleEvent = do+  (eventsIn, eventsOut) <- liftIO Unagi.newChan+  let sink = Sink \event -> liftIO (Unagi.writeChan eventsIn event)++  let+    handler = forever $+      liftIO (Unagi.readChan eventsOut) >>= handleEvent++  tid <- forkFinally handler+    \case+      Left exc ->+        case fromException exc of+          Just ThreadKilled ->+            logDebug "Event thread killed"+          _others ->+            logError $ "Event thread crashed: " <> displayShow exc+      Right () ->+        logWarn "Event thread exited prematurely"+  key <- Resource.register $ killThread tid+  pure (key, sink)
+ src/Engine/Frame.hs view
@@ -0,0 +1,352 @@+module Engine.Frame+  ( Frame(..)+  , initial+  , run+  , advance+  , queueSubmit++  , RecycledResources(..)+  , initialRecycledResources+  , timeoutError+  ) where++import RIO++import Control.Monad.Trans.Resource (ResourceT, MonadResource, allocate, release)+import Control.Monad.Trans.Resource qualified as ResourceT+import GHC.IO.Exception (IOErrorType(TimeExpired), IOException(IOError))+import RIO.App (appEnv)+import RIO.Vector qualified as Vector+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12+import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))+import Vulkan.NamedType ((:::))+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import Vulkan.Zero (zero)++import Engine.DataRecycler (DumpResource, WaitResource)+import Engine.Setup.Window qualified as Window+import Engine.Types (GlobalHandles(..), StageRIO, Stage(..), Frame(..), GPUWork, RecycledResources(..))+import Engine.Types.RefCounted (newRefCounted)+import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources)+import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues)++initial+  :: (RenderPass rp)+  => Maybe SwapchainResources+  -> DumpResource (RecycledResources rr)+  -> Stage rp p rr st+  -> StageRIO st (Frame rp p rr)+initial oldSR dumpResource Stage{..} = do+  logDebug "Making initial frame"++  GlobalHandles{..} <- asks appEnv+  let device = ghDevice++  sfSwapchainResources <- case oldSR of+    Nothing -> do+      windowSize <- liftIO $ Window.getExtent2D ghWindow+      let oldSwapchain = Vk.NULL_HANDLE+      allocSwapchainResources+        oldSwapchain+        windowSize+        ghSurface+        ghScreenP+    Just old ->+      pure old++  {- XXX:+    Create this resource object at the global level so it's closed correctly on exception.+  -}+  (stageKey, stageResources) <- allocate ResourceT.createInternalState ResourceT.closeInternalState+  stageRefCounted <- newRefCounted $ release stageKey+  semiFrame <- flip ResourceT.runInternalState stageResources do+    {- XXX:+      Stages appearing on the top of the stage stack are to create their swapchain-derived resources.+      Don't keep the release keys, all resources here are refcounted and live for the lifetime of the stage.+      Resources will be released when the stage is finished or suspended and all the frames are done.+    -}++    debugAlloc <- toIO . logDebug $ "Allocating inside stage " <> display sTitle+    debugRelease <- toIO . logDebug $ "Releasing inside stage " <> display sTitle+    void $! ResourceT.allocate_ debugAlloc debugRelease++    -- For each render pass:+    sfRenderpass <- allocateRenderpass_ sfSwapchainResources++    -- TODO: Recreate this if the swapchain format changes+    sfPipelines <- sAllocateP sfSwapchainResources sfRenderpass++    (_, sfRenderFinishedHostSemaphore) <- Vk.withSemaphore+      device+      (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_TIMELINE 0 :& ())+      Nothing+      allocate++    logDebug $ "Creating initial recycled resources for stage " <> display sTitle+    sfRecycledResources <- initialRecycledResources sInitialRR sfRenderpass sfPipelines+    replicateM_ (INFLIGHT_FRAMES - 1) do+      resources <- initialRecycledResources sInitialRR sfRenderpass sfPipelines+      liftIO $ dumpResource resources++    releaseDataDebug <- toIO . logDebug $ "Releasing recycled resources for stage " <> display sTitle+    void $! Resource.register releaseDataDebug++    pure+      ( sfSwapchainResources+      , sfRenderpass+      , sfPipelines+      , sfRenderFinishedHostSemaphore+      , sfRecycledResources+      )++  let+    (fSwapchainResources, fRenderpass, fPipelines, fRenderFinishedHostSemaphore, fRecycledResources) = semiFrame++  {- XXX:+    Create this resource object at the global level so it's closed correctly on exception.+    Recycled frame resources can linger for a bit longer after its stage is gone, thus 'RefCounted'.+  -}+  fResources <- allocate ResourceT.createInternalState ResourceT.closeInternalState++  fGPUWork <- liftIO $ newIORef mempty++  pure Frame+    { fIndex          = 1+    , fWindow         = ghWindow+    , fSurface        = ghSurface+    , fStageResources = (stageRefCounted, stageResources)+    , ..+    }++pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a+pattern INFLIGHT_FRAMES = 2 -- XXX: up to two frames submitted for rendering++-- | Derive next frame+advance+  :: ( HasLogFunc env+     , HasVulkan env+     , MonadResource (RIO env)+     , RenderPass rp+     )+  => WaitResource (RecycledResources rr)+  -> Frame rp p rr+  -> Bool+  -> RIO env (Frame rp p rr)+advance waitDumped f needsNewSwapchain = do+  -- Wait for a prior frame to finish, then we can steal it's resources!++  -- Handle mvar indefinite timeout exception here:+  -- https://github.com/expipiplus1/vulkan/issues/236+  fRecycledResources <- liftIO $+    waitDumped >>= \case+      Left block ->+        block+      Right rs ->+        pure rs++  (fSwapchainResources, fRenderpass) <- getNext f++  -- The per-frame resource helpers need to be created fresh+  fGPUWork   <- liftIO $ newIORef mempty+  fResources <- allocate ResourceT.createInternalState ResourceT.closeInternalState++  pure Frame+    { fIndex                       = fIndex f + 1+    , fWindow                      = fWindow f+    , fSurface                     = fSurface f+    , fPipelines                   = fPipelines f+    , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f+    , fStageResources              = fStageResources f+    , fSwapchainResources+    , fRenderpass+    , fGPUWork+    , fResources+    , fRecycledResources+    }+  where+    getNext Frame{..} = do+      if needsNewSwapchain then do+        windowSize <- liftIO $ Window.getExtent2D fWindow+        newResources <- recreateSwapchainResources windowSize fSwapchainResources++        let+          formatMatch =+            siSurfaceFormat (srInfo newResources) ==+            siSurfaceFormat (srInfo fSwapchainResources)+        unless formatMatch do+          logWarn "Swapchain changed format"+          throwString "TODO: Handle swapchain changing formats"++        newRenderpass <- updateRenderpass newResources fRenderpass++        pure+          ( newResources+          , newRenderpass+          )+      else+        pure+          ( fSwapchainResources+          , fRenderpass+          )++run+  :: ( HasLogFunc env+     , HasVulkan env+     , MonadResource (RIO env)+     )+  => (RecycledResources rr -> IO ())+  -> RIO (env, Frame rp p rr) a+  -> Frame rp p rr+  -> RIO env a+run recycle 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+      -- logDebug $ "Waiting Frame " <> displayShow fIndex++      unless (null waits) do+        let+          waitInfo = zero+            { Vk12.semaphores = Vector.fromList (map fst waits)+            , Vk12.values     = Vector.fromList (map snd waits)+            }+        waitTwice waitInfo oneSecondKhr >>= \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"+            {-+              XXX: recycler thread will crash now, never recycling its resources,+              resulting in an indefinite MVar block.+            -}+          Vk.SUCCESS ->+            pure ()+          huh ->+            logWarn $ "waitTwice returned " <> displayShow huh++      -- logDebug $ "Flushing Frame " <> displayShow fIndex++      -- Free resources wanted elsewhere now, all those in RecycledResources+      for_ (rrQueues fRecycledResources) \commandPool ->+        Vk.resetCommandPool device commandPool Vk.COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT++      -- Signal we're done by making the recycled resources available+      liftIO $ recycle fRecycledResources++      -- Destroy frame-specific resources at our leisure+      release (fst fResources)++-- | 'queueSubmit' and add wait for the timeline 'Semaphore' before retiring the frame.+queueSubmit+  :: MonadVulkan env m+  => Vk.Queue+  -> Vector (SomeStruct Vk.SubmitInfo)+  -> IORef [GPUWork]+  -> Vk.Semaphore+  -> Word64+  -> m ()+queueSubmit q submits gpuWork hostSemaphore frameIndex = do+  {-+    Make sure we don't get interrupted between submitting the work and+    recording the wait.+  -}+  mask \_ -> do+    Vk.queueSubmit q submits Vk.NULL_HANDLE+    atomicModifyIORef' gpuWork \waits ->+      ( (hostSemaphore, frameIndex) : waits+      , ()+      )++initialRecycledResources+  :: ( Resource.MonadResource (RIO env)+     , HasVulkan env+     , HasLogFunc env+     )+  => (Queues Vk.CommandPool -> rp -> p -> ResourceT (RIO env) rr)+  -> rp+  -> p+  -> ResourceT (RIO env) (RecycledResources rr)+initialRecycledResources initialRecycledData rps pipes = do+  device <- asks getDevice++  (_iaKey, rrImageAvailableSemaphore) <- Vk.withSemaphore+    device+    (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_BINARY 0 :& ())+    Nothing+    allocate++  (_rfKey, rrRenderFinishedSemaphore) <- Vk.withSemaphore+    device+    (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_BINARY 0 :& ())+    Nothing+    allocate++  queues <- asks getQueues+  rrQueues <- for queues \(QueueFamilyIndex ix, _queue) -> do+    let+      commandPoolCI = Vk.CommandPoolCreateInfo+        { flags            = zero+        , queueFamilyIndex = ix+        }+    cpDebug <- toIO . logDebug $ "Release time for command pool for queue " <> display ix+    void $! ResourceT.register cpDebug+    fmap snd $! Vk.withCommandPool device commandPoolCI Nothing ResourceT.allocate++  rrData <- initialRecycledData rrQueues rps pipes++  pure RecycledResources{..}++{- |+  Wait for some semaphores, if the wait times out give the frame one last+  chance to complete with a zero timeout.++  It could be that the program was suspended during the preceding+  wait causing it to timeout, this will check if it actually+  finished.+-}+waitTwice+  :: (MonadVulkan env m, HasLogFunc env)+  => Vk12.SemaphoreWaitInfo+  -> "timeout" ::: Word64+  -> m Vk.Result+waitTwice waitInfo t = do+  device <- asks getDevice+  Vk12.waitSemaphoresSafe device waitInfo t >>= \case+    Vk.TIMEOUT -> do+      r <- Vk12.waitSemaphores device waitInfo 0+      logWarn $ mconcat+        [ "waiting a second time on " <> displayShow waitInfo+        , " got " <> displayShow r+        ]+      pure r+    r ->+      pure r++timeoutError :: MonadThrow m => String -> m a+timeoutError message =+  throwM $ IOError Nothing TimeExpired "" message Nothing Nothing++spawn :: (MonadUnliftIO m, MonadResource m) => m a -> m (Async a)+spawn action = do+  actionIO <- toIO action+  {-+    If we don't remove the release key when the thread is done it'll leak,+    remove it at the end of the async action when the thread is going to+    die anyway.++    Mask this so there's no chance we're inturrupted before writing the mvar.+  -}+  kv  <- newEmptyMVar+  mask $ \_ -> do+    (k, r) <- allocate+      (asyncWithUnmask \unmask ->+        unmask $ actionIO <* (Resource.unprotect =<< liftIO (readMVar kv))+      )+      uninterruptibleCancel+    putMVar kv k+    pure r
+ src/Engine/Render.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedLists #-}++module Engine.Render where++import RIO+import Vulkan.Exception (VulkanException(..))++import Control.Monad.Trans.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12+import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))+import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr+import Vulkan.NamedType ((:::))+import Vulkan.Zero (zero)++import Engine.Frame qualified as Frame+import Engine.Types (Frame(..), RecycledResources(..), StageFrameRIO)+import Engine.Types.RefCounted (resourceTRefCount)+import Engine.Vulkan.Swapchain (SwapchainInfo(..), SwapchainResources(..))+import Engine.Vulkan.Types (HasVulkan(..), RenderPass(..), Queues(..))++renderFrame+  :: RenderPass rp+  => (rr -> StageFrameRIO rp p rr st ())+  -> (Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ())+  -> StageFrameRIO rp p rr st ()+renderFrame updateBuffers recordCommandBuffer = do+  Frame{..} <- asks snd+  let stageRecycled = rrData fRecycledResources+  device <- asks getDevice++  let oneSecondKhr = 1e9+  let+    RecycledResources{..}  = fRecycledResources+    SwapchainResources{..} = fSwapchainResources+    SwapchainInfo{..}      = srInfo++  resourceTRefCount srRelease+  resourceTRefCount (fst fStageResources)+  refcountRenderpass fRenderpass++  updateBuffers stageRecycled++  (res, imageIndex) <- Khr.acquireNextImageKHRSafe+    device+    siSwapchain+    oneSecondKhr+    rrImageAvailableSemaphore+    Vk.NULL_HANDLE++  let+    proceed = do+      -- Allocate a command buffer and populate it+      let+        commandBufferAI = zero+          { Vk.commandPool        = qGraphics rrQueues+          , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY+          , Vk.commandBufferCount = 1+          }+      commandBuffer <- Vk.withCommandBuffers device commandBufferAI Resource.allocate >>= \case+        (_key, [one]) ->+          pure one+        _ ->+          throwString "assert: 1 buffer allocated as requested"++      let+        commandBufferBI = zero+          { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT+          } :: Vk.CommandBufferBeginInfo '[]+      Vk.useCommandBuffer commandBuffer commandBufferBI $+        recordCommandBuffer commandBuffer stageRecycled imageIndex++      let+        submitInfo =+          zero+            { Vk.waitSemaphores =+                [ rrImageAvailableSemaphore+                ]+            , Vk.waitDstStageMask =+                [ Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT+                ]+            , Vk.commandBuffers =+                [ Vk.commandBufferHandle commandBuffer+                ]+            , Vk.signalSemaphores =+                [ rrRenderFinishedSemaphore+                , fRenderFinishedHostSemaphore+                ]+            }+          ::& zero+            { Vk12.waitSemaphoreValues   = [1]+            , Vk12.signalSemaphoreValues = [1, fIndex]+            }+          :& ()++      -- traceM $ "Submitting frame " <> textDisplay fIndex <> " to image " <> textDisplay imageIndex+      Queues{qGraphics=(_family, graphicsPresentQueue)} <- asks getQueues+      Frame.queueSubmit+        graphicsPresentQueue+        [SomeStruct submitInfo]+        fGPUWork+        fRenderFinishedHostSemaphore+        fIndex++      -- traceM $ "Presenting image " <> textDisplay imageIndex <> " from frame " <> textDisplay fIndex+      presentRes <- Khr.queuePresentKHR graphicsPresentQueue zero+        { Khr.waitSemaphores = [rrRenderFinishedSemaphore]+        , Khr.swapchains     = [siSwapchain]+        , Khr.imageIndices   = [imageIndex]+        }+      case presentRes of+        Vk.SUCCESS ->+          pure ()+        Vk.SUBOPTIMAL_KHR -> do+          logWarn "[present] Swapchain is suboptimal, forcing update."+          throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR+        _ ->+          -- TODO: check for SUBOPTIMAL_KHR+          logWarn $ "Presenting wasn't quite successful: " <> displayShow presentRes++  case res of+    Vk.SUCCESS ->+      -- logDebug $ "Acquired next image ID: " <> displayShow imageIndex+      proceed++    Vk.TIMEOUT ->+      logDebug "Timed out (1s) trying to acquire next image"++    Vk.ERROR_OUT_OF_DATE_KHR -> do+      {- XXX:+        Throwing an exception for 'Engine.Vulkan.Swapchain.threwSwapchainError' to catch.+        See also: 'Engine.Run.step'.+      -}+      logWarn "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."+      throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR++    _ -> do+      logError $+        "Unexpected Result from acquireNextImageKHR: " <>+        fromString (show res)+      throwM $ VulkanException res
+ src/Engine/Run.hs view
@@ -0,0 +1,178 @@+module Engine.Run+  ( runStack+  , run+  , step+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (App(..), appEnv)+import RIO.State (get, put)+import UnliftIO.Resource (ReleaseKey, release)+import Vulkan.Core10 qualified as Vk++import Engine.DataRecycler (DataRecycler(..))+import Engine.DataRecycler qualified as DataRecycler+import Engine.Frame qualified as Frame+import Engine.Render (renderFrame)+import Engine.StageSwitch (getNextStage)+import Engine.Types (Frame, NextStage(..), RecycledResources, StageStack, StackStage(..), Stage(..), StageRIO)+import Engine.Types.RefCounted (releaseRefCounted)+import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError)+import Engine.Vulkan.Types (RenderPass, getDevice)++runStack :: StageStack -> StageRIO (Maybe SwapchainResources) ()+runStack = \case+  [] -> do+    logInfo "Stage stack finished"+    get >>= \case+      Nothing ->+        pure ()+      Just oldSR ->+        releaseRefCounted (srRelease oldSR)+    asks getDevice >>= Vk.deviceWaitIdle+    threadDelay 0.5e6 -- XXX: this is arbitrary and may not always satisfy the validator++  StackStage stage : rest -> do+    logInfo $ "Setting up stage " <> display (sTitle stage)+    (stageRelease, runner) <- prepareStage (sInitialRS stage)+    oldSR <- get+    runner (run oldSR stageRelease stage) >>= proceed stageRelease rest++  StackStageContinue stKey state stage : rest -> do+    logInfo $ "Resuming stage " <> display (sTitle stage)+    (stageRelease, runner) <- prepareStage (pure (stKey, state))+    oldSR <- get+    runner (run oldSR stageRelease stage) >>= proceed stageRelease rest++type StageResult = (SwapchainResources, StageAction)++proceed :: ReleaseKey -> StageStack -> StageResult -> StageRIO (Maybe SwapchainResources) ()+proceed stageRelease rest (oldSR, stageAction) = do+  put (Just oldSR)+  case stageAction of+    StageDone -> do+      logInfo "Stage done"+      release stageRelease+      runStack rest+    StageReplace nextStage -> do+      logInfo "Stage replaced"+      release stageRelease+      runStack (nextStage : rest)+    StagePush frozenStage nextStage -> do+      case frozenStage of+        StackStage{} ->+          logInfo "Restarting stage pushed"+        StackStageContinue{} ->+          logInfo "Frozen stage pushed"+      runStack (nextStage : frozenStage : rest)++prepareStage+  :: StageRIO env (ReleaseKey, st)+  -> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)+prepareStage initialRS = do+  (key, rs) <- initialRS+  freshStateVar <- newSomeRef rs+  App{..} <- ask+  let+    stageApp = App+      { appState = freshStateVar+      , ..+      }+  pure (key, runRIO stageApp)++run+  :: RenderPass rp+  => Maybe SwapchainResources+  -> ReleaseKey+  -> Stage rp p rr st+  -> StageRIO st StageResult+run oldSR stKey stage@Stage{..} = do+  logInfo $ "Starting stage: " <> display sTitle++  recycler <- DataRecycler.new++  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++  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+  => ReleaseKey+  -> Stage rp p rr st+  -> DataRecycler (RecycledResources rr)+  -> Frame rp p rr+  -> StageRIO st (LoopAction (Frame rp p rr))+step stKey stage@Stage{..} DataRecycler{..} frame = do+  liftIO GLFW.pollEvents++  -- XXX: hard unwind all the stages, rendering nothing+  quit <- liftIO $ GLFW.windowShouldClose (Frame.fWindow frame)++  if quit then+    pure LoopQuit+  else+    getNextStage >>= \case+      Nothing -> do+        needsNewSwapchain <- threwSwapchainError do+          rs <- get+          Frame.run drDump (renderFrame (sUpdateBuffers rs) sRecordCommands) frame+        nextFrame <- Frame.advance drWait frame needsNewSwapchain++        pure $ LoopNextFrame nextFrame+      Just Finish ->+        -- XXX: finish the stage and proceed with the remaining stack+        pure LoopQuit+      Just (Replace nextStage) ->+        pure $ LoopReplaceStage frame nextStage+      Just (PushRestart nextStage) ->+        pure $ LoopPushStage frame (StackStage stage) nextStage+      Just (PushFreeze nextStage) -> do+        frozen <- freeze stKey stage+        pure $ LoopPushStage frame frozen nextStage++freeze :: RenderPass rp => ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage+freeze stKey stage = do+  st <- get+  pure $ StackStageContinue stKey st stage++data StageAction+  = StageReplace StackStage+  | StagePush StackStage StackStage+  | StageDone++data LoopAction f+  = LoopNextFrame f+  | LoopReplaceStage f StackStage+  | LoopPushStage f StackStage StackStage+  | LoopQuit++{-# INLINE stageLoop #-}+stageLoop :: (f -> StageRIO st (LoopAction f)) -> f -> StageRIO st (f, StageAction)+stageLoop action current =+  action current >>= \case+    LoopNextFrame nextFrame ->+      stageLoop action nextFrame+    LoopQuit ->+      pure (current, StageDone)+    LoopReplaceStage lastFrame nextStage ->+      pure (lastFrame, StageReplace nextStage)+    LoopPushStage lastFrame frozenStage nextStage ->+      pure (lastFrame, StagePush frozenStage nextStage)
+ src/Engine/Setup.hs view
@@ -0,0 +1,95 @@+module Engine.Setup where++import RIO++import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Extensions.VK_EXT_debug_utils qualified as Ext+import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 qualified as Khr+import Vulkan.Requirement (InstanceRequirement(..))+import Vulkan.Utils.Initialization (createInstanceFromRequirements)+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import Vulkan.Zero (zero)+import VulkanMemoryAllocator qualified as VMA++import Engine.Camera qualified as Camera+import Engine.Setup.Device (allocatePhysical, allocateLogical)+import Engine.Setup.Window qualified as Window+import Engine.Types (GlobalHandles(..))+import Engine.Types.Options (Options, optionsFullscreen)+import Engine.Vulkan.Swapchain (SwapchainResources)+import Engine.Vulkan.Types (PhysicalDeviceInfo(..))+import Engine.Worker qualified as Worker+import Engine.StageSwitch (newStageSwitchVar)++setup+  :: ( HasLogFunc env+     , MonadResource (RIO env)+     )+  => Options -> RIO env (GlobalHandles, Maybe SwapchainResources)+setup opts = do+  logDebug $ displayShow opts++  (windowReqs, ghWindow) <- Window.allocate+    (optionsFullscreen opts)+    Window.pickLargest+    "Keid Engine"++  logDebug "Creating instance"+  ghInstance <- createInstanceFromRequirements+    (deviceProps : debugUtils : windowReqs)+    mempty+    zero++  logDebug "Creating surface"+  (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance++  logDebug "Creating physical device"+  (ghPhysicalDeviceInfo, ghPhysicalDevice) <- allocatePhysical+    ghInstance+    ghSurface+    pdiTotalMemory++  logDebug "Creating logical device"+  ghDevice <- allocateLogical ghPhysicalDeviceInfo ghPhysicalDevice++  logDebug "Creating VMA"+  let+    allocatorCI :: VMA.AllocatorCreateInfo+    allocatorCI = zero+      { VMA.physicalDevice = Vk.physicalDeviceHandle ghPhysicalDevice+      , VMA.device         = Vk.deviceHandle ghDevice+      , VMA.instance'      = Vk.instanceHandle ghInstance+      }+  (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate+  toIO (logDebug "Releasing VMA") >>= Resource.register++  ghQueues <- liftIO $ pdiGetQueues ghPhysicalDeviceInfo ghDevice+  logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues)++  screen <- liftIO $ Window.getExtent2D ghWindow+  (_screenKey, ghScreenP) <- Worker.registered $+    Worker.spawnCell Camera.mkProjection Camera.ProjectionInput+      { projectionFovRads = τ / 4+      , projectionScreen  = screen+      }++  ghStageSwitch <- newStageSwitchVar++  pure (GlobalHandles{..}, Nothing)++deviceProps :: InstanceRequirement+deviceProps = RequireInstanceExtension+  Nothing+  Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME+  minBound++debugUtils :: InstanceRequirement+debugUtils = RequireInstanceExtension+  Nothing+  Ext.EXT_DEBUG_UTILS_EXTENSION_NAME+  minBound++τ :: Float+τ = 2 * pi
+ src/Engine/Setup/Device.hs view
@@ -0,0 +1,202 @@+-- | Physical device tools++module Engine.Setup.Device where++import RIO++import Control.Monad.Trans.Maybe (MaybeT(..))+import GHC.IO.Exception (IOException(..), IOErrorType(NoSuchThing))+import RIO.Vector qualified as V+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Core11.Promoted_From_VK_KHR_multiview (PhysicalDeviceMultiviewFeatures(..))+import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing (PhysicalDeviceDescriptorIndexingFeatures(..))+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (PhysicalDeviceTimelineSemaphoreFeatures(..))+import Vulkan.CStruct.Extends ( SomeStruct(SomeStruct), pattern (:&), pattern (::&))+import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 (getPhysicalDeviceFeatures2KHR)+import Vulkan.Extensions.VK_KHR_surface qualified as Khr+import Vulkan.Extensions.VK_KHR_swapchain (pattern KHR_SWAPCHAIN_EXTENSION_NAME)+import Vulkan.Extensions.VK_KHR_timeline_semaphore (pattern KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME)+import Vulkan.Utils.Initialization (createDeviceFromRequirements, physicalDeviceName, pickPhysicalDevice)+import Vulkan.Utils.QueueAssignment (QueueSpec(..))+import Vulkan.Utils.QueueAssignment qualified as Utils+import Vulkan.Utils.Requirements.TH qualified as Utils+import Vulkan.Core10 (PhysicalDeviceFeatures(..))+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (PhysicalDeviceInfo(..), Queues(..))++allocatePhysical+  :: ( MonadUnliftIO m, MonadThrow m+     , MonadReader env m+     , HasLogFunc env+     , MonadResource m+     )+  => Vk.Instance+  -> Khr.SurfaceKHR+  -> (PhysicalDeviceInfo -> Word64)+  -> m (PhysicalDeviceInfo, Vk.PhysicalDevice)+allocatePhysical vkInstance surface score = do+  UnliftIO unliftIO <- askUnliftIO++  let+    create = unliftIO do+      logDebug "Picking physical device..."+      pickPhysicalDevice vkInstance (physicalDeviceInfo surface) score >>= \case+        Nothing ->+          noSuchThing "Unable to find appropriate PhysicalDevice"+        Just res@(pdi, _dev) -> do+          logInfo $ mconcat+            [ "Using physical device: "+            , displayShow (pdiName pdi)+            ]+          pure res++    destroy _res = unliftIO $+      logDebug "Destroying physical device"++  fmap snd $ Resource.allocate create destroy++physicalDeviceInfo+  :: ( MonadIO m+     , MonadReader env m+     , HasLogFunc env+     )+  => Khr.SurfaceKHR -> Vk.PhysicalDevice -> m (Maybe PhysicalDeviceInfo)+physicalDeviceInfo surf phys = runMaybeT do+  pdiName <- physicalDeviceName phys+  logDebug $ "Considering " <> displayShow pdiName++  hasTimelineSemaphores <- deviceHasTimelineSemaphores phys+  unless hasTimelineSemaphores do+    logWarn $ mconcat+      [ "Not using physical device "+      , displayShow pdiName+      , " because it doesn't support timeline semaphores"+      ]++  hasSwapchainSupport <- deviceHasSwapchain phys+  unless hasSwapchainSupport do+    logWarn $ mconcat+      [ "Not using physical device "+      , displayShow pdiName+      , " because it doesn't support swapchains"+      ]++  (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT $+    Utils.assignQueues phys (queueRequirements phys surf)++  pdiTotalMemory <- do+    props <- Vk.getPhysicalDeviceMemoryProperties phys+    pure . sum $+      fmap+        (Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize)+        (Vk.memoryHeaps props)++  pdiProperties <- Vk.getPhysicalDeviceProperties phys++  pure PhysicalDeviceInfo{..}++{- |+  Requirements for a 'Queue' which has graphics support and can present to+  the specified surface.++  Priorities are ranged 0.0 to 1.0 with higher number means higher priority.+  https://www.khronos.org/registry/vulkan/specs/1.2-extensions/html/vkspec.html#devsandqueues-priority+-}+queueRequirements+  :: MonadIO m+  => Vk.PhysicalDevice -> Khr.SurfaceKHR -> Queues (QueueSpec m)+queueRequirements phys surf = Queues+  { qGraphics = QueueSpec 1.0 isGraphicsPresentQueue+  , qCompute  = QueueSpec 0.5 isComputeQueue+  , qTransfer = QueueSpec 0.0 isTransferQueue+  }+ where+  isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = do+    pq <- Utils.isPresentQueueFamily phys surf queueFamilyIndex+    let gq = Utils.isGraphicsQueueFamily queueFamilyProperties+    pure $ pq && gq++  isTransferQueue _queueFamilyIndex queueFamilyProperties =+    pure $ Utils.isTransferQueueFamily queueFamilyProperties++  isComputeQueue _queueFamilyIndex queueFamilyProperties =+    pure $ Utils.isComputeQueueFamily queueFamilyProperties++deviceHasSwapchain :: MonadIO m => Vk.PhysicalDevice -> m Bool+deviceHasSwapchain dev = do+  (_, extensions) <- Vk.enumerateDeviceExtensionProperties dev Nothing+  pure $ V.any+    ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . Vk.extensionName)+    extensions++deviceHasTimelineSemaphores :: MonadIO m => Vk.PhysicalDevice -> m Bool+deviceHasTimelineSemaphores phys = do+  (_, extensions) <- Vk.enumerateDeviceExtensionProperties phys Nothing+  let+    hasExt = V.any+      ((KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME ==) . Vk.extensionName)+      extensions++  hasFeat <- getPhysicalDeviceFeatures2KHR phys >>= \case+    _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) ->+      pure hasTimelineSemaphores+    _ ->+      pure False++  pure $ hasExt && hasFeat++allocateLogical+  :: ( MonadUnliftIO m+     , MonadReader env m, HasLogFunc env+     , MonadResource m+     )+  => PhysicalDeviceInfo -> Vk.PhysicalDevice -> m Vk.Device+allocateLogical pdi pd = do+  logDebug "Creating logical device"++  ld <- createDeviceFromRequirements+    [Utils.reqs|+      1.2++      VK_KHR_maintenance3+      VK_KHR_swapchain++      -- PhysicalDeviceFeatures.robustBufferAccess+      PhysicalDeviceFeatures.textureCompressionBC++      VK_KHR_multiview+      PhysicalDeviceMultiviewFeatures.multiview++      VK_EXT_descriptor_indexing+      PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingPartiallyBound+      PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingVariableDescriptorCount+      PhysicalDeviceDescriptorIndexingFeatures.runtimeDescriptorArray+      PhysicalDeviceDescriptorIndexingFeatures.shaderSampledImageArrayNonUniformIndexing++      VK_KHR_timeline_semaphore+      PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore+    |]+    [Utils.reqs|+      PhysicalDeviceFeatures.samplerAnisotropy+      PhysicalDeviceFeatures.sampleRateShading+    |]+    pd+    deviceCI++  toIO (logDebug "Destroying logical device") >>=+    Resource.register++  pure ld++  where+    deviceCI = zero+      { Vk.queueCreateInfos = fmap SomeStruct (pdiQueueCreateInfos pdi)+      }++noSuchThing :: MonadThrow m => String -> m a+noSuchThing message =+  throwM $+    IOError Nothing NoSuchThing "" message Nothing Nothing
+ src/Engine/Setup/Window.hs view
@@ -0,0 +1,171 @@+module Engine.Setup.Window+  ( GLFW.Window+  , allocate+  , createWindow+  , destroyWindow++  , SizePicker+  , pickLargest++  , Khr.SurfaceKHR+  , allocateSurface+  , createSurface++  , getExtent2D++  , GLFWError+  , GLFW.Error+  ) where++import RIO hiding (some)++import Data.List.NonEmpty qualified as NonEmpty+import Foreign qualified+import Graphics.UI.GLFW qualified as GLFW+import RIO.ByteString qualified as BS+import RIO.Text qualified as Text+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Extensions.VK_KHR_surface qualified as Khr+import Vulkan.Requirement (InstanceRequirement(..))++data GLFWError+  = InitError      GLFW.Error String+  | VulkanError    GLFW.Error String+  | MonitorError   GLFW.Error String+  | VideoModeError GLFW.Error String+  | WindowError    GLFW.Error String+  | SurfaceError   Vk.Result+  deriving (Eq, Ord, Show)++instance Exception GLFWError++type SizePicker = NonEmpty (GLFW.Monitor, GLFW.VideoMode) -> (GLFW.Monitor, GLFW.VideoMode)++allocate+  :: ( MonadUnliftIO m+     , MonadReader env m, HasLogFunc env+     , MonadResource m+     )+  => Bool+  -> SizePicker+  -> Text+  -> m ([InstanceRequirement], GLFW.Window)+allocate fullscreen sizePicker title = do+  UnliftIO unliftIO <- askUnliftIO++  let+    create = unliftIO $+      createWindow fullscreen sizePicker title++    destroy (_exts, window) = unliftIO $+      destroyWindow window++  fmap snd $ Resource.allocate create destroy++createWindow+  :: (MonadIO m, MonadReader env m, HasLogFunc env)+  => Bool -> SizePicker -> Text -> m ([InstanceRequirement], GLFW.Window)+createWindow fullScreen sizePicker title = do+  runGlfwIO_ InitError GLFW.init+  runGlfwIO_ VulkanError GLFW.vulkanSupported++  liftIO . GLFW.windowHint $ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI++  sizes <- runGlfwIO MonitorError GLFW.getMonitors >>= \case+    [] ->+      liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "No monitors returned"+    some ->+      fmap NonEmpty.fromList $+        for some \monitor -> do+          mode <- runGlfwIO VideoModeError $ GLFW.getVideoMode monitor+          pure (monitor, mode)++  let+    (monitor, mode) = sizePicker sizes+    GLFW.VideoMode{videoModeWidth=width, videoModeHeight=height} = mode+    fsMonitor =+      if fullScreen then+        Just monitor+      else+        Nothing++  logDebug $ "Display mode picked: " <> displayShow mode++  window <- runGlfwIO WindowError $+    GLFW.createWindow width height (Text.unpack title) fsMonitor Nothing++  extNamesC <- liftIO $ GLFW.getRequiredInstanceExtensions+  extNames <- liftIO $ traverse BS.packCString extNamesC++  when fullScreen $+    liftIO $ GLFW.setFullscreen window monitor mode++  let+    instanceReqs = do+      name <- extNames+      pure $ RequireInstanceExtension Nothing name minBound++  pure (instanceReqs, window)++destroyWindow+  :: (MonadIO m, MonadReader env m, HasLogFunc env)+  => GLFW.Window -> m ()+destroyWindow window = do+  logDebug "Destroying GLFW window"+  liftIO do+    GLFW.destroyWindow window+    GLFW.terminate++allocateSurface+  :: MonadResource m+  => GLFW.Window+  -> Vk.Instance+  -> m (Resource.ReleaseKey, Khr.SurfaceKHR)+allocateSurface window instance_ =+  Resource.allocate+    (createSurface window instance_)+    (\surf -> Khr.destroySurfaceKHR instance_ surf Nothing)++createSurface :: MonadIO m => GLFW.Window -> Vk.Instance -> m Khr.SurfaceKHR+createSurface window instance_ =+  liftIO $ Foreign.alloca \dst -> do+    vkResult <- GLFW.createWindowSurface @Foreign.Int32 inst window Foreign.nullPtr dst+    if vkResult == 0 then+      fmap Khr.SurfaceKHR $ Foreign.peek dst+    else+      throwIO . SurfaceError $ Vk.Result vkResult+  where+    inst = Foreign.castPtr $ Vk.instanceHandle instance_++runGlfwIO_ :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO Bool -> io ()+runGlfwIO_ cons action =+  runGlfwIO cons $ action >>= \case+    True ->+      pure $ Just ()+    False ->+      pure Nothing++runGlfwIO :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO (Maybe a) -> io a+runGlfwIO cons action =+  liftIO $ action >>= \case+    Just res ->+      pure res+    Nothing ->+      GLFW.getError >>= \case+        Just (err, msg) ->+          throwIO $ cons err msg+        Nothing ->+          throwIO $ cons GLFW.Error'PlatformError "Unknown error"++pickLargest :: SizePicker+pickLargest monitors = NonEmpty.head $ NonEmpty.sortBy (flip compare `on` getArea) monitors+  where+    getArea (_mon, GLFW.VideoMode{videoModeWidth=w, videoModeHeight=h}) =+      w * h++getExtent2D :: GLFW.Window -> IO Vk.Extent2D+getExtent2D window = do+  (width, height) <- GLFW.getFramebufferSize window+  pure $ Vk.Extent2D (fromIntegral width) (fromIntegral height)
+ src/Engine/Stage/Bootstrap/Setup.hs view
@@ -0,0 +1,87 @@+module Engine.Stage.Bootstrap.Setup+  ( stackStage+  , bootstrapStage+  ) where++import RIO++import Control.Monad.Trans.Resource (ResourceT)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::))++import Engine.Types (StackStage(..), StageRIO, StageFrameRIO)+import Engine.Types qualified as Engine+import Engine.Vulkan.Types (Queues)+import Engine.StageSwitch (trySwitchStage)++import Engine.Stage.Bootstrap.Types (NoRendering(..), NoPipelines(..), NoResources(..), NoState(..))++stackStage+  :: (a -> StackStage)+  -> Engine.StageSetupRIO a+  -> StackStage+stackStage handoff action = StackStage $ bootstrapStage handoff action++bootstrapStage+  :: (a -> StackStage)+  -> Engine.StageSetupRIO a+  -> Engine.Stage NoRendering NoPipelines NoResources NoState+bootstrapStage handoff action = Engine.Stage+  { sTitle = "Bootstrap"++  , sAllocateP  = noPipelines+  , sInitialRS  = transitState handoff action+  , sInitialRR  = noFrameResources++  , sBeforeLoop     = pure ()+  , sUpdateBuffers  = noUpdates+  , sRecordCommands = noCommands+  , sAfterLoop      = pure+  }++noPipelines :: swapchain -> NoRendering -> ResourceT (StageRIO st) NoPipelines+noPipelines _swapchain NoRendering =+  pure NoPipelines++noCommands+  :: Vk.CommandBuffer+  -> rd+  -> "image index" ::: Word32+  -> StageFrameRIO rp p rd st ()+noCommands _cb _rd _index =+  pure ()++noUpdates+  :: st+  -> rd+  -> StageFrameRIO rp p rd st ()+noUpdates _st _rd =+  pure ()++transitState+  :: (a -> StackStage)+  -> Engine.StageSetupRIO a+  -> Engine.StageSetupRIO (Resource.ReleaseKey, NoState)+transitState handoff action = do+  res <- action++  switched <- trySwitchStage . Engine.Replace $+    handoff res++  unless switched $+    logError "Bootstrap switch failed"++  key <- Resource.register $ pure ()+  pure (key, NoState)++noFrameResources+  :: Queues Vk.CommandPool+  -> renderPasses+  -> pipelines+  -> ResourceT (StageRIO rs) NoResources+noFrameResources _queues _rp _p =+  fmap snd $!+    Resource.allocate+      (pure NoResources)+      (\NoResources -> pure ())
+ src/Engine/Stage/Bootstrap/Types.hs view
@@ -0,0 +1,28 @@+module Engine.Stage.Bootstrap.Types+  ( Stage++  , NoRendering(..)+  , NoPipelines(..)+  , NoResources(..)+  , NoState(..)+  ) where++import RIO++import Engine.Vulkan.Types (RenderPass(..))+import Engine.Types qualified as Engine++data NoRendering = NoRendering++instance RenderPass NoRendering where+  allocateRenderpass_ _context = pure NoRendering+  updateRenderpass _context = pure+  refcountRenderpass _rp = pure ()++data NoPipelines = NoPipelines++type Stage = Engine.Stage NoRendering NoPipelines NoResources NoState++data NoResources = NoResources++data NoState = NoState
+ src/Engine/StageSwitch.hs view
@@ -0,0 +1,42 @@+module Engine.StageSwitch+  ( StageSwitchVar+  , newStageSwitchVar++  , StageSwitch(..)+  , trySwitchStage+  , trySwitchStageSTM+  , getNextStage+  ) where++import RIO++import RIO.App (appEnv)++import Engine.Types (NextStage, StageRIO, StageSwitch(..), StageSwitchVar)+import Engine.Types qualified as Engine++newStageSwitchVar :: MonadIO m => m StageSwitchVar+newStageSwitchVar = newEmptyTMVarIO++trySwitchStage :: NextStage -> StageRIO rs Bool+trySwitchStage nextStage = do+  var <- asks $ Engine.ghStageSwitch . appEnv+  atomically $ trySwitchStageSTM var nextStage++trySwitchStageSTM :: StageSwitchVar -> NextStage -> STM Bool+trySwitchStageSTM switchVar = tryPutTMVar switchVar . StageSwitchPending++getNextStage :: StageRIO rs (Maybe NextStage)+getNextStage = do+  var <- asks $ Engine.ghStageSwitch . appEnv+  atomically do+    noSwitch <- isEmptyTMVar var+    if noSwitch then+      pure Nothing+    else+      takeTMVar var >>= \case+        StageSwitchPending nextStage -> do+          putTMVar var StageSwitchHandled+          pure $ Just nextStage+        StageSwitchHandled ->+          pure Nothing
+ src/Engine/Types.hs view
@@ -0,0 +1,171 @@+module Engine.Types where++import RIO++import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Trans.Resource qualified as ResourceT+import Graphics.UI.GLFW qualified as GLFW+import RIO.App (App, appEnv)+import RIO.Lens (_1)+import UnliftIO.Resource (MonadResource, ReleaseKey)+import Vulkan.Core10 qualified as Vk+import Vulkan.Extensions.VK_KHR_surface qualified as Khr+import Vulkan.NamedType ((:::))+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import VulkanMemoryAllocator qualified as VMA++import Engine.Camera (ProjectionProcess)+import Engine.Setup.Window (Window)+import Engine.Types.RefCounted (RefCounted)+import Engine.Vulkan.Swapchain (SwapchainResources(..))+import Engine.Vulkan.Types (HasVulkan(..))+import Engine.Vulkan.Types qualified as Vulkan++-- * App globals++-- | A bunch of global, unchanging state we cart around+data GlobalHandles = GlobalHandles+  { ghWindow             :: GLFW.Window+  , ghSurface            :: Khr.SurfaceKHR+  , ghInstance           :: Vk.Instance+  , ghPhysicalDevice     :: Vk.PhysicalDevice+  , ghPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo+  , ghDevice             :: Vk.Device+  , ghAllocator          :: VMA.Allocator+  , ghQueues             :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue)+  , ghScreenP            :: ProjectionProcess+  , ghStageSwitch        :: StageSwitchVar+  }++getScreenP :: MonadReader (App GlobalHandles s) m => m ProjectionProcess+getScreenP = asks $ ghScreenP . appEnv++instance HasVulkan GlobalHandles where+  getInstance           = ghInstance+  getQueues             = ghQueues+  getPhysicalDevice     = ghPhysicalDevice+  getPhysicalDeviceInfo = ghPhysicalDeviceInfo+  getDevice             = ghDevice+  getAllocator          = ghAllocator++-- * Stage stack++type StageStack = [StackStage]++data NextStage+  = Finish+  | Replace     StackStage+  | PushRestart StackStage+  | PushFreeze  StackStage++data StackStage where+  StackStage+    :: forall rp p rr st+    .  Vulkan.RenderPass rp+    => Stage rp p rr st+    -> StackStage+  StackStageContinue+    :: forall rp p rr st+    .  Vulkan.RenderPass rp+    => ReleaseKey+    -> st+    -> Stage rp p rr st+    -> StackStage++type StageSwitchVar = TMVar StageSwitch++data StageSwitch+  = StageSwitchPending NextStage+  | StageSwitchHandled++-- * Stage on a stack++type StageRIO st = RIO (App GlobalHandles st)++type StageSetupRIO = RIO (App GlobalHandles (Maybe SwapchainResources))++type StageFrameRIO rp p rr st = RIO (App GlobalHandles st, Frame rp p rr)++data Stage rp p rr st = forall a . Stage+  { sTitle :: Text++  , sAllocateP  :: SwapchainResources -> rp -> ResourceT (StageRIO st) p+  , sInitialRS  :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)+  , sInitialRR  :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr++  , sBeforeLoop       :: StageRIO st a+  , sUpdateBuffers    :: st -> rr -> StageFrameRIO rp p rr st ()+  , sRecordCommands   :: Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ()+  , sAfterLoop        :: a -> StageRIO st ()+  }++-- * Frame loop inside a stage++-- | All the information required to render a single frame+data Frame renderpass pipelines resources = Frame+  { fIndex                       :: Word64 -- ^ Which number frame is this+  , fWindow                      :: Window+  , fSurface                     :: Khr.SurfaceKHR++  , fSwapchainResources          :: SwapchainResources+  , fRenderpass                  :: renderpass+  , fPipelines                   :: pipelines+  , fRenderFinishedHostSemaphore :: Vk.Semaphore+    {- ^+      A timeline semaphore which increments to fIndex when this frame+      is done, the host can wait on this semaphore.+    -}++  , fStageResources              :: (RefCounted, ResourceT.InternalState)+    -- ^ Swapchain-derived resources with a life time of this Frame's stage.++  , fGPUWork                     :: IORef [GPUWork]+    {- ^+      Timeline semaphores and corresponding wait values, updates as the+      frame progresses.+    -}++  , fResources                   :: (ReleaseKey, ResourceT.InternalState)+    {- ^+      The 'InternalState' for tracking frame-local resources along with the+      key to release it in the global scope. This will be released when the+      frame is done with GPU work.+    -}++  , fRecycledResources           :: RecycledResources resources+    {- ^+      Resources which can be used for this frame and are then passed on to a+      later frame.+    -}+  }++type GPUWork =+  ( "host semaphore" ::: Vk.Semaphore+  , "frame index" ::: Word64+  )++-- | These are resources which are reused by a later frame when the current+-- frame is retired+data RecycledResources a = RecycledResources+  { rrImageAvailableSemaphore :: Vk.Semaphore+    -- ^ A binary semaphore passed to 'acquireNextImageKHR'+  , rrRenderFinishedSemaphore :: Vk.Semaphore+    -- ^ A binary semaphore to synchronize rendering and presenting++  , rrQueues                  :: Vulkan.Queues Vk.CommandPool+    {- ^+      Pool for this frame's commands for each of the queue families.+      (might want more than one of these for multithreaded recording)+    -}++  , rrData                    :: a+  }++instance HasLogFunc env => HasLogFunc (env, Frame rp p rr) where+  logFuncL = _1 . logFuncL++instance MonadResource (RIO (env, Frame rp p rr)) where+  {-# INLINE liftResourceT #-}+  liftResourceT rt =+    asks (snd . fResources . snd) >>=+      liftIO . ResourceT.runInternalState rt
+ src/Engine/Types/Options.hs view
@@ -0,0 +1,50 @@+module Engine.Types.Options+  ( Options(..)+  , getOptions+  , optionsP+  ) where++import RIO++import Options.Applicative.Simple qualified as Opt++import Paths_keid_core qualified++-- | Command line arguments+data Options = Options+  { optionsVerbose :: Bool+  , optionsFullscreen :: Bool+  }+  deriving (Show)++getOptions :: IO Options+getOptions = do+  (options, ()) <- Opt.simpleOptions+    $(Opt.simpleVersion Paths_keid_core.version)+    header+    description+    optionsP+    Opt.empty+  pure options+  where+    header =+      "Another playground"++    description =+      mempty++optionsP :: Opt.Parser Options+optionsP = do+  optionsVerbose <- Opt.switch $ mconcat+    [ Opt.long "verbose"+    , Opt.short 'v'+    , Opt.help "Show more and more detailed messages"+    ]++  optionsFullscreen <- Opt.switch $ mconcat+    [ Opt.long "fullscreen"+    , Opt.short 'f'+    , Opt.help "Run in fullscreen mode"+    ]++  pure Options{..}
+ src/Engine/Types/RefCounted.hs view
@@ -0,0 +1,50 @@+module Engine.Types.RefCounted where++import RIO++import Control.Monad.Trans.Resource (allocate_)+import GHC.IO.Exception (IOErrorType(UserError), IOException(IOError))+import UnliftIO.Resource (MonadResource)++-- | A 'RefCounted' will perform the specified action when the count reaches 0+data RefCounted = RefCounted+  { rcCount  :: IORef Int+  , rcAction :: IO ()+  }++-- | Create a counter with a value of 1+newRefCounted :: MonadIO m => IO () -> m RefCounted+newRefCounted rcAction = do+  rcCount <- liftIO $ newIORef 1+  pure RefCounted{..}++-- | Decrement the value, the action will be run promptly and in+-- this thread if the counter reached 0.+releaseRefCounted :: MonadIO m => RefCounted -> m ()+releaseRefCounted RefCounted{..} =+  liftIO $ mask \_ ->+    atomicModifyIORef' rcCount (\c -> (c - 1, c - 1)) >>= \case+      n | n < 0 ->+        throwM $ IOError+          Nothing+          UserError+          ""+          "Ref counted value decremented below 0"+          Nothing+          Nothing++      0 ->+        rcAction++      _stillReferenced ->+        pure ()++-- | Increment the counter by 1+takeRefCounted :: MonadIO m => RefCounted -> m ()+takeRefCounted RefCounted{..} =+  liftIO $ atomicModifyIORef' rcCount \c -> (c + 1, ())++-- | Hold a reference for the duration of the 'MonadResource' action+resourceTRefCount :: MonadResource f => RefCounted -> f ()+resourceTRefCount r =+  void $ allocate_ (takeRefCounted r) (releaseRefCounted r)
+ src/Engine/UI/Layout.hs view
@@ -0,0 +1,364 @@+module Engine.UI.Layout+  ( BoxProcess+  , Box(..)+  , trackScreen+  , padAbs+  , hSplitRel+  , vSplitRel++  , splitsRelStatic+  , sharePadsH+  , sharePadsV++  , boxPadAbs+  , sharePads++  , fitPlaceAbs+  , boxFitPlace+  , boxFitScale++  , boxRectAbs+  , boxTransformAbs++  , Alignment(..)+  , pattern LeftTop+  , pattern LeftMiddle+  , pattern LeftBottom+  , pattern CenterTop+  , pattern Center+  , pattern CenterBottom+  , pattern RightTop+  , pattern RightMiddle+  , pattern RightBottom+  , Origin(..)++  , whenInBoxP+  , pointInBox+  ) where++import RIO++import Data.Traversable (mapAccumL)+import Geomancy (Transform, Vec2, Vec4, vec2, vec4, withVec2, pattern WithVec2, pattern WithVec4)+import Geomancy.Transform qualified as Transform+import Geomancy.Vec4 qualified as Vec4+import RIO.App (appEnv)+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::))++import Engine.Camera qualified as Camera+import Engine.Types qualified as Engine+import Engine.Worker qualified as Worker++data Box = Box+  { boxPosition :: Vec2+  , boxSize     :: Vec2+  }+  deriving (Eq, Ord, Show)++data Alignment = Alignment+  { alignX :: Origin -- ^ left/center/right+  , alignY :: Origin -- ^ top/middle/bottom+  }++pattern LeftTop :: Alignment+pattern LeftTop = Alignment Begin  Begin++pattern LeftMiddle :: Alignment+pattern LeftMiddle = Alignment Begin Middle++pattern LeftBottom :: Alignment+pattern LeftBottom = Alignment Begin End++pattern CenterTop :: Alignment+pattern CenterTop = Alignment Middle Begin++pattern Center :: Alignment+pattern Center = Alignment Middle Middle++pattern CenterBottom :: Alignment+pattern CenterBottom = Alignment Middle End++pattern RightTop :: Alignment+pattern RightTop = Alignment End Begin++pattern RightMiddle :: Alignment+pattern RightMiddle = Alignment End Middle++pattern RightBottom :: Alignment+pattern RightBottom = Alignment End End++data Origin+  = Begin+  | Middle+  | End+  deriving (Eq, Ord, Show, Enum, Bounded)++type BoxProcess = Worker.Merge Box++trackScreen :: Engine.StageRIO st BoxProcess+trackScreen = do+  projection <- asks $ Engine.ghScreenP . appEnv+  Worker.spawnMerge1 mkBox (Worker.getInput projection)+  where+    mkBox Camera.ProjectionInput{projectionScreen} = Box+      { boxPosition = 0+      , boxSize     = vec2 (fromIntegral width) (fromIntegral height)+      }+      where+        Vk.Extent2D{width, height} = projectionScreen++padAbs+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     , Worker.HasOutput padding+     , Worker.GetOutput padding ~ Vec4+     )+  => parent+  -> padding+  -> m BoxProcess+padAbs = Worker.spawnMerge2 boxPadAbs++{-# INLINEABLE boxPadAbs #-}+boxPadAbs :: Box -> Vec4 -> Box+boxPadAbs Box{..} (WithVec4 top right bottom left) = Box+  { boxPosition = boxPosition + vec2 dx dy+  , boxSize     = boxSize - vec2 dw dh+  }+  where+    WithVec2 w h = boxSize+    dx = left * 0.5 - right * 0.5+    dy = top * 0.5 - bottom * 0.5+    dw = min w (left + right)+    dh = min h (top + bottom)++padRel+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     , Worker.HasOutput padding+     , Worker.GetOutput padding ~ Vec4+     )+  => parent+  -> padding+  -> m BoxProcess+padRel = Worker.spawnMerge2 boxPadRel++{-# INLINEABLE boxPadRel #-}+boxPadRel :: Box -> Vec4 -> Box+boxPadRel box@Box{boxSize=WithVec2 w h} pad =+  boxPadAbs box (pad * vec4 h w h w)++fitPlaceAbs+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     )+  => Alignment+  -> "dimensions" ::: Vec2+  -> parent+  -> m BoxProcess+fitPlaceAbs align dimensions =+  Worker.spawnMerge1+    (boxFitPlace align dimensions)++{-# INLINEABLE boxFitPlace #-}+boxFitPlace+  :: Alignment+  -> "dimensions" ::: Vec2+  -> "parent" ::: Box+  -> Box+boxFitPlace Alignment{..} wh parent =+  boxPadAbs parent (vec4 t r b l)+  where+    (WithVec2 dw dh, _box) = boxFitScale wh parent++    (l, r) = case alignX of+      Begin  -> (0,      dw)+      Middle -> (dw / 2, dw / 2)+      End    -> (dw,     0)++    (t, b) = case alignY of+      Begin  -> (0,      dh)+      Middle -> (dh / 2, dh / 2)+      End    -> (dh,     0)++{-# INLINEABLE boxFitScale #-}+boxFitScale+  :: "dimensions" ::: Vec2+  -> "parent" ::: Box+  -> ( "leftovers" ::: Vec2+     , Box+     )+boxFitScale (WithVec2 w h) parent =+  ( vec2 (pw - sw) (ph - sh)+  , Box+      { boxSize     = vec2 sw sh+      , boxPosition = boxPosition parent+      }+  )+  where+    Box{boxSize=WithVec2 pw ph} = parent++    sw = scale * w+    sh = scale * h++    scale =+      if parentAspect > aspect then+        ph / h+      else+        pw / w+      where+        parentAspect = pw / ph+        aspect = w / h++splitsRelStatic+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     , Traversable t -- XXX: nested traversables may behave suprisingly+     )+  => ((Float, Float) -> Vec4)+  -> parent+  -> t Float+  -> m (t BoxProcess)+splitsRelStatic padF parentVar shares =+  for (sharePads totalShares shares) \pads -> do+    shareVar <- Worker.newVar $ padF pads Vec4.^/ totalShares+    padRel parentVar shareVar+  where+    totalShares = sum shares++sharePadsH :: (Float, Float) -> Vec4+sharePadsH (left, right) = vec4 0 right 0 left++sharePadsV :: (Float, Float) -> Vec4+sharePadsV (top, bottom) = vec4 top 0 bottom 0++sharePads :: Traversable t => Float -> t Float -> t (Float, Float)+sharePads totalShares shares = snd $ mapAccumL f 0 shares+  where+    f sharesBefore share =+      ( sharesBefore + share+      , ( sharesBefore+        , totalShares - sharesBefore - share+        )+      )++hSplitRel+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     , Worker.HasOutput proportion+     , Worker.GetOutput proportion ~ Float+     )+  => parent+  -> proportion+  -> m (BoxProcess, BoxProcess)+hSplitRel parentVar proportionVar = (,)+  <$> spawnLeft parentVar proportionVar+  <*> spawnRight parentVar proportionVar+  where+    spawnLeft = Worker.spawnMerge2 \parent proportion ->+      let+        rightWidth =+          withVec2 (boxSize parent) \width _height ->+            width - width * proportion+      in+        boxPadAbs parent (vec4 0 rightWidth 0 0)++    spawnRight = Worker.spawnMerge2 \parent proportion ->+      let+        leftWidth =+          withVec2 (boxSize parent) \width _height ->+            width * proportion+      in+        boxPadAbs parent (vec4 0 0 0 leftWidth)++vSplitRel+  :: ( MonadUnliftIO m+     , Worker.HasOutput parent+     , Worker.GetOutput parent ~ Box+     , Worker.HasOutput proportion+     , Worker.GetOutput proportion ~ Float+     )+  => parent+  -> proportion+  -> m (BoxProcess, BoxProcess)+vSplitRel parentVar proportionVar = (,)+  <$> spawnTop parentVar proportionVar+  <*> spawnBottom parentVar proportionVar+  where+    spawnTop = Worker.spawnMerge2 \parent proportion ->+      let+        bottomHeight =+          withVec2 (boxSize parent) \_width height ->+            height - height * proportion+      in+        boxPadAbs parent (vec4 0 0 bottomHeight 0)++    spawnBottom = Worker.spawnMerge2 \parent proportion ->+      let+        topHeight =+          withVec2 (boxSize parent) \_width height ->+            height * proportion+      in+        boxPadAbs parent (vec4 topHeight 0 0 0)++{-# INLINEABLE boxRectAbs #-}+boxRectAbs :: Box -> Vk.Rect2D+boxRectAbs Box{..} =+  withVec2 boxPosition \x y ->+  withVec2 boxSize \w h ->+    let+      r = Vk.Rect2D+        { offset = Vk.Offset2D (truncate $ x) (truncate $ y) -- FIXME: rects have top-left origin+        , extent = Vk.Extent2D (truncate w) (truncate h)+        }+    in+      -- traceShow (Box{..}, r)+      r++{-# INLINEABLE boxTransformAbs #-}+boxTransformAbs :: Box -> Transform+boxTransformAbs Box{..} = mconcat+  [ withVec2 boxSize Transform.scaleXY+  , withVec2 boxPosition translateXY+  ]++{-# INLINE translateXY #-}+translateXY :: Float -> Float -> Transform+translateXY x y = Transform.translate x y 0++whenInBoxP+  :: ( MonadIO m+     , Worker.HasOutput box+     , Worker.GetOutput box ~ Box+     )+  => "screen" ::: Vec2+  -> box+  -> ("local" ::: Vec2 -> m ())+  -> m ()+whenInBoxP cursorPos boxP action = do+  box <- Worker.getOutputData boxP+  when (pointInBox cursorPos box) $+    action $ cursorPos - boxPosition box++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
+ src/Engine/Vulkan/DescSets.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE UndecidableInstances #-}++-- XXX: TypeError in Compatible generates unused constraint argument+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Engine.Vulkan.DescSets+  ( HasDescSet(..)++  , Bound(..)+  , withBoundDescriptorSets0++  , Compatible++  , Extend+  , extendDS++  , Tagged(..)+  ) where++import RIO++import Data.Kind (Constraint, Type)+import Data.Tagged (Tagged(..))+import GHC.TypeLits as Type+import Vulkan.Core10 qualified as Vk++import Engine.Types (Frame(fRecycledResources), RecycledResources(rrData))+import Engine.Vulkan.Types (Bound(..))++class HasDescSet tag a where+  getDescSet :: a -> Tagged tag Vk.DescriptorSet++instance HasDescSet tag rr => HasDescSet tag (RecycledResources rr) where+  {-# INLINE getDescSet #-}+  getDescSet = getDescSet . rrData++instance HasDescSet tag rr => HasDescSet tag (Frame rp p rr) where+  {-# INLINE getDescSet #-}+  getDescSet = getDescSet . fRecycledResources++instance HasDescSet tag rr => HasDescSet tag (env, Frame rp p rr) where+  {-# INLINE getDescSet #-}+  getDescSet = getDescSet . snd++{-# INLINE withBoundDescriptorSets0 #-}+withBoundDescriptorSets0+  :: MonadIO m+  => Vk.CommandBuffer+  -> Vk.PipelineBindPoint+  -> Tagged dsl Vk.PipelineLayout+  -> Tagged dsl (Vector Vk.DescriptorSet)+  -> Bound dsl Void Void m b+  -> m b+withBoundDescriptorSets0 cb pbp (Tagged layout) (Tagged descriptorSets) (Bound action) = do+  Vk.cmdBindDescriptorSets+    cb+    pbp+    layout+    0+    descriptorSets+    mempty++  action++type Compatible (smaller :: [Type]) (larger :: [Type]) = Compatible' smaller larger smaller larger++type family Compatible' (xs :: [Type]) (ys :: [Type]) (a :: [Type]) (b :: [Type]) :: Constraint where+  Compatible' '[] _ _ _ = ()+  Compatible' (x : xs) (x : ys) a b = Compatible' xs ys a b+  Compatible' _ _ a b = TypeError+    ( 'ShowType a ':<>: 'Text " isn't compatible prefix of " ':<>: 'ShowType b+    )++type family Extend (xs :: [Type]) y :: [Type] where+  Extend '[] y = '[y]+  Extend (x ': xs) y = x ': Extend xs y++extendDS+  :: Tagged (as :: [Type]) (Vector Vk.DescriptorSet)+  -> Tagged b Vk.DescriptorSet+  -> Tagged (Extend as b) (Vector Vk.DescriptorSet)+extendDS (Tagged xs) (Tagged y) = Tagged (xs <> [y])
+ src/Engine/Vulkan/Pipeline.hs view
@@ -0,0 +1,416 @@+-- XXX: TypeError in Compatible generates unused constraint argument+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Engine.Vulkan.Pipeline+  ( Pipeline(..)+  , Config(..)+  , allocate+  , bind++  , pushPlaceholder++  , vertexInput+  , attrBindings+  , formatSize+  ) where++import RIO++import Data.Bits ((.|.))+import Data.Kind (Type)+import Data.List qualified as List+import Data.Tagged (Tagged(..))+import Data.Vector qualified as Vector+import UnliftIO.Resource (MonadResource, ReleaseKey)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12+import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))+import Vulkan.NamedType ((:::))+import Vulkan.Zero (Zero(..))++import Engine.Vulkan.DescSets (Bound(..), Compatible)+import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache)++data Pipeline (dsl :: [Type]) vertices instances = Pipeline+  { pipeline     :: Vk.Pipeline+  , pLayout      :: Tagged dsl Vk.PipelineLayout+  , pDescLayouts :: Tagged dsl DsLayouts+  }++-- * Pipeline++data Config (dsl :: [Type]) vertices instances = Config+  { cVertexCode         :: Maybe ByteString+  , cFragmentCode       :: Maybe ByteString+  , cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo+  , cDescLayouts        :: Tagged dsl [DsBindings]+  , cPushConstantRanges :: Vector Vk.PushConstantRange+  , cBlend              :: Bool+  , cDepthWrite         :: Bool+  , cDepthTest          :: Bool+  , cTopology           :: Vk.PrimitiveTopology+  , cCull               :: Vk.CullModeFlagBits+  , cDepthBias          :: Maybe ("constant" ::: Float, "slope" ::: Float)+  }++instance Zero (Config dsl vertices instances) where+  zero = Config+    { cVertexCode         = Nothing+    , cFragmentCode       = Nothing+    , cVertexInput        = zero+    , cDescLayouts        = Tagged [] -- FIXME: unsafe wrt. "dsl"+    , cPushConstantRanges = mempty+    , cBlend              = False+    , cDepthWrite         = True+    , cDepthTest          = True+    , cTopology           = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST+    , cCull               = Vk.CULL_MODE_BACK_BIT+    , cDepthBias          = Nothing+    }++-- XXX: consider using instance attrs or uniforms+pushPlaceholder :: Vk.PushConstantRange+pushPlaceholder = Vk.PushConstantRange+  { Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT+  , Vk.offset     = 0+  , Vk.size       = 4 * dwords+  }+  where+    -- XXX: each 4 word32s eat up one register (on AMD)+    dwords = 4++allocate+  :: ( MonadVulkan env m+     , MonadResource m+     , HasRenderPass renderpass+     )+  => Maybe Vk.Extent2D+  -> Vk.SampleCountFlagBits+  -> Config dsl vertices instances+  -> renderpass+  -> m (ReleaseKey, Pipeline dsl vertices instances)+allocate extent msaa config renderpass = do+  ctx <- ask+  Resource.allocate+    (create ctx extent msaa renderpass config)+    (destroy ctx)++create+  :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass)+  => ctx+  -> Maybe Vk.Extent2D+  -> Vk.SampleCountFlagBits+  -> renderpass+  -> Config dsl vertices instances+  -> io (Pipeline dsl vertices instances)+create context mextent msaa renderpass Config{..} = do+  dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do+    let+      (binds, flags) = List.unzip bindsFlags++      setCI =+        zero+          { Vk.bindings = Vector.fromList binds+          }+        ::& zero+          { Vk12.bindingFlags = Vector.fromList flags+          }+        :& ()++    Vk.createDescriptorSetLayout device setCI Nothing++  -- TODO: get from outside+  layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing++  let+    codeStages = Vector.fromList $ case (cVertexCode, cFragmentCode) of+      (Just vertCode, Just fragCode) ->+        [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)+        , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)+        ]++      (Just vertCode, Nothing) ->+        [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)+        ]++      (Nothing, Just fragCode) ->+        -- XXX: good luck+        [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)+        ]++      (Nothing, Nothing) ->+        []+  shader <- createShader context codeStages++  let+    cis = Vector.singleton . SomeStruct $+      pipelineCI (sPipelineStages shader) layout++  Vk.createGraphicsPipelines device cache cis Nothing >>= \case+    (Vk.SUCCESS, pipelines) ->+      case Vector.toList pipelines of+        [one] -> do+          destroyShader context shader+          pure Pipeline+            { pipeline     = one+            , pLayout      = Tagged layout+            , pDescLayouts = Tagged dsLayouts+            }+        _ ->+          error "assert: exactly one pipeline requested"+    (err, _) ->+      error $ "createGraphicsPipelines: " <> show err+  where+    device = getDevice context+    cache = getPipelineCache context++    layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo+      { flags              = zero+      , setLayouts         = dsLayouts+      , pushConstantRanges = cPushConstantRanges+      }++    pipelineCI stages layout = zero+      { Vk.stages             = stages+      , Vk.vertexInputState   = Just cVertexInput+      , Vk.inputAssemblyState = Just inputAsembly+      , Vk.viewportState      = Just $ SomeStruct viewportState+      , Vk.rasterizationState = SomeStruct rasterizationState+      , Vk.multisampleState   = Just $ SomeStruct multisampleState+      , Vk.depthStencilState  = Just depthStencilState+      , Vk.colorBlendState    = Just $ SomeStruct colorBlendState+      , Vk.dynamicState       = dynamicState+      , Vk.layout             = layout+      , Vk.renderPass         = getRenderPass renderpass+      , Vk.subpass            = 0+      , Vk.basePipelineHandle = zero+      }+      where+        inputAsembly = zero+          { Vk.topology               = cTopology+          , Vk.primitiveRestartEnable = restartable+          }++        restartable = elem cTopology+          [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP+          , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP+          , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN+          ]++        (viewportState, dynamicState) = case mextent of+          Nothing ->+            ( zero+                { Vk.viewportCount = 1+                , Vk.scissorCount = 1+                }+            , Just zero+                { Vk.dynamicStates = Vector.fromList+                    [ Vk.DYNAMIC_STATE_VIEWPORT+                    , Vk.DYNAMIC_STATE_SCISSOR+                    ]+                }+            )+          Just extent@Vk.Extent2D{width, height} ->+            ( zero+                { Vk.viewports = Vector.fromList+                    [ Vk.Viewport+                        { Vk.x        = 0+                        , Vk.y        = 0+                        , Vk.width    = realToFrac width+                        , Vk.height   = realToFrac height+                        , Vk.minDepth = 0+                        , Vk.maxDepth = 1+                        }+                    ]+                , Vk.scissors = Vector.singleton Vk.Rect2D+                    { Vk.offset = Vk.Offset2D 0 0+                    , extent    = extent+                    }+                }+            , Nothing+            )++        rasterizationState = case cDepthBias of+          Nothing ->+            rasterizationBase+          Just (constantFactor, slopeFactor) ->+            rasterizationBase+              { Vk.depthBiasEnable         = True+              , Vk.depthBiasConstantFactor = constantFactor+              , Vk.depthBiasSlopeFactor    = slopeFactor+              }++        rasterizationBase = zero+          { Vk.depthClampEnable        = False+          , Vk.rasterizerDiscardEnable = False+          , Vk.lineWidth               = 1+          , Vk.polygonMode             = Vk.POLYGON_MODE_FILL+          , Vk.cullMode                = cCull+          , Vk.frontFace               = Vk.FRONT_FACE_CLOCKWISE+          , Vk.depthBiasEnable         = False+          }++        multisampleState = zero+          { Vk.rasterizationSamples = msaa+          , Vk.sampleShadingEnable  = enable+          , Vk.minSampleShading     = if enable then 0.2 else 1.0+          , Vk.sampleMask           = Vector.singleton maxBound+          }+          where+            enable = True -- TODO: check and enable sample rate shading feature++        depthStencilState = zero+          { Vk.depthTestEnable       = cDepthTest+          , Vk.depthWriteEnable      = cDepthWrite+          , Vk.depthCompareOp        = Vk.COMPARE_OP_LESS+          , Vk.depthBoundsTestEnable = False+          , Vk.minDepthBounds        = 0.0 -- Optional+          , Vk.maxDepthBounds        = 1.0 -- Optional+          , Vk.stencilTestEnable     = False+          , Vk.front                 = zero -- Optional+          , Vk.back                  = zero -- Optional+          }++        colorBlendState = zero+          { Vk.logicOpEnable =+              False+          , Vk.attachments = Vector.singleton zero+              { Vk.blendEnable         = cBlend+              , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE+              , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA+              , Vk.colorBlendOp        = Vk.BLEND_OP_ADD+              , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE+              , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA+              , Vk.alphaBlendOp        = Vk.BLEND_OP_ADD+              , Vk.colorWriteMask      = colorRgba+              }+          }++        colorRgba =+          Vk.COLOR_COMPONENT_R_BIT .|.+          Vk.COLOR_COMPONENT_G_BIT .|.+          Vk.COLOR_COMPONENT_B_BIT .|.+          Vk.COLOR_COMPONENT_A_BIT++destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Pipeline dsl vertices instances -> io ()+destroy context Pipeline{..} = do+  Vector.forM_ (unTagged pDescLayouts) \dsLayout ->+    Vk.destroyDescriptorSetLayout device dsLayout Nothing+  Vk.destroyPipeline device pipeline Nothing+  Vk.destroyPipelineLayout device (unTagged pLayout) Nothing+  where+    device = getDevice context++bind+  :: ( Compatible pipeLayout boundLayout+     , MonadIO m+     )+  => Vk.CommandBuffer+  -> Pipeline pipeLayout vertices instances+  -> Bound boundLayout vertices instances m ()+  -> Bound boundLayout oldVertices oldInstances m ()+bind cb Pipeline{pipeline} (Bound attrAction) = do+  Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline+  Bound attrAction++vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo+vertexInput bindings = SomeStruct zero+  { Vk.vertexBindingDescriptions   = binds+  , Vk.vertexAttributeDescriptions = attrs+  }+  where+    binds = Vector.fromList do+      (ix, (rate, formats)) <- zip [0..] bindings+      pure Vk.VertexInputBindingDescription+        { binding   = ix+        , stride    = sum $ map formatSize formats+        , inputRate = rate+        }++    attrs = attrBindings $ map snd bindings++-- * Shader code++data Shader = Shader+  { sModules        :: Vector Vk.ShaderModule+  , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)+  }++createShader+  :: (MonadIO io, HasVulkan ctx)+  => ctx+  -> Vector (Vk.ShaderStageFlagBits, ByteString)+  -> io Shader+createShader context stages = do+  staged <- Vector.forM stages \(stage, code) -> do+    module_ <- Vk.createShaderModule+      (getDevice context)+      zero+        { Vk.code = code+        }+      Nothing+    pure+      ( module_+      , SomeStruct zero+          { Vk.stage   = stage+          , Vk.module' = module_+          , Vk.name    = "main"+          -- , Vk.specializationInfo = Nothing+          }+      )+  let (modules, pStages) = Vector.unzip staged+  pure Shader+    { sModules        = modules+    , sPipelineStages = pStages+    }++destroyShader :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()+destroyShader context Shader{sModules} =+  Vector.forM_ sModules \module_ ->+    Vk.destroyShaderModule (getDevice context) module_ Nothing++-- * Utils++attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription+attrBindings bindings = mconcat $ List.unfoldr shiftLocations (0, 0, bindings)+  where+    shiftLocations = \case+      (_binding, _lastLoc, [])           -> Nothing+      (binding, lastLoc, formats : rest) -> Just (bound, next)+        where+          bound = Vector.fromList do+            (ix, format) <- zip [0..] formats+            let offset = sum . map formatSize $ take ix formats+            pure zero+              { Vk.binding  = binding+              , Vk.location = fromIntegral $ lastLoc + ix+              , Vk.format   = format+              , Vk.offset   = offset+              }++          next =+            ( binding + 1+            , lastLoc + Vector.length bound+            , rest+            )++formatSize :: Integral a => Vk.Format -> a+formatSize = \case+  Vk.FORMAT_R32G32B32A32_SFLOAT -> 16+  Vk.FORMAT_R32G32B32_SFLOAT    -> 12+  Vk.FORMAT_R32G32_SFLOAT       -> 8+  Vk.FORMAT_R32_SFLOAT          -> 4++  Vk.FORMAT_R32G32B32A32_UINT -> 16+  Vk.FORMAT_R32G32B32_UINT    -> 12+  Vk.FORMAT_R32G32_UINT       -> 8+  Vk.FORMAT_R32_UINT          -> 4++  Vk.FORMAT_R32G32B32A32_SINT -> 16+  Vk.FORMAT_R32G32B32_SINT    -> 12+  Vk.FORMAT_R32G32_SINT       -> 8+  Vk.FORMAT_R32_SINT          -> 4++  format ->+    error $ "Format size unknown: " <> show format
+ src/Engine/Vulkan/Swapchain.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE OverloadedLists #-}++module Engine.Vulkan.Swapchain+  ( SwapchainResources(..)+  , SwapchainInfo(..)+  , allocSwapchainResources+  , recreateSwapchainResources+  , createSwapchain+  , threwSwapchainError++  , HasSwapchain(..)++  , setDynamic+  , setDynamicFullscreen+  ) where++import RIO++import Data.Bits (zeroBits, (.&.), (.|.))+import RIO.Vector qualified as V+import UnliftIO.Resource (MonadResource, allocate, release)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Exception (VulkanException(..))+import Vulkan.Extensions.VK_KHR_surface qualified as Khr+import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr+import Vulkan.Utils.Misc ((.&&.))+import Vulkan.NamedType ((:::))+import Vulkan.Zero (zero)++import Engine.Camera qualified as Camera+import Engine.Types.RefCounted (RefCounted, newRefCounted, releaseRefCounted)+import Engine.Vulkan.Types (MonadVulkan, HasVulkan(..), HasSwapchain(..), pdiProperties)+import Engine.Worker qualified as Worker++data SwapchainResources = SwapchainResources+  { srInfo       :: SwapchainInfo+  , srImageViews :: Vector Vk.ImageView+  , srImages     :: Vector Vk.Image+  , srRelease    :: RefCounted+  , srProjection :: Camera.ProjectionProcess+  }++data SwapchainInfo = SwapchainInfo+  { siSwapchain           :: Khr.SwapchainKHR+  , siSwapchainReleaseKey :: Resource.ReleaseKey+  , siPresentMode         :: Khr.PresentModeKHR+  , siMinImageCount       :: Word32+  , siSurfaceFormat       :: Vk.Format+  , siSurfaceColorspace   :: Khr.ColorSpaceKHR+  , siDepthFormat         :: Vk.Format+  , siMultisample         :: Vk.SampleCountFlagBits+  , siAnisotropy          :: Float+  , siImageExtent         :: Vk.Extent2D+  , siSurface             :: Khr.SurfaceKHR+  }++instance HasSwapchain SwapchainResources where+  getSurfaceExtent  = siImageExtent . srInfo+  getSurfaceFormat  = siSurfaceFormat . srInfo+  getDepthFormat    = siDepthFormat . srInfo+  getMultisample    = siMultisample . srInfo+  getAnisotropy     = siAnisotropy . srInfo+  getSwapchainViews = srImageViews+  getMinImageCount  = siMinImageCount . srInfo+  getImageCount     = fromIntegral . V.length . srImages++-- | Allocate everything which depends on the swapchain+allocSwapchainResources+  :: ( MonadResource (RIO env)+     , HasVulkan env+     , HasLogFunc env+     )+  => Khr.SwapchainKHR+  -- ^ Previous swapchain, can be NULL_HANDLE+  -> Vk.Extent2D+  -- ^ If the swapchain size determines the surface size, use this size+  -> Khr.SurfaceKHR+  -> Camera.ProjectionProcess+  -> RIO env SwapchainResources+  -- -> ResourceT (RIO env) SwapchainResources+allocSwapchainResources oldSwapchain windowSize surface projectionP = do+  logDebug "Allocating swapchain resources"++  device <- asks getDevice+  info@SwapchainInfo{..} <- createSwapchain oldSwapchain windowSize surface++  -- XXX: Get all the swapchain images, and create views for them+  (_, swapchainImages) <- Khr.getSwapchainImagesKHR device siSwapchain+  res <- for swapchainImages $+    createImageView siSurfaceFormat+  let (imageViewKeys, imageViews) = V.unzip res++  -- XXX: This refcount is released in 'recreateSwapchainResources'+  releaseDebug <- toIO $ logDebug "Releasing swapchain resources"+  releaseResources <- newRefCounted $ do+    releaseDebug+    traverse_ release imageViewKeys+    release siSwapchainReleaseKey++  Worker.pushInput projectionP \input -> input+    { Camera.projectionScreen = windowSize+    }++  pure SwapchainResources+    { srInfo       = info+    , srImageViews = imageViews+    , srImages     = swapchainImages+    , srRelease    = releaseResources+    , srProjection = projectionP+    }++recreateSwapchainResources+  :: ( MonadResource (RIO env)+     , HasVulkan env+     , HasLogFunc env+     )+  => Vk.Extent2D+  -> SwapchainResources+  -- ^ The reference to these resources will be dropped+  -> RIO env SwapchainResources+recreateSwapchainResources windowSize oldResources = do+  sr <- allocSwapchainResources+      (siSwapchain $ srInfo oldResources)+      windowSize+      (siSurface $ srInfo oldResources)+      (srProjection oldResources)+  releaseRefCounted (srRelease oldResources)+  pure sr++-- | Create a swapchain from a 'SurfaceKHR'+createSwapchain+  :: ( MonadResource m+     , MonadVulkan env m+     , HasLogFunc env+     )+  => Khr.SwapchainKHR+  -- ^ Old swapchain, can be NULL_HANDLE+  -> Vk.Extent2D+  -- ^ If the swapchain size determines the surface size, use this size+  -> Khr.SurfaceKHR+  -> m SwapchainInfo+createSwapchain oldSwapchain explicitSize surf = do+  physical <- asks getPhysicalDevice+  device <- asks getDevice+  props <- asks $ pdiProperties . getPhysicalDeviceInfo+  surfaceCaps <- Khr.getPhysicalDeviceSurfaceCapabilitiesKHR physical surf++  logDebug $ displayShow surfaceCaps++  -- Check flags+  for_ requiredUsageFlags \flag ->+    unless (Khr.supportedUsageFlags surfaceCaps .&&. flag) do+      logError $ "Surface images do not support " <> displayShow flag+      throwString $ "Surface images do not support " <> show flag++  -- Select a present mode+  (_, availablePresentModes) <- Khr.getPhysicalDeviceSurfacePresentModesKHR physical surf+  presentMode                <-+    case filter (`V.elem` availablePresentModes) desiredPresentModes of+      [] -> do+        logError "Unable to find a suitable present mode for swapchain"+        throwString "Unable to find a suitable present mode for swapchain"+      x : _rest ->+        pure x++  -- Select a surface format+  -- getPhysicalDeviceSurfaceFormatsKHR doesn't return an empty list+  -- (_, availableFormats) <- Khr.getPhysicalDeviceSurfaceFormatsKHR physical surf+  surfaceFormatKhr <- getSurfaceFormatKhr physical surf preferSrgb++  depthFormat <- getDepthFormats physical preferStenciledDepth >>= \case+    fmt : _rest ->+      pure fmt+    _none ->+      throwString "Unable to find a suitable depth format"++  -- Calculate the extent+  let+    imageExtent =+      case Khr.currentExtent (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of+        Vk.Extent2D w h | w == maxBound, h == maxBound ->+          explicitSize+        extent ->+          extent++  let+    minImageCount =+      let+        limit = case Khr.maxImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of+          0 -> maxBound+          n -> n+        -- Request one additional image to prevent us having to wait for+        -- the driver to finish+        buffer = 1+        desired =+          buffer + Khr.minImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR)+      in+        min limit desired++  let compositeAlphaMode = Khr.COMPOSITE_ALPHA_OPAQUE_BIT_KHR+  unless (compositeAlphaMode .&&. Khr.supportedCompositeAlpha surfaceCaps) $+    throwString $ "Surface doesn't support " <> show compositeAlphaMode++  let+    Khr.SurfaceFormatKHR{colorSpace=surfaceColorspace, format=surfaceFormat} = surfaceFormatKhr+    swapchainCreateInfo = Khr.SwapchainCreateInfoKHR+      { surface            = surf+      , next               = ()+      , flags              = zero+      , queueFamilyIndices = mempty -- No need to specify when not using concurrent access+      , minImageCount      = minImageCount+      , imageFormat        = surfaceFormat+      , imageColorSpace    = surfaceColorspace+      , imageExtent        = imageExtent+      , imageArrayLayers   = 1+      , imageUsage         = foldr (.|.) zero requiredUsageFlags+      , imageSharingMode   = Vk.SHARING_MODE_EXCLUSIVE+      , preTransform       = Khr.currentTransform (surfaceCaps :: Khr.SurfaceCapabilitiesKHR)+      , compositeAlpha     = compositeAlphaMode+      , presentMode        = presentMode+      , clipped            = True+      , oldSwapchain       = oldSwapchain+      }++  logDebug $ "Creating swapchain from " <> displayShow swapchainCreateInfo+  (key, swapchain) <- Khr.withSwapchainKHR device swapchainCreateInfo Nothing allocate++  pure SwapchainInfo+    { siSwapchain           = swapchain+    , siSwapchainReleaseKey = key+    , siPresentMode         = presentMode+    , siMinImageCount       = minImageCount+    , siSurface             = surf+    , siSurfaceFormat       = surfaceFormat+    , siSurfaceColorspace   = surfaceColorspace+    , siDepthFormat         = depthFormat+    , siMultisample         = msaaSamples props+    , siAnisotropy          = Vk.maxSamplerAnisotropy (Vk.limits props)+    , siImageExtent         = imageExtent+    }++-- -- The vector passed will have at least one element+-- selectSurfaceFormat :: Vector Khr.SurfaceFormatKHR -> Khr.SurfaceFormatKHR+-- selectSurfaceFormat = V.maximumBy (comparing surfaceFormatScore)+--   where+--     -- An ordered list of formats to choose for the swapchain images, if none+--     -- match then the first available format will be chosen.+--     surfaceFormatScore :: Khr.SurfaceFormatKHR -> Int+--     surfaceFormatScore = \case+--       _ -> 0++getSurfaceFormatKhr+  :: MonadIO io+  => Vk.PhysicalDevice+  -> Khr.SurfaceKHR+  -> Khr.SurfaceFormatKHR+  -> io Khr.SurfaceFormatKHR+getSurfaceFormatKhr device surface desiredFormat = do+  (_res, formats) <- Khr.getPhysicalDeviceSurfaceFormatsKHR device surface+  pure case toList formats of+    [] ->+      desiredFormat+    [Khr.SurfaceFormatKHR Vk.FORMAT_UNDEFINED _colorSpace] ->+      desiredFormat+    candidates | any cond candidates ->+      desiredFormat+    whatever : _rest ->+      whatever+  where+    cond f =+      Khr.format f == Khr.format desiredFormat &&+      Khr.colorSpace f == Khr.colorSpace desiredFormat++preferSrgb :: Khr.SurfaceFormatKHR+preferSrgb =+  Khr.SurfaceFormatKHR+    Vk.FORMAT_B8G8R8A8_SRGB+    Khr.COLOR_SPACE_SRGB_NONLINEAR_KHR++getDepthFormats+  :: MonadIO io+  => Vk.PhysicalDevice+  -> [Vk.Format]+  -> io [Vk.Format]+getDepthFormats device desiredDepthFormats = do+  properties <- traverse (Vk.getPhysicalDeviceFormatProperties device) desiredDepthFormats+  pure do+    (format, props) <- zip desiredDepthFormats properties+    guard $+      Vk.optimalTilingFeatures props .&&. Vk.FORMAT_FEATURE_DEPTH_STENCIL_ATTACHMENT_BIT+    pure format++preferStenciledDepth :: [Vk.Format]+preferStenciledDepth =+  [ Vk.FORMAT_D32_SFLOAT_S8_UINT+  , Vk.FORMAT_D24_UNORM_S8_UINT+  , Vk.FORMAT_D32_SFLOAT+  ]++msaaSamples :: Vk.PhysicalDeviceProperties -> Vk.SampleCountFlagBits+msaaSamples Vk.PhysicalDeviceProperties{limits} =+  case samplesAvailable of+    [] ->+      Vk.SAMPLE_COUNT_1_BIT+    best : _rest ->+      best+  where+    counts =+      Vk.framebufferColorSampleCounts limits .&.+      Vk.framebufferDepthSampleCounts limits++    samplesAvailable = do+      countBit <- msaaCandidates+      guard $ (counts .&. countBit) /= zeroBits+      pure countBit++msaaCandidates :: [Vk.SampleCountFlagBits]+msaaCandidates =+  {-+    XXX: Also possible, but not that impactful: 16x, 8x.++    Khronos MSAA best practice says:+      Use 4x MSAA if possible; it's not expensive and provides good image quality improvements.+  -}+  [ Vk.SAMPLE_COUNT_4_BIT+  , Vk.SAMPLE_COUNT_2_BIT+  ]++-- | An ordered list of the present mode to be chosen for the swapchain.+desiredPresentModes :: [Khr.PresentModeKHR]+desiredPresentModes =+  [ Khr.PRESENT_MODE_FIFO_RELAXED_KHR+  , Khr.PRESENT_MODE_FIFO_KHR --  ^ This will always be present+  , Khr.PRESENT_MODE_IMMEDIATE_KHR --  ^ Keep this here for easy swapping for testing+  ]++-- | The images in the swapchain must support these flags.+requiredUsageFlags :: [Vk.ImageUsageFlagBits]+requiredUsageFlags =+  [ Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT+  -- , Vk.IMAGE_USAGE_STORAGE_BIT+  ]++-- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened+threwSwapchainError :: MonadUnliftIO f => f () -> f Bool+threwSwapchainError = fmap isLeft . tryJust swapchainError+ where+  swapchainError = \case+    VulkanException e@Vk.ERROR_OUT_OF_DATE_KHR ->+      Just e++    VulkanException Vk.ERROR_SURFACE_LOST_KHR ->+      error "TODO: handle ERROR_SURFACE_LOST_KHR"++    VulkanException _ ->+      Nothing++-- | Create a pretty vanilla ImageView covering the whole image+createImageView+  :: ( MonadResource m+     , MonadVulkan env m+     )+  => Vk.Format+  -> Vk.Image+  -> m (Resource.ReleaseKey, Vk.ImageView)+createImageView format image = do+  device <- asks getDevice+  Vk.withImageView device imageViewCI Nothing allocate+ where+  imageViewCI = zero+    { Vk.image = image+    , Vk.viewType         = Vk.IMAGE_VIEW_TYPE_2D+    , Vk.format           = format+    -- , Vk.components       = zero+    , Vk.subresourceRange = zero+        { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT+        , Vk.baseMipLevel   = 0+        , Vk.levelCount     = 1+        , Vk.baseArrayLayer = 0+        , Vk.layerCount     = 1+        }+    }++setDynamic+  :: MonadIO io+  => Vk.CommandBuffer+  -> "viewport" ::: Vk.Rect2D+  -> "scissor"  ::: Vk.Rect2D+  -> io ()+setDynamic cb viewrect scissor = do+  Vk.cmdSetViewport cb 0 [viewport]+  Vk.cmdSetScissor cb 0 [scissor]+  where+    viewport = Vk.Viewport+      { x        = realToFrac x+      , y        = realToFrac y+      , width    = realToFrac width+      , height   = realToFrac height+      , minDepth = 0+      , maxDepth = 1+      }+      where+        Vk.Offset2D{x, y} = offset+        Vk.Extent2D{width, height} = extent+        Vk.Rect2D{offset, extent} = viewrect++setDynamicFullscreen :: MonadIO io => Vk.CommandBuffer -> SwapchainResources -> io ()+setDynamicFullscreen cb sr = do+  Vk.cmdSetViewport cb+    0+    [ Vk.Viewport+        { x        = 0+        , y        = 0+        , width    = realToFrac width+        , height   = realToFrac height+        , minDepth = 0+        , maxDepth = 1+        }+    ]+  Vk.cmdSetScissor cb 0+    [ Vk.Rect2D+        { offset = Vk.Offset2D 0 0+        , extent = siImageExtent+        }+    ]+  where+    SwapchainResources{srInfo} = sr+    SwapchainInfo{siImageExtent} = srInfo+    Vk.Extent2D{width, height} = siImageExtent
+ src/Engine/Vulkan/Types.hs view
@@ -0,0 +1,140 @@+module Engine.Vulkan.Types+  ( MonadVulkan+  , HasVulkan(..)+  , getPipelineCache++  , HasSwapchain(..)+  , HasRenderPass(..)+  , RenderPass(..)++  , PhysicalDeviceInfo(..)+  , Queues(..)++  , DsLayouts+  , DsBindings++  , Bound(..)+  ) where++import RIO++import Data.Kind (Type)+import RIO.App (App(..))+import UnliftIO.Resource (MonadResource, ResourceT)+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12+import Vulkan.NamedType ((:::))+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import VulkanMemoryAllocator qualified as VMA++type MonadVulkan env m =+  ( MonadUnliftIO m+  , MonadReader env m+  , HasVulkan env+  )++-- | A class for Monads which can provide some Vulkan handles+class HasVulkan a where+  getInstance           :: a -> Vk.Instance+  getQueues             :: a -> Queues (QueueFamilyIndex, Vk.Queue)+  getPhysicalDevice     :: a -> Vk.PhysicalDevice+  getPhysicalDeviceInfo :: a -> PhysicalDeviceInfo+  getDevice             :: a -> Vk.Device+  getAllocator          :: a -> VMA.Allocator++instance HasVulkan env => HasVulkan (App env st) where+  getInstance           = getInstance . appEnv+  getQueues             = getQueues . appEnv+  getPhysicalDevice     = getPhysicalDevice . appEnv+  getPhysicalDeviceInfo = getPhysicalDeviceInfo . appEnv+  getDevice             = getDevice . appEnv+  getAllocator          = getAllocator . appEnv++instance (HasVulkan env) => HasVulkan (env, a) where+  getInstance           = getInstance . fst+  getQueues             = getQueues . fst+  getPhysicalDevice     = getPhysicalDevice . fst+  getPhysicalDeviceInfo = getPhysicalDeviceInfo . fst+  getDevice             = getDevice . fst+  getAllocator          = getAllocator . fst++instance (HasSwapchain context) => HasSwapchain (a, context) where+  getSurfaceExtent  = getSurfaceExtent . snd+  getSurfaceFormat  = getSurfaceFormat . snd+  getDepthFormat    = getDepthFormat . snd+  getMultisample    = getMultisample . snd+  getAnisotropy     = getAnisotropy . snd+  getSwapchainViews = getSwapchainViews . snd+  getMinImageCount  = getMinImageCount . snd+  getImageCount     = getImageCount . snd++-- TODO+getPipelineCache :: {- HasVulkan ctx => -} ctx -> Vk.PipelineCache+getPipelineCache _ctx = Vk.NULL_HANDLE++{- |+  The shape of all the queues we use for our program, parameterized over the+  queue type so we can use it with 'Vulkan.Utils.QueueAssignment.assignQueues'.+-}+data Queues q = Queues+  { qGraphics :: q+  , qTransfer :: q+  , qCompute  :: q+  }+  deriving (Show, Functor, Foldable, Traversable)++data PhysicalDeviceInfo = PhysicalDeviceInfo+  { pdiTotalMemory      :: Word64+  , pdiQueueCreateInfos :: Vector (Vk.DeviceQueueCreateInfo '[])+  , pdiName             :: Text+  , pdiProperties       :: Vk.PhysicalDeviceProperties+  , pdiGetQueues        :: Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue))+  }++class HasSwapchain a where+  getSurfaceExtent  :: a -> Vk.Extent2D+  getSurfaceFormat  :: a -> Vk.Format+  getDepthFormat    :: a -> Vk.Format+  getMultisample    :: a -> Vk.SampleCountFlagBits+  getAnisotropy     :: a -> "max sampler anisotropy" ::: Float+  getSwapchainViews :: a -> Vector Vk.ImageView+  getMinImageCount  :: a -> Word32+  getImageCount     :: a -> Word32++-- TODO: extract to a module+class HasRenderPass a where+  getFramebuffers        :: a -> Vector Vk.Framebuffer+  getRenderPass          :: a -> Vk.RenderPass+  getClearValues         :: a -> Vector Vk.ClearValue+  getRenderArea          :: a -> Vk.Rect2D++class RenderPass a where+  allocateRenderpass_+    :: ( HasLogFunc env+       , HasSwapchain context+       , HasVulkan env+       , MonadResource (RIO env)+       )+    => context+    -> ResourceT (RIO env) a++  updateRenderpass+    :: ( HasLogFunc env+       , HasSwapchain context+       , HasVulkan env+       , MonadResource (RIO env)+       )+    => context+    -> a+    -> RIO env a++  refcountRenderpass+    :: MonadResource (RIO env)+    => a+    -> RIO env ()++type DsBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)]+type DsLayouts = Vector Vk.DescriptorSetLayout++newtype Bound (dsl :: [Type]) vertices instances m a = Bound (m a)+  deriving (Foldable, Traversable, Functor, Applicative, Monad, MonadIO, MonadUnliftIO)
+ src/Engine/Window/CursorPos.hs view
@@ -0,0 +1,34 @@+module Engine.Window.CursorPos+  ( Callback+  , callback++  , GLFW.MouseButton(..)+  , GLFW.MouseButtonState(..)+  , GLFW.ModifierKeys(..)++  , mkCallback+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (appEnv)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (GlobalHandles(..), StageRIO)++type Callback st = Double -> Double -> StageRIO st ()++callback :: Callback st -> StageRIO st ReleaseKey+callback handler = do+  window <- asks $ ghWindow . appEnv+  withUnliftIO \ul ->+    GLFW.setCursorPosCallback window . Just $ mkCallback ul handler+  Resource.register $+    GLFW.setCursorPosCallback window Nothing++mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.CursorPosCallback+mkCallback (UnliftIO ul) action =+  \_window px py ->+    ul $ action px py
+ src/Engine/Window/Drop.hs view
@@ -0,0 +1,30 @@+module Engine.Window.Drop+  ( Callback+  , callback++  , mkCallback+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (appEnv)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (GlobalHandles(..), StageRIO)++type Callback st = [FilePath] -> StageRIO st ()++callback :: Callback st -> StageRIO st ReleaseKey+callback handler = do+  window <- asks $ ghWindow . appEnv+  withUnliftIO \ul ->+    GLFW.setDropCallback window . Just $ mkCallback ul handler+  Resource.register $+    GLFW.setDropCallback window Nothing++mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.DropCallback+mkCallback (UnliftIO ul) action =+  \_window files ->+    ul $ action files
+ src/Engine/Window/Key.hs view
@@ -0,0 +1,34 @@+module Engine.Window.Key+  ( Callback+  , callback++  , GLFW.Key(..)+  , GLFW.KeyState(..)+  , GLFW.ModifierKeys(..)++  , mkCallback+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (appEnv)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (GlobalHandles(..), StageRIO)++type Callback st = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> StageRIO st ()++callback :: Callback st -> StageRIO st ReleaseKey+callback handler = do+  window <- asks $ ghWindow . appEnv+  withUnliftIO \ul ->+    GLFW.setKeyCallback window . Just $ mkCallback ul handler+  Resource.register $+    GLFW.setKeyCallback window Nothing++mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.KeyCallback+mkCallback (UnliftIO ul) action =+  \_window key keyCode keyState mods ->+    ul $ action keyCode (mods, keyState, key)
+ src/Engine/Window/MouseButton.hs view
@@ -0,0 +1,34 @@+module Engine.Window.MouseButton+  ( Callback+  , callback++  , GLFW.MouseButton(..)+  , GLFW.MouseButtonState(..)+  , GLFW.ModifierKeys(..)++  , mkCallback+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (appEnv)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (GlobalHandles(..), StageRIO)++type Callback st = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> StageRIO st ()++callback :: Callback st -> StageRIO st ReleaseKey+callback handler = do+  window <- asks $ ghWindow . appEnv+  withUnliftIO \ul ->+    GLFW.setMouseButtonCallback window . Just $ mkCallback ul handler+  Resource.register $+    GLFW.setMouseButtonCallback window Nothing++mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.MouseButtonCallback+mkCallback (UnliftIO ul) action =+  \_window button buttonState mods ->+    ul $ action (mods, buttonState, button)
+ src/Engine/Window/Scroll.hs view
@@ -0,0 +1,30 @@+module Engine.Window.Scroll+  ( Callback+  , callback++  , mkCallback+  ) where++import RIO++import Graphics.UI.GLFW qualified as GLFW+import RIO.App (appEnv)+import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource qualified as Resource++import Engine.Types (GlobalHandles(..), StageRIO)++type Callback st = Double -> Double -> StageRIO st ()++callback :: Callback st -> StageRIO st ReleaseKey+callback handler = do+  window <- asks $ ghWindow . appEnv+  withUnliftIO \ul ->+    GLFW.setScrollCallback window . Just $ mkCallback ul handler+  Resource.register $+    GLFW.setScrollCallback window Nothing++mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.ScrollCallback+mkCallback (UnliftIO ul) action =+  \_window dx dy ->+    ul $ action dx dy
+ src/Engine/Worker.hs view
@@ -0,0 +1,672 @@+module Engine.Worker+  ( Versioned(..)+  , Var+  , newVar+  , readVar+  , stateVar+  , stateVarMap++  , HasInput(..)+  , pushInput+  , pushInputSTM+  , updateInput+  , updateInputSTM+  , getInputData+  , getInputDataSTM++  , HasConfig(..)+  , modifyConfig+  , modifyConfigSTM++  , HasOutput(..)+  , updateOutput+  , updateOutputSTM+  , getOutputData+  , getOutputDataSTM++  , Cell(..)+  , spawnCell++  , Timed(..)+  , spawnTimed+  , spawnTimed_++  , Merge(..)+  , spawnMerge1+  , spawnMerge2+  , spawnMerge3+  , spawnMerge4++  , ObserverIO+  , newObserverIO+  , observeIO+  , observeIO_+  , readObservedIO++  , Source+  , newSource+  , pubSource+  , subSource++  , HasWorker(..)+  , register+  , registerCollection+  , registered+  , registeredCollection+  ) where++import RIO++import Control.Concurrent.Chan.Unagi.Unboxed (UnagiPrim)+import Control.Concurrent.Chan.Unagi.Unboxed qualified as UnagiPrim+import Data.Vector.Unboxed qualified as Unboxed+import UnliftIO.Concurrent (forkIO, killThread)+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Data.StateVar qualified as StateVar++data Versioned a = Versioned+  { vVersion :: Unboxed.Vector Word64+  , vData    :: a+  }+  deriving (Show, Functor, Foldable, Traversable)++instance Eq (Versioned a) where+  a == b = vVersion a == vVersion b++instance Ord (Versioned a) where+  compare a b = compare (vVersion a) (vVersion b)++type Var a = TVar (Versioned a)++newVar :: MonadUnliftIO m => a -> m (Var a)+newVar initial = newTVarIO Versioned+  { vVersion = Unboxed.singleton 0+  , vData    = initial+  }++stateVar :: HasInput var => var -> StateVar.StateVar (GetInput var)+stateVar var = StateVar.makeStateVar+  (getInputData var)+  (\new -> pushInput var \_old -> new)++stateVarMap+  :: HasInput var+  => (GetInput var -> a)+  -> (a -> GetInput var -> GetInput var)+  -> var+  -> StateVar.StateVar a+stateVarMap mapGet mapSet var = StateVar.makeStateVar+  (fmap mapGet $ getInputData var)+  (\new -> pushInput var (mapSet new))++{-# INLINEABLE readVar #-}+readVar :: (MonadUnliftIO m) => Var a -> m a+readVar = fmap vData . readTVarIO++{-# INLINEABLE pushVarSTM #-}+pushVarSTM :: Var a -> (a -> a) -> STM ()+pushVarSTM var f =+  modifyTVar' var \Versioned{vVersion, vData} ->+    Versioned+      { vVersion = Unboxed.map (+ 1) vVersion+      , vData = f vData+      }++{-# INLINEABLE updateVarSTM #-}+updateVarSTM :: Var a -> (a -> Maybe a) -> STM ()+updateVarSTM var f = do+  current <- readTVar var+  let+    oldData = vData current+  case f oldData of+    Nothing ->+      pure ()+    Just newData ->+      writeTVar var Versioned+        { vVersion = Unboxed.map (+1) (vVersion current)+        , vData    = newData+        }++class HasInput a where+  type GetInput a+  getInput :: a -> Var (GetInput a)++instance HasInput (TVar (Versioned a)) where+  type GetInput (TVar (Versioned a)) = a+  getInput = id++{-# INLINEABLE pushInput #-}+pushInput+  :: (MonadIO m, HasInput var)+  => var+  -> (GetInput var -> GetInput var)+  -> m ()+pushInput input =+  atomically . pushInputSTM input++{-# INLINEABLE pushInputSTM #-}+pushInputSTM+  :: HasInput var+  => var+  -> (GetInput var -> GetInput var)+  -> STM ()+pushInputSTM input = pushVarSTM (getInput input)++{-# INLINEABLE updateInput #-}+updateInput+  :: ( MonadIO m+     , HasInput var+     )+  => var+  -> (GetInput var -> Maybe (GetInput var))+  -> m ()+updateInput input =+  atomically . updateInputSTM input++updateInputSTM+  :: HasInput var+  => var+  -> (GetInput var -> Maybe (GetInput var))+  -> STM ()+updateInputSTM input = updateVarSTM (getInput input)++{-# INLINEABLE getInputData #-}+getInputData :: (HasInput worker, MonadIO m) => worker -> m (GetInput worker)+getInputData = fmap vData . readTVarIO . getInput++{-# INLINEABLE getInputDataSTM #-}+getInputDataSTM :: (HasInput worker) => worker -> STM (GetInput worker)+getInputDataSTM = fmap vData . readTVar . getInput++class HasConfig a where+  type GetConfig a+  getConfig :: a -> TVar (GetConfig a)++instance HasConfig (TVar a) where+  type GetConfig (TVar a) = a+  getConfig = id++modifyConfig+  :: (MonadIO m, HasConfig var)+  => var+  -> (GetConfig var -> GetConfig var)+  -> m ()+modifyConfig config =+  atomically . modifyConfigSTM config++modifyConfigSTM+  :: HasConfig var+  => var+  -> (GetConfig var -> GetConfig var)+  -> STM ()+modifyConfigSTM config =+  modifyTVar' (getConfig config)++class HasOutput a where+  type GetOutput a+  getOutput  :: a -> Var (GetOutput a)++instance HasOutput (TVar (Versioned a)) where+  type GetOutput (TVar (Versioned a)) = a+  getOutput = id++{-# INLINEABLE pushOutput #-}+pushOutput+  :: (MonadIO m, HasOutput var)+  => var+  -> (GetOutput var -> GetOutput var)+  -> m ()+pushOutput output =+  atomically . pushOutputSTM output++pushOutputSTM+  :: HasOutput var+  => var+  -> (GetOutput var -> GetOutput var)+  -> STM ()+pushOutputSTM output f =+  modifyTVar' (getOutput output) \Versioned{vVersion, vData} ->+    Versioned+      { vVersion = Unboxed.map (+1) vVersion+      , vData    = f vData+      }++{-# INLINEABLE updateOutput #-}+updateOutput+  :: (MonadIO m, HasOutput var)+  => var+  -> (GetOutput var -> Maybe (GetOutput var))+  -> m ()+updateOutput output =+  atomically . updateOutputSTM output++updateOutputSTM+  :: HasOutput var+  => var+  -> (GetOutput var -> Maybe (GetOutput var))+  -> STM ()+updateOutputSTM output f = do+  current <- readTVar outputVar+  let+    oldData = vData current+  case f oldData of+    Nothing ->+      pure ()+    Just newData ->+      writeTVar outputVar Versioned+        { vVersion = Unboxed.map (+1) (vVersion current)+        , vData    = newData+        }+  where+    outputVar = getOutput output++{-# INLINEABLE getOutputData #-}+getOutputData :: (HasOutput worker, MonadIO m) => worker -> m (GetOutput worker)+getOutputData = fmap vData . readTVarIO . getOutput++{-# INLINEABLE getOutputDataSTM #-}+getOutputDataSTM :: (HasOutput worker) => worker -> STM (GetOutput worker)+getOutputDataSTM = fmap vData . readTVar . getOutput++-- * Suppply++-- | Updatable cell for composite input or costly output.+data Cell input output = Cell+  { cWorker :: ThreadId+  , cInput  :: Var input+  , cOutput :: Var output+  }++instance HasInput (Cell i o) where+  type GetInput (Cell i o) = i+  getInput = cInput++instance HasOutput (Cell i o) where+  type GetOutput (Cell i o) = o+  getOutput = cOutput++spawnCell+  :: MonadUnliftIO m+  => (input -> output)+  -> input+  -> m (Cell input output)+spawnCell f initial = do+  input <- newVar initial++  output <- newVar (f initial)++  worker <- forkIO $+    forever $ atomically do+      next <- readTVar input+      old <- readTVar output++      if Unboxed.head (vVersion next) > Unboxed.head (vVersion old) then+        writeTVar output Versioned+          { vVersion = vVersion next+          , vData    = f (vData next)+          }+      else+        retrySTM++  pure Cell+    { cWorker = worker+    , cInput  = input+    , cOutput = output+    }++-- | Timer-driven stateful producer.+data Timed config output = Timed+  { tWorker :: ThreadId+  , tActive :: TVar Bool+  , tConfig :: TVar config+  , tOutput :: Var output+  }++instance HasConfig (Timed config output) where+  type GetConfig (Timed config output) = config+  getConfig = tConfig++instance HasOutput (Timed config output) where+  type GetOutput (Timed config output) = output+  getOutput = tOutput++spawnTimed_+  :: MonadUnliftIO m+  => Int+  -> Bool+  -> m output+  -> m (Timed () output)+spawnTimed_ dt startActive stepF =+  spawnTimed+    (\_old () -> fmap (,()) stepF)+    (Left dt)+    startActive+    (error "assert: spawnTimed_ ignores old")+    ()++spawnTimed+  :: MonadUnliftIO m+  => (state -> config -> m (output, state))+  -> Either Int (config -> Int)+  -> Bool+  -> state+  -> config+  -> m (Timed config output)+spawnTimed stepF dtF startActive initialState initialConfig = do+  tActive <- newTVarIO startActive+  tConfig <- newTVarIO initialConfig+  (initialOutput, nextState) <- stepF initialState initialConfig+  tOutput <- newVar initialOutput+  tWorker <- forkIO $ step tActive tConfig tOutput nextState+  pure Timed{..}+  where+    step activeVar configVar output curState = do+      case dtF of+        Left static ->+          threadDelay static+        Right fromConfig ->+          readTVarIO configVar >>=+            threadDelay . fromConfig++      active <- readTVarIO activeVar+      if active then do+        config <- readTVarIO configVar+        (nextOutput, nextState) <- stepF curState config+        pushOutput output $ const nextOutput+        step activeVar configVar output nextState+      else+        step activeVar configVar output curState++-- | Supply-driven step cell.+data Merge o = Merge+  { mWorker   :: ThreadId+  , mOutput   :: TVar (Versioned o)+  }++instance HasOutput (Merge o) where+  type GetOutput (Merge o) = o+  getOutput = mOutput++spawnMerge1+  :: ( MonadUnliftIO m+     , HasOutput i+     )+  => (GetOutput i -> o)+  -> i+  -> m (Merge o)+spawnMerge1 f i = do+  output <- atomically do+    initial <- readTVar (getOutput i)+    newTVar Versioned+      { vVersion = vVersion initial+      , vData    = f (vData initial)+      }++  worker <- forkIO $+    forever $ atomically do+      next <- readTVar (getOutput i)+      old <- readTVar output++      let nextVersion = vVersion next+      if nextVersion > vVersion old then+        writeTVar output Versioned+          { vVersion = nextVersion+          , vData    = f (vData next)+          }+      else+        retrySTM++  pure Merge+    { mWorker = worker+    , mOutput = output+    }++spawnMerge2+  :: ( MonadUnliftIO m+     , HasOutput i1+     , HasOutput i2+     )+  => (GetOutput i1 -> GetOutput i2 -> o)+  -> i1+  -> i2+  -> m (Merge o)+spawnMerge2 f i1 i2 = do+  output <- atomically do+    (initial1, initial2) <- (,)+      <$> readTVar (getOutput i1)+      <*> readTVar (getOutput i2)++    newTVar Versioned+      { vVersion = mkVersion initial1 initial2+      , vData    = f (vData initial1) (vData initial2)+      }++  worker <- forkIO $+    forever $ atomically $ do+      next1 <- readTVar (getOutput i1)+      next2 <- readTVar (getOutput i2)+      old <- readTVar output++      let nextVersion = mkVersion next1 next2++      if nextVersion > vVersion old then+        writeTVar output Versioned+          { vVersion = nextVersion+          , vData    = f (vData next1) (vData next2)+          }+      else+        retrySTM++  pure Merge+    { mWorker = worker+    , mOutput = output+    }+  where+    mkVersion a b = vVersion a <> vVersion b++spawnMerge3+  :: ( MonadUnliftIO m+     , HasOutput i1+     , HasOutput i2+     , HasOutput i3+     )+  => (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> o)+  -> i1+  -> i2+  -> i3+  -> m (Merge o)+spawnMerge3 f i1 i2 i3 = do+  output <- atomically do+    (initial1, initial2, initial3) <- (,,)+      <$> readTVar (getOutput i1)+      <*> readTVar (getOutput i2)+      <*> readTVar (getOutput i3)++    newTVar Versioned+      { vVersion = mkVersion initial1 initial2 initial3+      , vData    = f (vData initial1) (vData initial2) (vData initial3)+      }++  worker <- forkIO $+    forever $ atomically $ do+      next1 <- readTVar (getOutput i1)+      next2 <- readTVar (getOutput i2)+      next3 <- readTVar (getOutput i3)+      old <- readTVar output++      let nextVersion = mkVersion next1 next2 next3++      if nextVersion > vVersion old then+        writeTVar output Versioned+          { vVersion = nextVersion+          , vData    = f (vData next1) (vData next2) (vData next3)+          }+      else+        retrySTM++  pure Merge+    { mWorker = worker+    , mOutput = output+    }+  where+    mkVersion a b c = mconcat [vVersion a, vVersion b, vVersion c]++spawnMerge4+  :: ( MonadUnliftIO m+     , HasOutput i1+     , HasOutput i2+     , HasOutput i3+     , HasOutput i4+     )+  => (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> GetOutput i4 -> o)+  -> i1+  -> i2+  -> i3+  -> i4+  -> m (Merge o)+spawnMerge4 f i1 i2 i3 i4 = do+  output <- atomically do+    (initial1, initial2, initial3, initial4) <- (,,,)+      <$> readTVar (getOutput i1)+      <*> readTVar (getOutput i2)+      <*> readTVar (getOutput i3)+      <*> readTVar (getOutput i4)++    newTVar Versioned+      { vVersion = mkVersion initial1 initial2 initial3 initial4+      , vData    = f (vData initial1) (vData initial2) (vData initial3) (vData initial4)+      }++  worker <- forkIO $+    forever $ atomically $ do+      next1 <- readTVar (getOutput i1)+      next2 <- readTVar (getOutput i2)+      next3 <- readTVar (getOutput i3)+      next4 <- readTVar (getOutput i4)+      old <- readTVar output++      let nextVersion = mkVersion next1 next2 next3 next4++      if nextVersion > vVersion old then+        writeTVar output Versioned+          { vVersion = nextVersion+          , vData    = f (vData next1) (vData next2) (vData next3) (vData next4)+          }+      else+        retrySTM++  pure Merge+    { mWorker = worker+    , mOutput = output+    }+  where+    mkVersion a b c d = mconcat [vVersion a, vVersion b, vVersion c, vVersion d]++-- * Demand++type ObserverIO a = IORef (Versioned a)++newObserverIO :: MonadIO m => a -> m (ObserverIO a)+newObserverIO initial = newIORef Versioned+  { vVersion = mempty+  , vData    = initial+  }++observeIO+  :: (MonadUnliftIO m, HasOutput output)+  => output+  -> ObserverIO a+  -> (a -> GetOutput output -> m a)+  -> m a+observeIO output currentRef action = do+  outputV <- readTVarIO (getOutput output)+  currentV <- readIORef currentRef+  if vVersion outputV > vVersion currentV then do+    derived <- action (vData currentV) (vData outputV)+    atomicWriteIORef currentRef Versioned+      { vVersion = vVersion outputV+      , vData    = derived+      }+    pure derived+  else+    pure (vData currentV)++observeIO_+  :: (MonadUnliftIO m, HasOutput output)+  => output+  -> ObserverIO a+  -> (a -> GetOutput output -> m a)+  -> m ()+observeIO_ output currentRef =+  void . observeIO output currentRef++{-# INLINEABLE readObservedIO #-}+readObservedIO :: (MonadUnliftIO m) => IORef (Versioned a) -> m a+readObservedIO = fmap vData . readIORef++-- * PubSub++newtype Source a = Source (UnagiPrim.InChan a)++newSource :: (MonadUnliftIO m, UnagiPrim a) => m (Source a)+newSource = fmap (Source . fst) $ liftIO UnagiPrim.newChan++pubSource :: (MonadUnliftIO m, UnagiPrim a) => Source a -> a -> m ()+pubSource (Source ic) = liftIO . UnagiPrim.writeChan ic++subSource :: MonadUnliftIO m => Source a -> m (UnagiPrim.OutChan a)+subSource (Source ic) = liftIO $ UnagiPrim.dupChan ic++-- * Utils++class HasWorker a where+  getWorker :: a -> ThreadId++instance HasWorker (Cell i o) where+  getWorker = cWorker++instance HasWorker (Timed c o) where+  getWorker = tWorker++instance HasWorker (Merge o) where+  getWorker = mWorker++register+  :: ( MonadResource m+     , HasWorker process+     )+  => process+  -> m Resource.ReleaseKey+register = Resource.register . killThread . getWorker++registerCollection+  :: ( MonadResource m+     , HasWorker process+     , Foldable t+     )+  => t process+  -> m Resource.ReleaseKey+registerCollection = Resource.register . traverse_ (killThread . getWorker)++registered :: (MonadResource m, HasWorker a) => m a -> m (Resource.ReleaseKey, a)+registered spawn = do+  worker <- spawn+  key <- Resource.register $ killThread (getWorker worker)+  pure (key, worker)++registeredCollection+  :: ( MonadResource m+     , HasWorker process+     , Traversable t+     )+  => (input -> m process)+  -> t input+  -> m (Resource.ReleaseKey, t process)+registeredCollection spawn inputs = do+  workers <- traverse spawn inputs++  key <- Resource.register $+    traverse_ (killThread . getWorker) workers++  pure (key, workers)
+ src/Render/Code.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fno-prof-auto #-}++module Render.Code+  ( compileVert+  , compileFrag+  , glsl+  , trimming+  , Code(..)+  ) where++import RIO++import Language.Haskell.TH (Exp, Q)+import NeatInterpolation (trimming)+import RIO.Text qualified as Text+import Vulkan.Utils.ShaderQQ.GLSL.Glslang (compileShaderQ, glsl)++compileVert :: String -> Q Exp+compileVert = compileShaderQ Nothing "vert" Nothing++compileFrag :: String -> Q Exp+compileFrag = compileShaderQ Nothing "frag" Nothing++-- | A wrapper to `show` code into `compileShaderQ` vars.+newtype Code = Code { unCode :: Text }+  deriving (Eq, Ord)++instance Show Code where+  show = Text.unpack . unCode
+ src/Render/Code/Noise.hs view
@@ -0,0 +1,15 @@+module Render.Code.Noise+  ( hash33+  ) where++import Render.Code (Code(..), trimming)++hash33 :: Code+hash33 = Code+  [trimming|+    vec3 hash33(vec3 a) {+      vec3 p = fract(a * vec3(443.8975, 397.2973, 491.1871));+      p += dot(p.zxy, p.yxz + 19.27);+      return fract(vec3(p.x * p.y, p.z * p.x, p.y * p.z));+    }+  |]
+ src/Render/Draw.hs view
@@ -0,0 +1,231 @@+module Render.Draw+  ( triangle_+  , triangles_+  , quads++  , indexed+  , indexedRanges+  , indexedParts++  , indexedPos+  , indexedPosRanges++  , unsafeIndexedRanges+  , unsafeIndexedParts+  ) where++import RIO++import Data.Vector qualified as Vector+import Vulkan.Core10 qualified as Vk++import Engine.Vulkan.Types (Bound(..))+import Resource.Buffer qualified as Buffer+import Resource.Model qualified as Model++-- * Primitives++-- | Single triangle, binding nothing.+triangle_ :: MonadUnliftIO m => Vk.CommandBuffer -> Bound dsl () () m ()+triangle_ cb = triangles_ cb 1++-- | Multiple shader-driven triangles without bindings.+triangles_ :: MonadUnliftIO m => Vk.CommandBuffer -> Word32 -> Bound dsl () () m ()+triangles_ cb num =+  Bound $ Vk.cmdDraw cb 3 num 0 0++-- | Instanced quads.+quads+  :: MonadUnliftIO m+  => Vk.CommandBuffer+  -> Buffer.Allocated stage instances+  -> Bound dsl () instances m ()+quads cb instances = Bound do+  Vk.cmdBindVertexBuffers cb 0 (pure $ Buffer.aBuffer instances) (pure 0)+  Vk.cmdDraw cb 6 (Buffer.aUsed instances) 0 0++-- * Indexed models++-- ** Positions + attributes++-- | Draw whole-model instances.+indexed+  :: (MonadUnliftIO m, Model.HasVertexBuffers instances)+  => Vk.CommandBuffer+  -> Model.Indexed storage pos attrs+  -> instances+  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+indexed cmd model instances = indexedRanges cmd model instances [wholeIndexed]+  where+    wholeIndexed = Model.IndexRange+      { irFirstIndex = 0+      , irIndexCount = Buffer.aUsed (Model.iIndices model)+      }++{- |+  Draw subrange of each instance.++  E.g. chunks of the same material drawn in different places.+-}+indexedRanges+  :: (MonadUnliftIO m, Model.HasVertexBuffers instances)+  => Vk.CommandBuffer+  -> Model.Indexed storage pos attrs+  -> instances+  -> [Model.IndexRange]+  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+indexedRanges cmd model instances ranges = do+  checkedTanges <- traverse check ranges+  Bound $ unsafeIndexedRanges True cmd model instances checkedTanges+  where+    check ir@Model.IndexRange{..}+      | irFirstIndex > maxIndex =+          throwString "firstIndex is over the actual buffer size"+      | irFirstIndex + irIndexCount > maxIndex =+          throwString "firstIndex + indexCount is over the actual buffer size"+      | otherwise =+          pure ir++    maxIndex = Buffer.aUsed (Model.iIndices model)++{- |+  Draw ranges and instances zipped.++  E.g. range materials stored in instances.+-}+indexedParts+  :: (MonadUnliftIO m, Model.HasVertexBuffers instances, Foldable t)+  => Bool+  -> Vk.CommandBuffer+  -> Model.Indexed storage pos attrs+  -> instances+  -> Int+  -> t Model.IndexRange+  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+indexedParts drawAttrs cmd model instances startInstance parts =+  Bound $ unsafeIndexedParts drawAttrs cmd model instances startInstance parts++-- ** Position-only draws++-- | Draw whole-model instances, ignoring attributes.+indexedPos+  :: (MonadUnliftIO m, Model.HasVertexBuffers instances)+  => Vk.CommandBuffer+  -> Model.Indexed storage pos unusedAttrs+  -> instances+  -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m ()+indexedPos cmd model instances = indexedPosRanges cmd model instances [wholeIndexed]+  where+    wholeIndexed = Model.IndexRange+      { irFirstIndex = 0+      , irIndexCount = Buffer.aUsed (Model.iIndices model)+      }++-- | Draw subrange of each instances, ignoring attributes.+indexedPosRanges+  :: (MonadUnliftIO m, Model.HasVertexBuffers instances)+  => Vk.CommandBuffer+  -> Model.Indexed storage pos unusedAttrs+  -> instances+  -> [Model.IndexRange]+  -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m ()+indexedPosRanges cmd model instances ranges = do+  checkedTanges <- traverse check ranges+  Bound $ unsafeIndexedRanges False cmd model instances checkedTanges+  where+    check ir@Model.IndexRange{..}+      | irFirstIndex > maxIndex =+          throwString "firstIndex is over the actual buffer size"+      | irFirstIndex + irIndexCount > maxIndex =+          throwString "firstIndex + indexCount is over the actual buffer size"+      | otherwise =+          pure ir++    maxIndex = Buffer.aUsed (Model.iIndices model)++-- * Unchecked implementations++-- | Common unchecked part for pos/attrs+unsafeIndexedRanges+  :: (MonadUnliftIO io, Model.HasVertexBuffers instances, Foldable t)+  => Bool+  -> Vk.CommandBuffer+  -> Model.Indexed storage pos attrs+  -> instances+  -> t Model.IndexRange+  -> io ()+unsafeIndexedRanges drawAttrs cmd Model.Indexed{..} instances indexRanges =+  case toList indexRanges of+    [] ->+      pure ()++    _skip | instanceCount < 1 ->+      pure ()++    someRanges -> liftIO do+      Vk.cmdBindVertexBuffers cmd 0 vertexBuffers bufferOffsets+      Vk.cmdBindIndexBuffer cmd (Buffer.aBuffer iIndices) indexBufferOffset Vk.INDEX_TYPE_UINT32+      for_ someRanges \Model.IndexRange{..} ->+        Vk.cmdDrawIndexed cmd irIndexCount instanceCount irFirstIndex vertexOffset firstInstance++  where+    indexBufferOffset = 0+    vertexOffset = 0++    instanceCount = Model.getInstanceCount instances+    firstInstance = 0++    vertexBuffers = Vector.fromList $+      if drawAttrs then+        Buffer.aBuffer iPositions :+        Buffer.aBuffer iAttrs :+        Model.getVertexBuffers instances+      else+        Buffer.aBuffer iPositions :+        Model.getVertexBuffers instances++    bufferOffsets =+      Vector.replicate (Vector.length vertexBuffers) 0++-- | Instance/range zipped+unsafeIndexedParts+  :: (MonadUnliftIO io, Model.HasVertexBuffers instances, Foldable t)+  => Bool+  -> Vk.CommandBuffer+  -> Model.Indexed storage pos attrs+  -> instances+  -> Int+  -> t Model.IndexRange+  -> io ()+unsafeIndexedParts drawAttrs cmd Model.Indexed{..} instances startInstance parts =+  case drop startInstance (toList parts) of+    [] ->+      pure ()++    _skip | instanceCount < 1 ->+      pure ()++    someRanges -> liftIO do+      Vk.cmdBindVertexBuffers cmd 0 vertexBuffers bufferOffsets+      Vk.cmdBindIndexBuffer cmd (Buffer.aBuffer iIndices) indexBufferOffset Vk.INDEX_TYPE_UINT32+      for_ (zip [fromIntegral startInstance ..] someRanges) \(firstInstance, Model.IndexRange{..}) ->+        Vk.cmdDrawIndexed cmd irIndexCount instanceCount irFirstIndex vertexOffset firstInstance++  where+    indexBufferOffset = 0+    vertexOffset = 0++    instanceCount = 1 -- Model.getInstanceCount instances+    -- firstInstance = 0++    vertexBuffers = Vector.fromList $+      if drawAttrs then+        Buffer.aBuffer iPositions :+        Buffer.aBuffer iAttrs :+        Model.getVertexBuffers instances+      else+        Buffer.aBuffer iPositions :+        Model.getVertexBuffers instances++    bufferOffsets =+      Vector.replicate (Vector.length vertexBuffers) 0
+ src/Render/Samplers.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveAnyClass #-}++module Render.Samplers+  ( Collection(..)+  , allocate+  , indices++  , Params+  , create+  , destroy+  ) where++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 ((:::))+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (HasSwapchain(..), HasVulkan(..), MonadVulkan)+import Resource.Collection qualified as Collection++data Collection a = Collection+  { linearMipRepeat  :: a+  , linearMip        :: a+  , linearRepeat     :: a+  , linear           :: a+  , nearestMipRepeat :: a+  , nearestMip       :: a+  , nearestRepeat    :: a+  , nearest          :: a+  }+  deriving stock (Show, Functor, Foldable, Traversable, Generic, Generic1)+  deriving Applicative via (Co Collection)+  deriving anyclass (Representable)++instance Distributive Collection where+  collect = genericCollect++type Params = (Vk.Filter, "LOD clamp" ::: Float, Vk.SamplerAddressMode)++params :: Collection Params+params = Collection+  { linearMipRepeat  = (Vk.FILTER_LINEAR,  Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 0+  , linearMip        = (Vk.FILTER_LINEAR,  Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 1+  , linearRepeat     = (Vk.FILTER_LINEAR,  0,                 Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 2+  , linear           = (Vk.FILTER_LINEAR,  0,                 Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 3+  , nearestMipRepeat = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 4+  , nearestMip       = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 5+  , nearestRepeat    = (Vk.FILTER_NEAREST, 0,                 Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 6+  , nearest          = (Vk.FILTER_NEAREST, 0,                 Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 7+  }++indices :: Collection Int32+indices = fmap fst $ Collection.enumerate params++allocate+  :: ( MonadVulkan env m+     , Resource.MonadResource m+     , HasSwapchain a+     )+  => a+  -> m (Resource.ReleaseKey, Collection Vk.Sampler)+allocate swapchain = do+  context <- ask+  Resource.allocate+    (for params $ create context $ getAnisotropy swapchain)+    (traverse_ $ destroy context)++create+  :: (MonadIO io, HasVulkan context)+  => context+  -> "max anisotropy" ::: Float+  -> Params+  -> io Vk.Sampler+create context maxAnisotropy (filt, mips, reps) =+  Vk.createSampler (getDevice context) samplerCI Nothing+  where+    samplerCI = zero+      { Vk.magFilter               = filt+      , Vk.minFilter               = filt+      , Vk.addressModeU            = reps+      , Vk.addressModeV            = reps+      , Vk.addressModeW            = reps+      , Vk.anisotropyEnable        = maxAnisotropy > 1+      , Vk.maxAnisotropy           = maxAnisotropy+      , Vk.borderColor             = Vk.BORDER_COLOR_INT_OPAQUE_BLACK+      , Vk.unnormalizedCoordinates = False+      , Vk.compareEnable           = False+      , Vk.compareOp               = Vk.COMPARE_OP_ALWAYS+      , Vk.mipmapMode              = Vk.SAMPLER_MIPMAP_MODE_LINEAR+      , Vk.mipLodBias              = 0+      , Vk.minLod                  = 0+      , Vk.maxLod                  = mips+      }++destroy :: (MonadIO io, HasVulkan context) => context -> Vk.Sampler -> io ()+destroy context sampler =+  Vk.destroySampler (getDevice context) sampler Nothing
+ src/Resource/Buffer.hs view
@@ -0,0 +1,217 @@+module Resource.Buffer where++import RIO++import Data.Bits ((.|.))+import Data.Vector.Storable qualified as VectorS+import Foreign (Storable)+import Foreign qualified+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::))+import Vulkan.Zero (zero)+import VulkanMemoryAllocator qualified as VMA++import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer))+import Resource.CommandBuffer (oneshot_)++data Store = Staged | Coherent++data Allocated (s :: Store) a = Allocated+  { aBuffer         :: Vk.Buffer+  , aAllocation     :: VMA.Allocation+  , aAllocationInfo :: VMA.AllocationInfo+  , aCapacity       :: Int+  , aUsed           :: Word32+  , aUsage          :: Vk.BufferUsageFlagBits+  } deriving (Show)++allocateCoherent+  :: (Resource.MonadResource m, Storable a, HasVulkan context)+  => context+  -> Vk.BufferUsageFlagBits+  -> "initial size" ::: Int+  -> VectorS.Vector a+  -> m (Resource.ReleaseKey, Allocated 'Coherent a)+allocateCoherent context usage initialSize xs =+  Resource.allocate+    (createCoherent context usage initialSize xs)+    (destroy context)++createCoherent+  :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io)+  => context+  -> Vk.BufferUsageFlagBits+  -> "initial size" ::: Int+  -> VectorS.Vector a+  -> io (Allocated 'Coherent a)+createCoherent context usage initialSize xs = do+  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer (getAllocator context) bci aci++  when (len /= 0) $+    if VMA.mappedData aAllocationInfo == Foreign.nullPtr then+      error "TODO: recover from unmapped data and flush manually"+    else+      liftIO $ VectorS.unsafeWith xs \src ->+        Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData aAllocationInfo) src lenBytes++  pure Allocated+    { aCapacity = max initialSize len+    , aUsed     = fromIntegral len+    , aUsage    = usage+    , ..+    }+  where++    len = VectorS.length xs+    lenBytes = Foreign.sizeOf (undefined :: a) * len++    sizeBytes = Foreign.sizeOf (undefined :: a) * max initialSize len++    bci = zero+      { Vk.size        = fromIntegral sizeBytes+      , Vk.usage       = usage+      , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE+      }++    flags =+      Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT .|.+      Vk.MEMORY_PROPERTY_HOST_COHERENT_BIT++    aci = zero+      { VMA.flags          = VMA.ALLOCATION_CREATE_MAPPED_BIT+      , VMA.usage          = VMA.MEMORY_USAGE_GPU_ONLY+      , VMA.requiredFlags  = flags+      , VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT+      }++createStaged+  :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io)+  => context+  -> Queues Vk.CommandPool+  -> Vk.BufferUsageFlagBits+  -> Int+  -> VectorS.Vector a+  -> io (Allocated 'Staged a)+createStaged context commandQueues usage initialSize xs = do+  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer vma bci aci++  when (len /= 0) . liftIO $+    VMA.withBuffer vma stageCI stageAI bracket \(staging, _stage, stageInfo) ->+      if VMA.mappedData stageInfo == Foreign.nullPtr then+        error "TODO: recover from unmapped data and flush manually"+      else do+        VectorS.unsafeWith xs \src ->+          Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData stageInfo) src lenBytes+        copyBuffer_ context commandQueues aBuffer staging (fromIntegral sizeBytes)++  pure Allocated+    { aCapacity = max initialSize len+    , aUsed     = fromIntegral len+    , aUsage    = usage+    , ..+    }+  where+    vma = getAllocator context++    len = VectorS.length xs+    lenBytes = Foreign.sizeOf (undefined :: a) * len++    sizeBytes = Foreign.sizeOf (undefined :: a) * max initialSize len++    bci = zero+      { Vk.size        = fromIntegral sizeBytes+      , Vk.usage       = Vk.BUFFER_USAGE_TRANSFER_DST_BIT .|. usage+      , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE+      }++    aci = zero+      { VMA.usage         = VMA.MEMORY_USAGE_GPU_ONLY+      , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT+      }++    stageCI = zero+      { Vk.size        = fromIntegral sizeBytes+      , Vk.usage       = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT+      , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE+      }++    stageAI = zero+      { VMA.flags         = VMA.ALLOCATION_CREATE_MAPPED_BIT+      , VMA.usage         = VMA.MEMORY_USAGE_CPU_TO_GPU+      , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT+      }++destroy+  :: (MonadUnliftIO io, HasVulkan context)+  => context+  -> Allocated s a+  -> io ()+destroy context a =+  VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a)++destroyAll+  :: (MonadUnliftIO io, HasVulkan context, Foldable t)+  => context+  -> t (Allocated s a)+  -> io ()+destroyAll context =+  traverse_ \a ->+    VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a)++peekCoherent :: (MonadIO m, Storable a) => Word32 -> Allocated 'Coherent a -> m (Maybe a)+peekCoherent ix Allocated{..} =+  case VMA.mappedData aAllocationInfo of+    _ | ix + 1 > aUsed ->+      pure Nothing+    ptr | ptr == Foreign.nullPtr ->+      pure Nothing+    ptr ->+      liftIO . fmap Just $+        Foreign.peekElemOff (Foreign.castPtr ptr) (fromIntegral ix)++updateCoherent+  :: (Foreign.Storable a, MonadUnliftIO io)+  => VectorS.Vector a+  -> Allocated 'Coherent a+  -> io (Allocated 'Coherent a)+updateCoherent xs old = do+  liftIO $ VectorS.unsafeWith xs \src ->+    Foreign.copyBytes dst src lenBytes+  pure old+    { aUsed = fromIntegral len+    }+  where+    dst = Foreign.castPtr $ VMA.mappedData (aAllocationInfo old)+    len = VectorS.length xs+    lenBytes = len * Foreign.sizeOf (VectorS.head xs)++updateCoherentResize_+  :: (Storable a, HasVulkan context, MonadUnliftIO io)+  => context+  -> Allocated 'Coherent a+  -> VectorS.Vector a+  -> io (Allocated 'Coherent a)+updateCoherentResize_ ctx old xs =+  if newSize <= oldSize then+    updateCoherent xs old+  else do+    destroyAll ctx [old]+    createCoherent ctx (aUsage old) newSize xs+  where+    oldSize = aCapacity old+    newSize = VectorS.length xs++-- TODO: add a staged buffer to check out the transfer queue+copyBuffer_+  :: (MonadUnliftIO io, HasVulkan context)+  => context+  -> Queues Vk.CommandPool+  -> ("dstBuffer" ::: Vk.Buffer)+  -> ("srcBuffer" ::: Vk.Buffer)+  -> Vk.DeviceSize+  -> io ()+copyBuffer_ context commandQueues dst src sizeBytes =+  oneshot_ context commandQueues qTransfer \cmd ->+    Vk.cmdCopyBuffer cmd src dst+      (pure $ Vk.BufferCopy 0 0 sizeBytes)
+ src/Resource/Collection.hs view
@@ -0,0 +1,33 @@+module Resource.Collection+  ( enumerate+  , size+  , toVector+  , toVectorStorable+  ) 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)++{-# INLINE size #-}+size :: (Foldable t, Num size) => t a -> size+size = List.genericLength . toList++enumerate :: (Traversable t, Num ix) => t a -> t (ix, a)+enumerate = snd . mapAccumL f 0+  where+    f a b = (a + 1, (a, b))++{-# INLINE toVector #-}+toVector :: Foldable collection => collection a -> Vector a+toVector = Vector.fromList . toList++{-# INLINE toVectorStorable #-}+toVectorStorable+  :: (Foldable collection, Storable a)+  => collection a+  -> VectorStorable.Vector a+toVectorStorable = VectorStorable.fromList . toList
+ src/Resource/Combined/Textures.hs view
@@ -0,0 +1,51 @@+module Resource.Combined.Textures+  ( Collection(..)+  , attachDebugNames+  ) where++import RIO++import GHC.Stack (withFrozenCallStack)++import Engine.Vulkan.Types (MonadVulkan)+import Resource.Texture (Texture, debugNameCollection)++data Collection textures fonts a = Collection+  -- XXX: textures go first, as there should be a filler texture at [0]+  { textures :: textures a+  , fonts    :: fonts a+  }+  deriving (Show, Functor, Foldable, Traversable, Generic)++instance+  ( Applicative t+  , Applicative f+  )+  => Applicative (Collection t f) where+  pure x = Collection+    { textures = pure x+    , fonts    = pure x+    }++  af <*> ax = Collection+    { textures = textures af <*> textures ax+    , fonts    = fonts af <*> fonts ax+    }++attachDebugNames+  :: ( Traversable textures+     , Traversable fonts+     , MonadVulkan env m+     , HasLogFunc env+     , HasCallStack+     )+  => Collection textures fonts (Texture a)+  -> textures FilePath+  -> fonts FilePath+  -> m ()+attachDebugNames combined texturePaths fontPaths =+  withFrozenCallStack $+    debugNameCollection combined Collection+      { textures = texturePaths+      , fonts    = fontPaths+      }
+ src/Resource/CommandBuffer.hs view
@@ -0,0 +1,89 @@+module Resource.CommandBuffer+  ( allocatePools+  , withPools+  , oneshot_+  ) where++import RIO++import Data.Vector qualified as Vector+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.CStruct.Extends (SomeStruct(..))+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..))++allocatePools+  :: (HasVulkan context, Resource.MonadResource m)+  => context+  -> m (Resource.ReleaseKey, Queues Vk.CommandPool)+allocatePools context = do+  -- context <- ask+  bootstrapQueues <- for (getQueues context) \(QueueFamilyIndex ix, _queue) -> do+    let+      commandPoolCI = Vk.CommandPoolCreateInfo+        { flags            = zero+        , queueFamilyIndex = ix+        }+    Vk.withCommandPool (getDevice context) commandPoolCI Nothing Resource.allocate++  bqKey <- Resource.register $+    traverse_ (Resource.release . fst) bootstrapQueues+  pure (bqKey, fmap snd bootstrapQueues)++withPools+  :: (MonadVulkan env m, MonadResource m)+  => (Queues Vk.CommandPool -> m a)+  -> m a+withPools action = do+  context <- ask+  bracket (allocatePools context) (Resource.release . fst) (action . snd)++-- | Scratch command buffer for transfer operations.+-- The simple fence makes it unusable for rendering.+oneshot_+  :: (HasVulkan context, MonadUnliftIO m)+  => context+  -> Queues Vk.CommandPool+  -> (forall a . Queues a -> a)+  -> (Vk.CommandBuffer -> m ())+  -> m ()+oneshot_ context commandQueues pickQueue action =+  Vk.withCommandBuffers device commandBufferAllocateInfo bracket $ \case+    (Vector.toList -> [buf]) -> do+      let+        oneTime :: Vk.CommandBufferBeginInfo '[]+        oneTime = zero+          { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT+          }++      Vk.useCommandBuffer buf oneTime $ action buf++      Vk.withFence device zero Nothing bracket $ \fence -> do+        Vk.queueSubmit transferQueue (wrap buf) fence+        Vk.waitForFences device (pure fence) True maxBound >>= \case+          Vk.SUCCESS ->+            -- traceM "oneshot_: transfer finished"+            pure ()+          err ->+            error $ "copyBuffer failed: " <> show err+    _ ->+      error "assert: exactly the requested buffer was given"+  where+    device = getDevice context+    transferQueue = snd . pickQueue $ getQueues context++    commandBufferAllocateInfo :: Vk.CommandBufferAllocateInfo+    commandBufferAllocateInfo = zero+      { Vk.commandPool        = pickQueue commandQueues+      , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY+      , Vk.commandBufferCount = 1+      }++    wrap buf = Vector.singleton $ SomeStruct zero+      { Vk.commandBuffers =+          Vector.singleton (Vk.commandBufferHandle buf)+      }
+ src/Resource/Compressed/Zstd.hs view
@@ -0,0 +1,39 @@+module Resource.Compressed.Zstd where++import RIO++import RIO.FilePath (takeExtension)+import RIO.ByteString qualified as ByteString++import Codec.Compression.Zstd qualified as Zstd++data CompressedError+  = EmptyFile FilePath+  | ZstdError Text+  deriving (Eq, Show)++instance Exception CompressedError++fromFileWith :: MonadIO m => (ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b+fromFileWith withBS withFilePath filePath+  | elem (takeExtension filePath) compressedExts =+      loadCompressed withBS filePath+  | otherwise =+      withFilePath filePath++loadCompressed :: MonadIO m => (ByteString -> m b) -> FilePath -> m b+loadCompressed withBS filePath = do+  yeet'd <- ByteString.readFile filePath+  case Zstd.decompress yeet'd of+    Zstd.Skip ->+      throwIO $ EmptyFile filePath+    Zstd.Error str ->+      throwIO $ ZstdError (fromString str)+    Zstd.Decompress buf ->+      withBS buf++compressedExts :: [FilePath]+compressedExts =+  [ ".zst"+  , ".zstd"+  ]
+ src/Resource/DescriptorSet.hs view
@@ -0,0 +1,32 @@+module Resource.DescriptorSet+  ( allocatePool+  , TypeMap+  , mkPoolCI+  ) where++import RIO++import UnliftIO.Resource qualified as Resource+import RIO.Vector qualified as Vector+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (HasVulkan(getDevice))++allocatePool+  :: (Resource.MonadResource m, MonadReader env m, HasVulkan env)+  => Word32 -> TypeMap Word32 -> m (Resource.ReleaseKey, Vk.DescriptorPool)+allocatePool maxSets sizes = do+  device <- asks getDevice+  Vk.withDescriptorPool device (mkPoolCI maxSets sizes) Nothing Resource.allocate++type TypeMap a = [(Vk.DescriptorType, a)]++mkPoolCI+  :: Word32+  -> TypeMap Word32+  -> Vk.DescriptorPoolCreateInfo '[]+mkPoolCI maxSets sizes = zero+  { Vk.maxSets   = maxSets+  , Vk.poolSizes = Vector.fromList $ map (uncurry Vk.DescriptorPoolSize) sizes+  }
+ src/Resource/Image.hs view
@@ -0,0 +1,318 @@+module Resource.Image where++import RIO++import Data.Bits (shiftR, (.|.))+import RIO.Vector qualified as Vector+import Vulkan.Core10 qualified as Vk+import Vulkan.CStruct.Extends (SomeStruct(..))+import Vulkan.NamedType ((:::))+import Vulkan.Utils.Debug qualified as Debug+import Vulkan.Zero (zero)+import VulkanMemoryAllocator qualified as VMA++import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..), Queues(..))+import Resource.CommandBuffer (oneshot_)++data AllocatedImage = AllocatedImage+  { aiAllocation :: VMA.Allocation+  , aiImage      :: Vk.Image+  , aiImageView  :: Vk.ImageView+  }+  deriving (Show)++createColorResource+  :: ( MonadIO io+     , HasVulkan ctx+     , HasSwapchain ctx+     )+  => ctx+  -> Vk.Extent2D+  -> io AllocatedImage+createColorResource context Vk.Extent2D{width, height} = do+  let+    device    = getDevice context+    allocator = getAllocator context+    format    = getSurfaceFormat context+    msaa      = getMultisample context++  (image, allocation, _info) <- VMA.createImage+    allocator+    (imageCI format msaa)+    imageAllocationCI+  Debug.nameObject device image "ColorResource.image"++  imageView <- Vk.createImageView+    device+    (imageViewCI image format)+    Nothing+  Debug.nameObject device image "ColorResource.view"++  pure AllocatedImage+    { aiAllocation = allocation+    , aiImage      = image+    , aiImageView  = imageView+    }+  where+    imageCI format msaa = zero+      { Vk.imageType     = Vk.IMAGE_TYPE_2D+      , Vk.format        = format+      , Vk.extent        = Vk.Extent3D width height 1+      , Vk.mipLevels     = 1+      , Vk.arrayLayers   = 1+      , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL+      , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED+      , Vk.usage         = Vk.IMAGE_USAGE_TRANSIENT_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT+      , Vk.sharingMode   = Vk.SHARING_MODE_EXCLUSIVE+      , Vk.samples       = msaa+      }++    imageAllocationCI = zero+      { VMA.usage         = VMA.MEMORY_USAGE_GPU_ONLY+      , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT+      }++    imageViewCI image format = zero+      { Vk.image            = image+      , Vk.viewType         = Vk.IMAGE_VIEW_TYPE_2D+      , Vk.format           = format+      , Vk.components       = zero+      , Vk.subresourceRange = subr+      }++    subr = zero+      { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT+      , Vk.baseMipLevel   = 0+      , Vk.levelCount     = 1+      , Vk.baseArrayLayer = 0+      , Vk.layerCount     = 1+      }++createDepthResource+  :: ( MonadIO io+     , HasVulkan context+     , HasSwapchain context+     )+  => context+  -> Vk.Extent2D+  -> "shadowmap layers" ::: Maybe Word32+  -> io AllocatedImage+createDepthResource context Vk.Extent2D{width, height} depthLayers = do+  let+    device    = getDevice context+    allocator = getAllocator context++    depthFormat = getDepthFormat context+    msaa        = getMultisample context++    (samples, usage, numLayers) =+      case depthLayers of+        Nothing ->+          ( msaa+          , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT+          , 1+          )+        Just nl ->+          ( Vk.SAMPLE_COUNT_1_BIT+          , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|.+            Vk.IMAGE_USAGE_SAMPLED_BIT+          , nl+          )++  (image, allocation, _info) <- VMA.createImage+    allocator+    (imageCI depthFormat usage samples numLayers)+    imageAllocationCI+  Debug.nameObject device image "DepthResource.image"++  imageView <- Vk.createImageView+    device+    (imageViewCI depthFormat image numLayers)+    Nothing+  Debug.nameObject device image "DepthResource.view"++  pure AllocatedImage+    { aiAllocation = allocation+    , aiImage      = image+    , aiImageView  = imageView+    }+  where+    imageCI format usage samples numLayers = zero+      { Vk.imageType     = Vk.IMAGE_TYPE_2D+      , Vk.format        = format+      , Vk.extent        = Vk.Extent3D width height 1+      , Vk.mipLevels     = 1+      , Vk.arrayLayers   = numLayers+      , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL+      , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED+      , Vk.usage         = usage+      , Vk.sharingMode   = Vk.SHARING_MODE_EXCLUSIVE+      , Vk.samples       = samples+      }++    imageAllocationCI = zero+      { VMA.usage         = VMA.MEMORY_USAGE_GPU_ONLY+      , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT+      }++    imageViewCI format image numLayers = zero+      { Vk.image            = image+      , Vk.viewType         = viewType+      , Vk.format           = format+      , Vk.components       = zero+      , Vk.subresourceRange = subr numLayers+      }+      where+        viewType =+          if numLayers > 1 then+            Vk.IMAGE_VIEW_TYPE_2D_ARRAY+          else+            Vk.IMAGE_VIEW_TYPE_2D++    subr numLayers = zero+      { Vk.aspectMask     = Vk.IMAGE_ASPECT_DEPTH_BIT+      , Vk.baseMipLevel   = 0+      , Vk.levelCount     = 1+      , Vk.baseArrayLayer = 0+      , Vk.layerCount     = numLayers+      }++destroyAllocatedImage+  :: ( MonadIO io+     , HasVulkan context+     )+  => context+  -> AllocatedImage+  -> io ()+destroyAllocatedImage context AllocatedImage{..} = do+  -- traceM "destroyAllocatedImage"+  Vk.destroyImageView (getDevice context) aiImageView Nothing+  VMA.destroyImage (getAllocator context) aiImage aiAllocation++--------------------------------------------++transitionImageLayout+  :: (HasVulkan context)+  => context+  -> Queues Vk.CommandPool+  -> Vk.Image+  -> "mip levels" ::: Word32+  -> "layer count" ::: Word32+  -> Vk.Format+  -> ("old" ::: Vk.ImageLayout)+  -> ("new" ::: Vk.ImageLayout)+  -> RIO env ()+transitionImageLayout ctx pool image mipLevels layerCount format old new =+  case (old, new) of+    (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->+      oneshot_ ctx pool qTransfer \buf ->+        Vk.cmdPipelineBarrier+          buf+          Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+          Vk.PIPELINE_STAGE_TRANSFER_BIT+          zero+          mempty+          mempty+          ( Vector.singleton $+              barrier Vk.IMAGE_ASPECT_COLOR_BIT zero Vk.ACCESS_TRANSFER_WRITE_BIT+          )+    (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL) ->+      oneshot_ ctx pool qTransfer \buf ->+        Vk.cmdPipelineBarrier+          buf+          Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+          Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT+          zero+          mempty+          mempty+          ( Vector.singleton $+              barrier aspectMask zero $+                Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT .|.+                Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT+          )+        where+          aspectMask =+            if hasStencilComponent then+              Vk.IMAGE_ASPECT_DEPTH_BIT .|. Vk.IMAGE_ASPECT_STENCIL_BIT+            else+              Vk.IMAGE_ASPECT_DEPTH_BIT+          hasStencilComponent =+            format == Vk.FORMAT_D32_SFLOAT_S8_UINT ||+            format == Vk.FORMAT_D24_UNORM_S8_UINT++    (Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL) ->+      oneshot_ ctx pool qGraphics \buf ->+        Vk.cmdPipelineBarrier+          buf+          Vk.PIPELINE_STAGE_TRANSFER_BIT+          Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT+          zero+          mempty+          mempty+          ( Vector.singleton $+              barrier+                Vk.IMAGE_ASPECT_COLOR_BIT+                Vk.ACCESS_TRANSFER_WRITE_BIT+                Vk.ACCESS_SHADER_READ_BIT+          )+    _ ->+      error $ "Unsupported image layout transfer: " <> show (old, new)+  where+    barrier aspectMask srcMask dstMask = SomeStruct zero+      { Vk.srcAccessMask       = srcMask+      , Vk.dstAccessMask       = dstMask+      , Vk.oldLayout           = old+      , Vk.newLayout           = new+      , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+      , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+      , Vk.image               = image+      , Vk.subresourceRange    = subresource aspectMask mipLevels layerCount+      }++subresource+  :: Vk.ImageAspectFlags+  -> "mip levels" ::: Word32+  -> "layer count" ::: Word32+  -> Vk.ImageSubresourceRange+subresource aspectMask mipLevels layerCount = Vk.ImageSubresourceRange+  { aspectMask     = aspectMask+  , baseMipLevel   = 0+  , levelCount     = mipLevels -- XXX: including base+  , baseArrayLayer = 0+  , layerCount     = layerCount+  }++copyBufferToImage+  :: (HasVulkan context, Foldable t, Integral deviceSize)+  => context+  -> Queues Vk.CommandPool+  -> Vk.Buffer+  -> Vk.Image+  -> "base extent" ::: Vk.Extent3D+  -> "mip offsets" ::: t deviceSize+  -> "layer count" ::: Word32+  -> RIO env ()+copyBufferToImage ctx pool src dst Vk.Extent3D{..} mipOffsets layerCount =+  oneshot_ ctx pool qTransfer \cmd ->+    Vk.cmdCopyBufferToImage cmd src dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $+      Vector.fromList copyRegions+  where+    copyRegions = do+      (offset, mipLevel) <- zip (toList mipOffsets) [0..]+      pure Vk.BufferImageCopy+        { Vk.bufferOffset      = fromIntegral offset+        , Vk.bufferRowLength   = zero -- XXX: "use extent width"+        , Vk.bufferImageHeight = zero -- XXX: "use extent height"+        , Vk.imageSubresource = Vk.ImageSubresourceLayers+            { aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT+            , mipLevel       = fromIntegral mipLevel+            , baseArrayLayer = 0+            , layerCount     = layerCount+            }+        , Vk.imageOffset = zero+        , Vk.imageExtent = Vk.Extent3D+            { width  = max 1 $ width `shiftR` mipLevel+            , height = max 1 $ height `shiftR` mipLevel+            , depth  = depth+            }+        }
+ src/Resource/Mesh/Codec.hs view
@@ -0,0 +1,340 @@+module Resource.Mesh.Codec where++import RIO++import Codec.Compression.Zstd qualified as Zstd+import Crypto.Hash.MD5 qualified as MD5+import Data.Binary.Get (runGet)+import Data.Binary.Get qualified as Get+import Data.Binary.Put (runPut)+import Data.Binary.Put qualified as Put+import Data.ByteString.Internal qualified as BSI+import Data.ByteString.Unsafe (unsafePackCStringLen)+import Data.Vector qualified as Vector+import Data.Vector.Generic qualified as Generic+import Data.Vector.Storable qualified as Storable+import Foreign qualified+import Geomancy.Vec3 qualified as Vec3+import RIO.ByteString qualified as ByteString+import RIO.ByteString.Lazy qualified as BSL+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Data.Typeable++import Engine.Vulkan.Types (HasVulkan, Queues)+import Resource.Buffer qualified as Buffer+import Resource.Model qualified as Model++-- * Format meta++pattern VER_BREAKS :: Word8+pattern VER_BREAKS = 2++pattern VER_TWEAKS :: Word8+pattern VER_TWEAKS = 0++-- * Encoding++encodeFile+  :: forall vp vi va vn attrs nodes meta env+  .  ( Generic.Vector vp Vec3.Packed+     , Generic.Vector vi Word32+     , Generic.Vector va attrs+     , Generic.Vector vn nodes+     , Storable attrs+     , Storable nodes+     , Storable meta+     , HasLogFunc env+     )+  => FilePath+  -> vp Vec3.Packed+  -> vi Word32+  -> va attrs+  -> vn nodes+  -> meta+  -> RIO env ()+encodeFile fp positions indices attrs nodes meta = do+  (posDigest, posCompressed) <- encodeItems positions+  logDebug $ "Position digest: " <> displayShow posDigest++  (indDigest, indCompressed) <- encodeItems indices+  logDebug $ "Index digest: " <> displayShow indDigest++  (attDigest, attCompressed) <- encodeItems attrs+  logDebug $ "Attribute digest: " <> displayShow attDigest++  (nodDigest, nodCompressed) <- encodeItems nodes+  logDebug $ "Node digest: " <> displayShow nodDigest++  (metDigest, metCompressed) <- encodeItems $ Storable.singleton meta+  logDebug $ "Meta digest: " <> displayShow metDigest++  withFile fp WriteMode \out -> do+    BSL.hPut out $ runPut do+      -- 0x00 + 4 + 4+      Put.putStringUtf8 "🌋📦"++      -- 0x08 + 1 + 1+      Put.putWord8 VER_BREAKS+      Put.putWord8 VER_TWEAKS++      -- 0x0A + 2 + 4+      -- XXX: reserved+      Put.putWord16le maxBound+      Put.putWord32le maxBound++      -- 0x10 + 4 + 4+      Put.putWord32le . fromIntegral $ Generic.length positions+      Put.putWord32le . fromIntegral $ ByteString.length posCompressed++      -- 0x18 + 4 + 4+      Put.putWord32le . fromIntegral $ Generic.length indices+      Put.putWord32le . fromIntegral $ ByteString.length indCompressed++      -- 0x20 + 4 + 4+      Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: attrs)+      Put.putWord32le . fromIntegral $ ByteString.length attCompressed++      -- 0x28 + 4 + 4+      Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: nodes)+      Put.putWord32le . fromIntegral $ ByteString.length nodCompressed++      -- 0x30 + 4 + 4+      Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: meta)+      Put.putWord32le . fromIntegral $ ByteString.length metCompressed++      -- 0x38 + 4 + 4+      -- XXX: reserved+      Put.putWord32le maxBound+      Put.putWord32le maxBound++      -- 0x40 + 16 + 16 + 16 + 16 + 16+      Put.putByteString posDigest+      Put.putByteString indDigest+      Put.putByteString attDigest+      Put.putByteString nodDigest+      Put.putByteString metDigest++      -- 0x90 + posCompressed+      Put.putByteString posCompressed++      -- 0x90 + posCompressed + indCompressed+      Put.putByteString indCompressed++      -- 0x90 + posCompressed + indCompressed + attCompressed+      Put.putByteString attCompressed++      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed+      Put.putByteString nodCompressed++      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed+      Put.putByteString metCompressed++      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed + 4 + 4+      Put.putStringUtf8 "📦🌋"++encodeItems+  :: ( Storable a+     , Generic.Vector v a+     , MonadIO m+     )+  => v a+  -> m (ByteString, ByteString)+encodeItems items = do+  let bytes = Storable.unsafeCast @_ @Word8 $ Vector.convert items+  liftIO $ Storable.unsafeWith bytes \ptr -> do+    buf <- unsafePackCStringLen+      ( Foreign.castPtr ptr+      , Storable.length bytes+      )+    let+      -- XXX: Process buffer before bytes/ptr go out of scope!+      !bufHash = MD5.hash buf+      !zBuf = Zstd.compress Zstd.maxCLevel buf+    pure (bufHash, zBuf)++-- * Decoding++loadIndexed+  :: ( Storable attrs+     , Storable nodes+     , Storable meta+     , Show meta+     , Typeable nodes+     , HasVulkan env+     , HasLogFunc env+     , MonadResource (RIO env)+     )+  => Queues Vk.CommandPool+  -> FilePath+  -> RIO env+    ( Resource.ReleaseKey+    , (meta, Storable.Vector nodes, Model.Indexed 'Buffer.Staged Vec3.Packed attrs)+    )+loadIndexed pools fp = do+  logInfo $ "Loading " <> fromString fp+  (meta, nodes, (positions, indices, attrs)) <- loadBlobs fp+  logDebug $ displayShow meta++  logDebug $ "Staging " <> fromString fp+  context <- ask+  indexed <- Model.createStaged context pools positions attrs indices+  key <- Resource.register $ Model.destroyIndexed context indexed+  pure (key, (meta, nodes, indexed))++loadBlobs+  :: forall attrs env nodes meta+  .  ( Storable attrs+     , Storable meta+     , Storable nodes+     , Typeable nodes+     , HasLogFunc env+     )+  => FilePath+  -> RIO env+    ( meta+    , Storable.Vector nodes+    , ( Storable.Vector Vec3.Packed+      , Storable.Vector Word32+      , Storable.Vector attrs+      )+    )+loadBlobs fp = do+  blob <- BSL.readFile fp+  let+    getter = do+      magicStart <- Get.getByteString (4+4)++      verBreaks <- Get.getWord8+      verTweaks <- Get.getWord8+      guardEq "Codec version" VER_BREAKS verBreaks++      _reserved16 <- Get.getWord16le+      _reserved32 <- Get.getWord32le++      numPositions <- fmap fromIntegral Get.getWord32le+      lenPositions <- fmap fromIntegral Get.getWord32le++      numIndices <- fmap fromIntegral Get.getWord32le+      lenIndices <- fmap fromIntegral Get.getWord32le++      sizeOfAttr <- fmap fromIntegral Get.getWord32le+      lenAttrs   <- fmap fromIntegral Get.getWord32le+      guardEq "Attribute size" (Foreign.sizeOf (error "sizeOfAttr" :: attrs)) sizeOfAttr++      sizeOfNode <- fmap fromIntegral Get.getWord32le+      lenNodes   <- fmap fromIntegral Get.getWord32le+      guardEq+        ("Node size for " <> show (typeRepTyCon . typeRep $ Proxy @nodes))+        (Foreign.sizeOf (error "sizeOfNode" :: nodes))+        sizeOfNode++      sizeOfMeta <- fmap fromIntegral Get.getWord32le+      lenMeta    <- fmap fromIntegral Get.getWord32le+      guardEq "Meta size" (Foreign.sizeOf (error "sizeOf" :: meta)) sizeOfMeta++      _reserved32 <- Get.getWord32le+      _reserved32 <- Get.getWord32le++      posDigest <- Get.getByteString 16+      indDigest <- Get.getByteString 16+      attDigest <- Get.getByteString 16+      nodDigest <- Get.getByteString 16+      metDigest <- Get.getByteString 16++      -- XXX: end for static part for VER_BREAKS+      staticDone <- Get.bytesRead+      guardEq ("End of static part for v" <> show VER_BREAKS) 0x90 staticDone++      let payloadSize = fromIntegral (lenPositions + lenIndices + lenAttrs + lenNodes + lenMeta)+      guardEq "Blob size" (BSL.length blob) $+        staticDone + payloadSize + 4 + 4++      zPositions <- Get.getByteString lenPositions+      zIndices   <- Get.getByteString lenIndices+      zAttrs     <- Get.getByteString lenAttrs+      zNodes     <- Get.getByteString lenNodes+      zMetas     <- Get.getByteString lenMeta++      magicFinish <- Get.getByteString (4+4)++      let magicReverse = ByteString.drop 4 magicFinish <> ByteString.take 4 magicFinish+      guardEq "Magic final" magicStart magicReverse++      positions <- decodeItems "Positions"  posDigest (Just numPositions) zPositions+      indices   <- decodeItems "Indices"    indDigest (Just numIndices)   zIndices+      attrs     <- decodeItems "Attributes" attDigest (Just numPositions) zAttrs+      nodes     <- decodeItems "Nodes"      nodDigest Nothing             zNodes+      meta      <- decodeItems "Metadata"   metDigest (Just 1)            zMetas++      pure (verTweaks, Storable.head meta, nodes, (positions, indices, attrs))++  let (verTweaks, meta, nodes, blobs) = runGet getter blob++  when (verTweaks /= VER_TWEAKS) $+    logWarn $ mconcat+      [ "Format tweak version mismatch: "+      , display verTweaks+      , " /= "+      , display VER_TWEAKS+      ]++  pure (meta, nodes, blobs)++decodeItems+  :: forall item m+  . (Storable item, MonadFail m)+  => String+  -> ByteString+  -> Maybe Int+  -> ByteString+  -> m (Storable.Vector item)+decodeItems label digest expectedSize zBytes =+  case Zstd.decompress zBytes of+    Zstd.Error err ->+      fail err+    Zstd.Skip -> do+      guardEq (label <> " size") 0 itemSize+      case expectedSize of+        Just size ->+          pure . Storable.replicate size $+            unsafePerformIO (Foreign.peek Foreign.nullPtr)+        Nothing ->+          pure Storable.empty+    Zstd.Decompress bytes -> do+      let (buf, bufOff, bufLen) = BSI.toForeignPtr bytes+      guardEq (label <> " buffer offset") 0 bufOff+      case expectedSize of+        Nothing ->+          pure ()+        Just size ->+          guardEq (label <> " buffer size") (itemSize * size) bufLen+      guardEq (label <> " hash") digest (MD5.hash bytes)+      let+        !items =+          Storable.unsafeCast @Word8 @item $+            Storable.unsafeFromForeignPtr0 buf bufLen+      case expectedSize of+        Nothing ->+          pure ()+        Just size ->+          guardEq (label <> " size") size (Storable.length items)+      pure items+  where+    itemSize = Foreign.sizeOf @item undefined++-- * Utils++guardEq :: (MonadFail m, Show a, Eq a) => String -> a -> a -> m ()+guardEq label expected got = do+  if expected == got then+    -- traceM . fromString $ label <> " match: " <> show got+    pure ()+  else+    fail $ unlines+      [ label <> " mismatch"+      , "\tExpected: " <> show expected+      , "\tGot     : " <> show got+      ]
+ src/Resource/Mesh/Types.hs view
@@ -0,0 +1,305 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}++module Resource.Mesh.Types+  ( AxisAligned(..)++  , Meta(..)++  , NodeGroup(..)+  , NodePartitions(..)++  , Nodes+  , Node(..)+  , TexturedNodes+  , TexturedNode(..)+  , TextureParams(..) -- XXX: copypasta from LitTextured++  , Measurements(..)+  , measureAa+  , measureAaWith+  , middle+  , middleAa+  , size+  , sizeAa++  , HasRange(..)+  ) where++import RIO++import Control.Foldl qualified as L+import Foreign (Storable(..), castPtr)+import Foreign.Storable.Generic (GStorable)+import Geomancy (Transform(..), Vec2, Vec4, withVec3)+import Geomancy.Mat4 qualified as Mat4+import Geomancy.Vec3 qualified as Vec3+import RIO.Vector.Storable qualified as Storable+import Vulkan.Zero (Zero(..))++import Resource.Model (IndexRange(..))++data AxisAligned a = AxisAligned+  { aaX :: a+  , aaY :: a+  , aaZ :: a+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)++instance Applicative AxisAligned where+  pure x = AxisAligned+    { aaX = x+    , aaY = x+    , aaZ = x+    }++  funcs <*> args = AxisAligned+    { aaX = aaX funcs $ aaX args+    , aaY = aaY funcs $ aaY args+    , aaZ = aaZ funcs $ aaZ args+    }++instance Storable a => Storable (AxisAligned a) where+  alignment ~_ = alignment (error "AxisAligned.alignment" :: a)++  sizeOf ~_ = 3 * sizeOf (error "AxisAligned.sizeOf" :: a)++  peek ptr = do+    aaX <- peekElemOff (castPtr ptr) 0+    aaY <- peekElemOff (castPtr ptr) 1+    aaZ <- peekElemOff (castPtr ptr) 2+    pure AxisAligned{..}++  poke ptr AxisAligned{..} = do+    pokeElemOff (castPtr ptr) 0 aaX+    pokeElemOff (castPtr ptr) 1 aaY+    pokeElemOff (castPtr ptr) 2 aaZ++-- * Whole-scene metadata++data Meta = Meta+  { -- XXX: full-scene draws+    mOpaqueIndices  :: IndexRange+  , mBlendedIndices :: IndexRange++    -- XXX: per-node draws+  , mOpaqueNodes    :: IndexRange+  , mBlendedNodes   :: IndexRange++  , mBoundingSphere :: Vec4+  , mTransformBB    :: Transform+  , mMeasurements   :: AxisAligned Measurements+  }+  deriving (Show, Generic)++instance GStorable Meta++instance Eq Meta where+  a == b = and+    [ mBoundingSphere a == mBoundingSphere b+    , mOpaqueIndices  a == mOpaqueIndices  b+    , mBlendedIndices a == mBlendedIndices b+    , mOpaqueNodes    a == mOpaqueNodes    b+    , mBlendedNodes   a == mBlendedNodes   b+    , mMeasurements   a == mMeasurements   b++    , Mat4.toListRowMajor (mTransformBB a) ==+      Mat4.toListRowMajor (mTransformBB b)+    ]++-- * Scene parts++data NodeGroup+  = NodeOpaque+  | NodeBlended+  -- TODO: NodeCutout+  deriving (Eq, Ord, Show, Enum, Bounded)++data NodePartitions a = NodePartitions+  { npOpaque  :: a+  , npBlended :: a+  }+  deriving (Eq, Show, Functor, Foldable, Traversable)++type Nodes = Storable.Vector Node++data Node = Node+  { nBoundingSphere :: Vec4+  , nTransformBB    :: Transform+  , nRange          :: IndexRange+  , nMeasurements   :: AxisAligned Measurements+  }+  deriving (Show, Generic)++instance Eq Node where+  a == b = and+    [ nBoundingSphere a == nBoundingSphere b+    , nMeasurements   a == nMeasurements   b+    , nRange          a == nRange          b++    , Mat4.toListRowMajor (nTransformBB a) ==+      Mat4.toListRowMajor (nTransformBB b)+    ]++instance GStorable Node++type TexturedNodes = Storable.Vector TexturedNode++data TexturedNode = TexturedNode+  { tnNode              :: Node+  , tnBase              :: TextureParams+  , tnEmissive          :: TextureParams+  , tnNormal            :: TextureParams+  , tnOcclusion         :: TextureParams+  , tnMetallicRoughness :: TextureParams+  }+  deriving (Eq, Show, Generic)++instance GStorable TexturedNode++-- XXX: copypasta from LitTextured.Model+data TextureParams = TextureParams+  { tpScale     :: Vec2+  , tpOffset    :: Vec2+  , tpGamma     :: Vec4+  , tpSamplerId :: Int32+  , tpTextureId :: Int32+  }+  deriving (Eq, Show, Generic)++instance Zero TextureParams where+  zero = TextureParams+    { tpScale     = 1+    , tpOffset    = 0+    , tpGamma     = 1.0+    , tpSamplerId = minBound+    , tpTextureId = minBound+    }++instance Storable TextureParams where+  alignment ~_ = 4++  sizeOf ~_ = 8 + 8 + 16 + 4 + 4++  poke ptr TextureParams{..} = do+    pokeByteOff ptr  0 tpScale+    pokeByteOff ptr  8 tpOffset+    pokeByteOff ptr 16 tpGamma+    pokeByteOff ptr 32 tpSamplerId+    pokeByteOff ptr 36 tpTextureId++  peek ptr = do+    tpScale     <- peekByteOff ptr  0+    tpOffset    <- peekByteOff ptr  8+    tpGamma     <- peekByteOff ptr 16+    tpSamplerId <- peekByteOff ptr 32+    tpTextureId <- peekByteOff ptr 36+    pure TextureParams{..}++-- * Measurements++data Measurements = Measurements+  { mMin  :: Float+  , mMax  :: Float+  , mMean :: Float+  , mStd  :: Float+  }+  deriving (Eq, Ord, Show, Generic)++instance Storable Measurements where+  alignment ~_ = 4 -- XXX: 16?++  sizeOf ~_ = 4 * 4++  peek ptr = do+    mMin  <- peekByteOff ptr  0+    mMax  <- peekByteOff ptr  4+    mMean <- peekByteOff ptr  8+    mStd  <- peekByteOff ptr 12+    pure Measurements{..}++  poke ptr Measurements{..} = do+    pokeByteOff ptr  0 mMin+    pokeByteOff ptr  4 mMax+    pokeByteOff ptr  8 mMean+    pokeByteOff ptr 12 mStd++{-# INLINEABLE middleAa #-}+middleAa :: AxisAligned Measurements -> AxisAligned Float+middleAa = fmap middle++{-# INLINEABLE middle #-}+middle :: Measurements -> Float+middle Measurements{mMax, mMin} = mMin * 0.5 + mMax * 0.5++{-# INLINEABLE sizeAa #-}+sizeAa :: AxisAligned Measurements -> AxisAligned Float+sizeAa = fmap size++{-# INLINEABLE size #-}+size :: Measurements -> Float+size Measurements{mMax, mMin} = mMax - mMin++measureAaWith+  :: (Foldable outer, Foldable inner)+  => (a -> inner Vec3.Packed)+  -> outer a+  -> AxisAligned Measurements+measureAaWith f = L.fold (measureAaWithF f)++measureAaWithF :: (Foldable t) => (a -> (t Vec3.Packed)) -> L.Fold a (AxisAligned Measurements)+measureAaWithF f = L.premap f (L.handles L.folded measureAaF)++measureAa :: Foldable t => t Vec3.Packed -> AxisAligned Measurements+measureAa = L.fold measureAaF++measureAaF :: L.Fold Vec3.Packed (AxisAligned Measurements)+measureAaF = AxisAligned+  <$> L.premap packedX measureF+  <*> L.premap packedY measureF+  <*> L.premap packedZ measureF++measureF :: L.Fold Float Measurements+measureF = do+  mMin  <- fmap (fromMaybe 0) L.minimum+  mMax  <- fmap (fromMaybe 0) L.maximum+  mMean <- L.mean+  mStd  <- L.std+  pure Measurements{..}++-- * Utils++{-# INLINE packedX #-}+packedX :: Vec3.Packed -> Float+packedX (Vec3.Packed pos) = withVec3 pos \x _y _z -> x++{-# INLINE packedY #-}+packedY :: Vec3.Packed -> Float+packedY (Vec3.Packed pos) = withVec3 pos \_x y _z -> y++{-# INLINE packedZ #-}+packedZ :: Vec3.Packed -> Float+packedZ (Vec3.Packed pos) = withVec3 pos \_x _y z -> z++class HasRange a where+  getRange :: a -> IndexRange+  adjustRange :: a -> Word32 -> a++instance HasRange Node where+  {-# INLINEABLE getRange #-}+  getRange = nRange++  {-# INLINEABLE adjustRange #-}+  adjustRange node@Node{nRange} newFirstIndex = node+    { nRange = nRange+        { irFirstIndex = newFirstIndex+        }+    }++instance HasRange TexturedNode where+  {-# INLINE getRange #-}+  getRange = getRange . tnNode++  {-# INLINE adjustRange #-}+  adjustRange tn@TexturedNode{tnNode} newFirstIndex = tn+    { tnNode = adjustRange tnNode newFirstIndex+    }
+ src/Resource/Mesh/Utils.hs view
@@ -0,0 +1,26 @@+module Resource.Mesh.Utils where++import RIO++import RIO.List.Partial (maximum)++import Geomancy (Transform, Vec4, vec4)+import Geomancy.Transform qualified as Transform++import Resource.Mesh.Types (AxisAligned(..), Measurements(..), middleAa, sizeAa)++aabbTranslate :: AxisAligned Measurements -> Transform+aabbTranslate measurements = Transform.translate aaX aaY aaZ+  where+    AxisAligned{..} = middleAa measurements++aabbScale :: AxisAligned Measurements -> Transform+aabbScale measurements = Transform.scale3 aaX aaY aaZ+  where+    AxisAligned{..} = sizeAa measurements++boundingSphere :: AxisAligned Measurements -> Vec4+boundingSphere measurements = vec4 aaX aaY aaZ radius+  where+    AxisAligned{..} = middleAa measurements+    radius = maximum (fmap mMax measurements)
+ src/Resource/Model.hs view
@@ -0,0 +1,175 @@+module Resource.Model where++import RIO++import Data.List qualified as List+import Data.Vector.Storable qualified as Storable+import Foreign (Storable(..))+import Vulkan.Core10 qualified as Vk++import Engine.Vulkan.Types (HasVulkan(..), Queues(..))+import Resource.Buffer qualified as Buffer++data Indexed storage pos attrs = Indexed+  { iPositions :: Buffer.Allocated storage pos+  , iAttrs     :: Buffer.Allocated storage attrs+  , iIndices   :: Buffer.Allocated storage Word32+  } deriving (Show)++data Vertex pos attrs = Vertex+  { vPosition :: pos+  , vAttrs    :: attrs+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++{-# INLINEABLE vertexAttrs #-}+vertexAttrs :: (pos -> a -> b) -> [Vertex pos a] -> [Vertex pos b]+vertexAttrs inject vertices = do+  v@Vertex{..} <- vertices+  pure v+    { vAttrs = inject vPosition vAttrs+    }++{-# INLINEABLE vertexAttrsPos #-}+vertexAttrsPos :: (pos -> a) -> [pos] -> [Vertex pos a]+vertexAttrsPos inject positions = do+  pos <- positions+  pure Vertex+    { vPosition = pos+    , vAttrs    = inject pos+    }++class HasVertexBuffers a where+  type VertexBuffersOf a+  getVertexBuffers :: a -> [Vk.Buffer]+  getInstanceCount :: a -> Word32++instance HasVertexBuffers () where+  type VertexBuffersOf () = ()++  {-# INLINE getVertexBuffers #-}+  getVertexBuffers () = []++  {-# INLINE getInstanceCount #-}+  getInstanceCount () = 1++instance HasVertexBuffers (Buffer.Allocated store a) where+  type VertexBuffersOf (Buffer.Allocated store a) = a++  {-# INLINE getVertexBuffers #-}+  getVertexBuffers Buffer.Allocated{aBuffer} = [aBuffer]++  {-# INLINE getInstanceCount #-}+  getInstanceCount = Buffer.aUsed++data IndexRange = IndexRange+  { irFirstIndex :: Word32+  , irIndexCount :: Word32+  }+  deriving (Eq, Ord, Show)++instance Storable IndexRange where+  alignment ~_ = 4++  sizeOf ~_ = 8++  peek ptr = do+    irFirstIndex <- peekByteOff ptr 0+    irIndexCount <- peekByteOff ptr 4+    pure IndexRange{..}++  poke ptr IndexRange{..} = do+    pokeByteOff ptr 0 irFirstIndex+    pokeByteOff ptr 4 irIndexCount++createStagedL+  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)+  => context+  -> Queues Vk.CommandPool+  -> [Vertex pos attrs]+  -> Maybe [Word32]+  -> io (Indexed 'Buffer.Staged pos attrs)+createStagedL context pool vertices mindices = createStaged context pool pv av iv+  where+    pv = Storable.fromList ps+    av = Storable.fromList as++    iv = case mindices of+      Just is ->+        Storable.fromList is+      Nothing ->+        -- TODO: add vertex deduplication+        Storable.generate (Storable.length pv) fromIntegral++    (ps, as) = List.unzip do+      Vertex{..} <- vertices+      pure (vPosition, vAttrs)++createStaged+  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)+  => context+  -> Queues Vk.CommandPool+  -> Storable.Vector pos+  -> Storable.Vector attrs+  -> Storable.Vector Word32+  -> io (Indexed 'Buffer.Staged pos attrs)+createStaged context pool pv av iv = do+  positions <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 pv+  attrs     <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 av+  indices   <- Buffer.createStaged context pool Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  0 iv+  pure Indexed+    { iPositions = positions+    , iAttrs     = attrs+    , iIndices   = indices+    }++createCoherentEmpty+  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)+  => context+  -> Int+  -> io (Indexed 'Buffer.Coherent pos attrs)+createCoherentEmpty ctx initialSize = Indexed+  <$> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty+  <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty+  <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  initialSize mempty++destroyIndexed+  :: (HasVulkan context, MonadUnliftIO io)+  => context+  -> Indexed storage pos attrs+  -> io ()+destroyIndexed ctx Indexed{..} = do+  Buffer.destroyAll ctx [iPositions]+  Buffer.destroyAll ctx [iAttrs]+  Buffer.destroyAll ctx [iIndices]++updateCoherent+  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)+  => context+  -> [Vertex pos attrs]+  -> Indexed 'Buffer.Coherent pos attrs+  -> io (Indexed 'Buffer.Coherent pos attrs)+updateCoherent ctx vertices old = do+  Indexed{..} <- pick+  Indexed+    <$> Buffer.updateCoherent pv iPositions+    <*> Buffer.updateCoherent av iAttrs+    <*> Buffer.updateCoherent iv iIndices+  where+    pick =+      if oldSize > newSize then+        pure old+      else do+        destroyIndexed ctx old+        createCoherentEmpty ctx (max newSize $ oldSize * 2)++    oldSize = Buffer.aCapacity $ iIndices old+    newSize = Storable.length pv++    pv = Storable.fromList ps+    av = Storable.fromList as++    iv = Storable.generate newSize fromIntegral++    (ps, as) = List.unzip do+      Vertex{..} <- vertices+      pure (vPosition, vAttrs)
+ src/Resource/Static.hs view
@@ -0,0 +1,132 @@+module Resource.Static where++import RIO++import Data.Char (isDigit, isUpper, toUpper)+import Language.Haskell.TH (Q, Dec)+import Language.Haskell.TH.Syntax (qRunIO)+import RIO.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)+import RIO.FilePath (combine, joinPath)+import RIO.State (StateT, evalStateT, get, put)++import qualified Language.Haskell.TH.Syntax as TH+import qualified RIO.List as List+import qualified RIO.Map as Map++data Scope+  = Files+  | Dirs+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)++filePaths :: Scope -> FilePath -> Q [Dec]+filePaths = mkDeclsWith mkPattern+  where+    mkPattern fp fs = do+      let name = TH.mkName "paths"++      sigType <- [t| [FilePath] |]++      let+        body = TH.ListE do+          segments <- List.sort fs+          pure . TH.LitE . TH.StringL $+            joinPath (fp : segments)++      pure+        [ TH.SigD name sigType+        , TH.FunD name [TH.Clause [] (TH.NormalB body) []]+        ]++filePatterns :: Scope -> FilePath -> Q [Dec]+filePatterns = mkDeclsWith mkPattern+  where+    mkPattern fp fs =+      fmap concat $ for fs \segments -> do+        let+          name =+            TH.mkName . map (replace . toUpper) $+              List.intercalate "_" segments++        patType <- [t| FilePath |]+        let pat = TH.LitP . TH.StringL $ joinPath (fp : segments)++        pure+          [ TH.PatSynSigD name patType+          , TH.PatSynD name (TH.PrefixPatSyn []) TH.ImplBidir pat+          ]++    replace c =+      if isUpper c || isDigit c then+        c+      else+        '_'++mkDeclsWith+  :: (FilePath -> [[String]] -> Q [Dec])+  -> Scope+  -> FilePath+  -> Q [Dec]+mkDeclsWith mkDecl scope fp =+  qRunIO (getFileListPieces scope fp) >>= mkDecl fp++-- XXX: Initially sourced from yesod-static+getFileListPieces :: Scope -> FilePath -> IO [[String]]+getFileListPieces scope rootPath = evalStateT (go id rootPath) mempty+  where+    go+      :: ([String] -> [String])+      -> String+      -> StateT (Map.Map String String) IO [[String]]+    go prefixF parentPath = do+      let expandPath = combine parentPath+      rawContents <- liftIO $ getDirectoryContents parentPath+      (dirs, files) <- foldM (partitionContents expandPath) (mempty, mempty) $+        filter notHidden rawContents++      inner <- for dirs \(path, fullPath) ->+        go (prefixF . (:) path) fullPath++      let collect = traverse $ traverse dedupe . prefixF . pure+      current <- case scope of+        Dirs ->+          collect $ map snd dirs+        Files -> do+          collect files++      pure $ concat (current : inner)++    partitionContents expandPath acc@(accDirs, accFiles) path = do+      let fullPath = expandPath path+      isDir <- doesDirectoryExist fullPath+      if isDir then+        pure+          ( (path, fullPath) : accDirs+          , accFiles+          )+      else do+        isFile <- doesFileExist fullPath+        if isFile then+          pure+            ( accDirs+            , path : accFiles+            )+        else+          -- XXX: skip weird stuff+          pure acc++    -- | Reuse data buffers for identical strings+    dedupe :: String -> StateT (Map String String) IO String+    dedupe s = do+      m <- get+      case Map.lookup s m of+        Just seen ->+          pure seen+        Nothing -> do+          put $ Map.insert s s m+          pure s++    notHidden :: FilePath -> Bool+    notHidden = \case+      "tmp"   -> False+      '.' : _ -> False+      _       -> True
+ src/Resource/Texture.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Resource.Texture+  ( Texture(..)+  , destroy++  , TextureError(..)+    -- * Texture types+  , Flat+  , CubeMap+  , ArrayOf+  , TextureLayers(..)++    -- * Utilities+  , allocateCollectionWith+  , allocateTextureWith+  , debugNameCollection+  , TextureLoader++  , createImageView+  , imageCI+  , imageAllocationCI+  , stageBufferCI+  , stageAllocationCI+  ) where++import RIO++import Data.Bits ((.|.))+import Data.List qualified as List+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (Nat, KnownNat, natVal)+import RIO.FilePath (takeBaseName)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::))+import Vulkan.Utils.Debug qualified as Debug+import Vulkan.Zero (zero)+import VulkanMemoryAllocator qualified as VMA++import Engine.Vulkan.Types (HasVulkan(getDevice), MonadVulkan, Queues)+import Resource.Collection qualified as Collection+import Resource.Image (AllocatedImage(..), destroyAllocatedImage, subresource)+import Resource.Image qualified as Image++data TextureError+  = LoadError Int64 Text+  | LayerError Word32 Word32+  | MipLevelsError Word32 Int+  | ArrayError Word32 Word32+  deriving (Eq, Ord, Show)++instance Exception TextureError++data Texture a = Texture+  { tFormat         :: Vk.Format+  , tMipLevels      :: Word32+  , tLayers         :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@+  , tAllocatedImage :: AllocatedImage+  }+  deriving (Show)++data CubeMap+data Flat+data ArrayOf (layers :: Nat)++-- | Number of expected texture layers to load from resource.+class TextureLayers a where+  textureLayers :: Word32++instance TextureLayers CubeMap where+  textureLayers = 6++instance TextureLayers Flat where+  textureLayers = 1++instance KnownNat n => TextureLayers (ArrayOf n) where+  textureLayers = fromInteger $ natVal (Proxy @n)++type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers)++type TextureLoaderAction m layers = FilePath -> m (Texture layers)++-- * Allocation wrappers++allocateCollectionWith+  :: (Resource.MonadResource m, MonadVulkan env m, Traversable t)+  => TextureLoaderAction m layers+  -> t FilePath+  -> m (Resource.ReleaseKey, t (Texture layers))+allocateCollectionWith action collection = do+  res <- traverse (allocateTextureWith action) collection+  key <- Resource.register $+    traverse_ (Resource.release . fst) res+  pure (key, fmap snd res)++allocateTextureWith+  :: (Resource.MonadResource m, MonadVulkan env m)+  => TextureLoaderAction m layers+  -> FilePath+  -> m (Resource.ReleaseKey, Texture layers)+allocateTextureWith action path = do+  context <- ask+  createTexture <- toIO $ action path+  Resource.allocate createTexture (destroy context)++debugNameCollection+  :: ( Traversable t+     , MonadVulkan env m+     , HasLogFunc env+     , HasCallStack+     )+  => t (Texture layers)+  -> t FilePath+  -> m ()+debugNameCollection textures paths = do+  device <- asks getDevice+  for_ names \((ix, path), Texture{tAllocatedImage}) -> do+    withFrozenCallStack . logDebug $ displayShow (ix, path)+    Debug.nameObject device (Image.aiImage tAllocatedImage) $+      fromString $ show @Natural ix <> ":" <> takeBaseName path+  where+    names = List.zip+      (toList $ Collection.enumerate paths)+      (toList textures)++-- * Implementation++destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io ()+destroy context Texture{tAllocatedImage} =+  destroyAllocatedImage context tAllocatedImage++createImageView+  :: (MonadIO io, HasVulkan context)+  => context+  -> Vk.Image+  -> Vk.Format+  -> "mip levels" ::: Word32+  -> "array layers" ::: Word32+  -> io Vk.ImageView+createImageView context image format mipLevels arrayLayers =+  Vk.createImageView (getDevice context) imageViewCI Nothing+  where+    imageViewCI = zero+      { Vk.image            = image+      , Vk.viewType         = viewType+      , Vk.format           = format+      , Vk.components       = zero+      , Vk.subresourceRange = colorRange+      }++    viewType =+      if arrayLayers == 6 then+        Vk.IMAGE_VIEW_TYPE_CUBE+      else+        Vk.IMAGE_VIEW_TYPE_2D++    colorRange =+      subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels arrayLayers++imageCI :: Vk.Format -> Vk.Extent3D -> Word32 -> Word32 -> Vk.ImageCreateInfo '[]+imageCI format extent mipLevels arrayLayers = zero+  { Vk.flags         = flags+  , Vk.imageType     = Vk.IMAGE_TYPE_2D+  , Vk.format        = format+  , Vk.extent        = extent+  , Vk.mipLevels     = mipLevels+  , Vk.arrayLayers   = if isCube then 6 else arrayLayers+  , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL+  , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED+  , Vk.usage         = usage+  , Vk.sharingMode   = Vk.SHARING_MODE_EXCLUSIVE+  , Vk.samples       = Vk.SAMPLE_COUNT_1_BIT -- XXX: no multisampling here+  }+  where+    isCube =+      arrayLayers == 6++    usage =+      Vk.IMAGE_USAGE_SAMPLED_BIT .|.  -- Sampler+      Vk.IMAGE_USAGE_TRANSFER_DST_BIT -- Staging++    flags =+      if isCube then+        Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT+      else+        zero++imageAllocationCI :: VMA.AllocationCreateInfo+imageAllocationCI = zero+  { VMA.usage         = VMA.MEMORY_USAGE_GPU_ONLY+  , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT+  }++stageBufferCI :: Integral a => a -> Vk.BufferCreateInfo '[]+stageBufferCI pixelBytes = zero+  { Vk.size        = fromIntegral pixelBytes+  , Vk.usage       = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT+  , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE+  }++stageAllocationCI :: VMA.AllocationCreateInfo+stageAllocationCI = zero+  { VMA.flags         = VMA.ALLOCATION_CREATE_MAPPED_BIT+  , VMA.usage         = VMA.MEMORY_USAGE_CPU_TO_GPU+  , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT+  }
+ src/Resource/Texture/Ktx1.hs view
@@ -0,0 +1,197 @@+module Resource.Texture.Ktx1+  ( createTexture+  ) where++import RIO++import Codec.Ktx qualified as Ktx1+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Foreign qualified+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.FromGL qualified as FromGL+import VulkanMemoryAllocator qualified as VMA++import Engine.Types (StageRIO)+import Engine.Vulkan.Types (HasVulkan(..), Queues)+import Resource.Compressed.Zstd qualified as Zstd+import Resource.Image (AllocatedImage(..))+import Resource.Image qualified as Image+import Resource.Texture (Texture(..), TextureLayers(..))+import Resource.Texture qualified as Texture++createTexture+  :: forall a st . (TextureLayers a)+  => Queues Vk.CommandPool+  -> FilePath+  -> StageRIO st (Texture a)+createTexture pool path = do+  context <- ask+  let vma = getAllocator context++  logInfo $ "Loading " <> fromString path+  loader path >>= \case+    Left (offset, err) -> do+      logError $ "Texture load error: " <> fromString err+      throwM $ Texture.LoadError offset (Text.pack err)+    Right Ktx1.Ktx{header, images=ktxImages} -> do+      let+        skipMips = 0 -- DEBUG: Vector.length ktxImages `div` 2+        mipsSkipped = min (Vector.length ktxImages - 1) skipMips+        images = Vector.drop mipsSkipped ktxImages+        mipLevels = Ktx1.numberOfMipmapLevels header - fromIntegral mipsSkipped++      when (Vector.null images) $+        throwM $ Texture.LoadError 0 "At least one image must be present in KTX"++      unless (fromIntegral mipLevels == Vector.length images) $+        throwM $ Texture.MipLevelsError mipLevels (Vector.length images)++      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vk_format.h#L676+      format <- case Ktx1.glInternalFormat header of+        -- XXX: Force all BC7s to SRGB+        36492 ->+          pure Vk.FORMAT_BC7_SRGB_BLOCK+        other ->+          case FromGL.internalFormat other of+            Nothing ->+              error $ "Unexpected glInternalFormat: " <> show other -- TODO: throwIo+            Just fmt ->+              -- XXX: going in blind+              pure fmt+      logDebug $ mconcat+        [ "Loading format "+        , display $ Ktx1.glInternalFormat header+        , " as "+        , displayShow format+        ]++      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vkloader.c#L552+      let+        extent = Vk.Extent3D+          { Vk.width  = Ktx1.pixelWidth header `Foreign.shiftR` mipsSkipped+          , Vk.height = Ktx1.pixelHeight header `Foreign.shiftR` mipsSkipped+          , Vk.depth  = max 1 $ Ktx1.pixelDepth header+          }+        arrayLayers = max 1 $ Ktx1.numberOfArrayElements header++      -- TODO: basisu can encode movies as arrays, this could be handy+      unless (arrayLayers == 1) do+        logError "TODO: arrayLayers > 1"+        throwM $ Texture.ArrayError 1 arrayLayers++      let+        numLayers = Ktx1.numberOfFaces header+        mipSizes = fmap ((*) numLayers . Ktx1.imageSize) images++        offsets' = Vector.scanl' (+) 0 mipSizes+        totalSize = Vector.last offsets'+        offsets = Vector.init offsets'++      logDebug $ "mipSizes: " <> displayShow mipSizes+      logDebug $ "offsets: " <> displayShow offsets++      {- XXX:+        Image created before staging buffer due to `Image.copyBufferToImage`+        issued inside `VMA.withBuffer` bracket.+      -}+      (image, allocation, _info) <- VMA.createImage+        vma+        (Texture.imageCI format extent mipLevels numLayers)+        Texture.imageAllocationCI++      Image.transitionImageLayout+        context+        pool+        image+        mipLevels+        numLayers -- XXX: arrayLayers is always 0 for now+        format+        Vk.IMAGE_LAYOUT_UNDEFINED+        Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL++      unless (numLayers == textureLayers @a) $+        throwM $ Texture.ArrayError (textureLayers @a) numLayers++      VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do+        let ixMipImages = Vector.zip3 (Vector.fromList [0..]) offsets images+        Vector.forM_ ixMipImages \(mipIx, offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do+          let ixArrayElements = Vector.zip (Vector.fromList [0..]) arrayElements+          Vector.forM_ ixArrayElements \(arrayIx, Ktx1.ArrayElement{faces}) -> do+            let ixFaces = Vector.zip (Vector.fromList [0..]) faces+            Vector.forM_ ixFaces \(faceIx, Ktx1.Face{zSlices}) -> do+              let ixSlices = Vector.zip (Vector.fromList [0..]) zSlices+              Vector.forM_ ixSlices \(sliceIx, Ktx1.ZSlice{block}) -> do+                let+                  indices = mconcat+                    [ "["+                    , " mip:" <> display @Word32 mipIx+                    , " arr:" <> display @Word32 arrayIx+                    , " fac:" <> display @Word32 faceIx+                    , " slc:" <> display @Word32 sliceIx+                    , " ]"+                    ]+                let blockOffset = offset + faceIx * imageSize+                let sectionPtr = Foreign.plusPtr (VMA.mappedData stageInfo) (fromIntegral blockOffset)+                logDebug $ mconcat+                  [ indices+                  , " base offset = "+                  , display offset+                  , " image offset = "+                  , display $ faceIx * imageSize+                  , " image size = "+                  , display imageSize+                  ]+                liftIO $ unsafeUseAsCStringLen block \(pixelsPtr, pixelBytes) -> do+                  if pixelBytes /= fromIntegral imageSize then+                    error "assert: MipLevel.imageSize matches block.pixelBytes"+                  else+                    -- traceShowM (sectionPtr, pixelBytes)+                    Foreign.copyBytes sectionPtr (Foreign.castPtr pixelsPtr) pixelBytes++        VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE++        -- XXX: copying to image while the staging buffer is still alive+        Image.copyBufferToImage+          context+          pool+          staging+          image+          extent+          offsets+          numLayers++      -- XXX: staging buffer is gone++      Image.transitionImageLayout+        context+        pool+        image+        mipLevels+        numLayers -- XXX: arrayLayers is always 0 for now+        format+        Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+        Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL++      imageView <- Texture.createImageView+        context+        image+        format+        mipLevels+        numLayers++      let+        allocatedImage = AllocatedImage+          { aiAllocation = allocation+          , aiImage      = image+          , aiImageView  = imageView+          }+      pure Texture+        { tFormat         = format+        , tMipLevels      = mipLevels+        , tLayers         = numLayers+        , tAllocatedImage = allocatedImage+        }+  where+    loader = liftIO . Zstd.fromFileWith (pure . Ktx1.fromByteString) Ktx1.fromFile