Bump upstream to v1.90.9 (#207)

* Bump upstream to v1.90.9 and fix parser
* Fix font and dynamic rendering breakage in vulkan backend

ChangeLog.md

@@ -1,5 +1,15 @@
 # Changelog for dear-imgui
 
+## [2.3.0]
+
+- `imgui` updated to [1.90.9].
+    * Breaking: `sdlRendererRenderDrawData` now required `Renderer` arg.
+    * Breaking: ImplVulkan removed command buffer for `ImGui_ImplVulkan_CreateFontsTexture`.
+    * Breaking: ImplVulkan removed command for `ImGui_ImplVulkan_DestroyFontUploadObjects`.
+      + Added `ImGui_ImplVulkan_DestroyFontsTexture`, but it shouldn't be needed as it is called from impl internals.
+    * Breaking: ImplVulkan moved RenderPass into InitInfo structure.
+      + Breaking: Haskell API is now using `Either RenderPass RenderingPipelineCreateInfo` to switch between RP/dynamic rendering.
+
 ## [2.2.1]
 
 - Added `DearImGui.SDL.Renderer` backend and `sdlrenderer` example.
@@ -125,7 +135,9 @@ Initial Hackage release based on [1.83].
 [2.1.3]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.1.3
 [2.2.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.2.0
 [2.2.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.2.1
+[2.3.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.3.0
 
+[1.90.9]: https://github.com/ocornut/imgui/releases/tag/v1.90.9
 [1.89.9]: https://github.com/ocornut/imgui/releases/tag/v1.89.9
 [1.87]: https://github.com/ocornut/imgui/releases/tag/v1.87
 [1.86]: https://github.com/ocornut/imgui/releases/tag/v1.86

dear-imgui.cabal

@@ -1,7 +1,7 @@
 cabal-version: 3.0
 
 name: dear-imgui
-version: 2.2.1
+version: 2.3.0
 author: Oliver Charles
 maintainer: [email protected], [email protected]
 license: BSD-3-Clause

examples/sdl/Renderer.hs

@@ -109,7 +109,7 @@ mainLoop renderer = do
     SDL.rendererDrawColor renderer $= V4 0 0 0 255
     SDL.clear renderer
     render
-    sdlRendererRenderDrawData =<< getDrawData
+    sdlRendererRenderDrawData renderer =<< getDrawData
     SDL.present renderer
 
     go refs

examples/vulkan/Main.hs

@@ -391,16 +391,15 @@ app = do
       , device
       , queueFamily
       , queue
-      , pipelineCache         = Vulkan.NULL_HANDLE
-      , descriptorPool        = imGuiDescriptorPool
-      , subpass               = 0
+      , pipelineCache  = Vulkan.NULL_HANDLE
+      , descriptorPool = imGuiDescriptorPool
+      , subpass        = 0
       , minImageCount
       , imageCount
-      , msaaSamples           = Vulkan.SAMPLE_COUNT_1_BIT
-      , mbAllocator           = Nothing
-      , useDynamicRendering   = False
-      , colorAttachmentFormat = Nothing
-      , checkResult           = \case { Vulkan.SUCCESS -> pure (); e -> throw $ Vulkan.VulkanException e }
+      , msaaSamples    = Vulkan.SAMPLE_COUNT_1_BIT
+      , mbAllocator    = Nothing
+      , rendering      = Left imGuiRenderPass
+      , checkResult    = \case { Vulkan.SUCCESS -> pure (); e -> throw $ Vulkan.VulkanException e }
       }
 
   logDebug "Initialising ImGui SDL2 for Vulkan"
@@ -409,7 +408,7 @@ app = do
     ( const ImGui.SDL.sdl2Shutdown )
 
   logDebug "Initialising ImGui for Vulkan"
-  ImGui.Vulkan.withVulkan initInfo imGuiRenderPass \ _ -> do
+  ImGui.Vulkan.withVulkan initInfo \ _ -> do
 
     logDebug "Running one-shot commands to upload ImGui textures"
     logDebug "Creating fence"
@@ -421,7 +420,9 @@ app = do
 
     logDebug "Recording one-shot commands"
     beginCommandBuffer oneshotCommandBuffer
-    _ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
+
+    logDebug "ImGui preparing fonts texture"
+    _ <- ImGui.Vulkan.vulkanCreateFontsTexture
 
     logDebug "Uploading texture"
     let textureSubresource = Vulkan.ImageSubresourceRange
@@ -497,8 +498,6 @@ app = do
     waitForFences device ( WaitAll [ fence ] )
 
     logDebug "Finished uploading font objects"
-    logDebug "Cleaning up one-shot commands"
-    ImGui.Vulkan.vulkanDestroyFontUploadObjects
     traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ]
 
     logDebug "Adding imgui texture"

generator/DearImGui/Generator/Parser.hs

@@ -27,15 +27,15 @@ import Data.Bits
 import Data.Char
   ( isSpace, toLower )
 import Data.Either
-  ( partitionEithers )
+  ( rights )
 import Data.Functor
   ( ($>) )
 import Data.Int
   ( Int64 )
 import Data.Maybe
   ( catMaybes, fromMaybe )
 import Foreign.C.Types
-  ( CInt )
+  ( CChar, CInt, CShort, CLLong, CUChar, CUShort, CUInt, CULLong )
 
 -- template-haskell
 import qualified Language.Haskell.TH as TH
@@ -44,7 +44,7 @@ import qualified Language.Haskell.TH as TH
 -- megaparsec
 import Text.Megaparsec
   ( MonadParsec(..), ShowErrorComponent(..)
-  , (<?>), anySingle, customFailure, single
+  , (<?>), anySingle, choice, customFailure, single
   )
 
 -- parser-combinators
@@ -126,13 +126,24 @@ headers = do
   _ <- skipManyTill anySingle ( namedSection "Dear ImGui end-user API functions" )
 
   _ <- skipManyTill anySingle ( namedSection "Flags & Enumerations" )
-  ( _defines, basicEnums ) <- partitionEithers <$>
+
+  basicEnums <- rights <$>
+    manyTill
+      (   ( Left  <$> try ignoreDefine )
+      <|> ( Left  <$> try cppConditional )
+      <|> ( Right <$> enumeration enumNamesAndTypes )
+      )
+      ( namedSection "Tables API flags and structures (ImGuiTableFlags, ImGuiTableColumnFlags, ImGuiTableRowFlags, ImGuiTableBgTarget, ImGuiTableSortSpecs, ImGuiTableColumnSortSpecs)" )
+
+  tableEnums <- rights <$>
     manyTill
       (   ( Left  <$> try ignoreDefine )
       <|> ( Left  <$> try cppConditional )
       <|> ( Right <$> enumeration enumNamesAndTypes )
       )
-      ( namedSection "Helpers: Memory allocations macros, ImVector<>" )
+      ( try $ many comment >> keyword "struct" >> identifier)
+
+  _ <- skipManyTill anySingle ( namedSection "Helpers: Memory allocations macros, ImVector<>" )
 
   _ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
 
@@ -158,7 +169,7 @@ headers = do
 
   let
     enums :: [ Enumeration () ]
-    enums = basicEnums <> drawingEnums <> fontEnums
+    enums = basicEnums <> tableEnums <> drawingEnums <> fontEnums
   pure ( Headers { enums } )
 
 --------------------------------------------------------------------------------
@@ -169,6 +180,15 @@ forwardDeclarations
   => m ( HashMap Text Comment, HashMap Text ( TH.Name, Comment ) )
 forwardDeclarations = do
   _ <- many comment
+  _scalars <- many do
+    try $ keyword "typedef"
+    signed <- try (keyword "signed" $> True) <|> (keyword "unsigned" $> False)
+    width <- try (keyword "int") <|> try (keyword "char") <|> try (keyword "short") <|> try (keyword "int") <|> (keyword "long" >> keyword "long")
+    typeName <- identifier
+    reservedSymbol ';'
+    doc <- comment
+    pure (typeName, (signed, width, doc))
+  _ <- many comment
   structs <- many do
     keyword "struct"
     structName <- identifier
@@ -177,6 +197,9 @@ forwardDeclarations = do
     pure ( structName, doc )
   _ <- many comment
   enums <- many do
+    _ <- try do
+      _ <- many comment
+      cppConditional <|> pure ()
     keyword "enum"
     enumName <- identifier
     symbol ":"
@@ -197,7 +220,23 @@ forwardDeclarations = do
   pure ( HashMap.fromList structs, HashMap.fromList (enums <> typedefs) )
 
 cTypeName :: MonadParsec e [Tok] m => m TH.Name
-cTypeName = keyword "int" $> ''CInt
+cTypeName =
+  choice
+    [ try $ (keyword "char") $> ''CChar
+    , try $ (keyword "signed" >> keyword "int") $> ''CInt
+    , try $ (keyword "unsigned" >> keyword "int") $> ''CUInt
+    , try $ (keyword "unsigned" >> keyword "char") $> ''CUChar
+    , try $ (identifier' "ImS8") $> ''CChar
+    , try $ (identifier' "ImU8") $> ''CUChar
+    , try $ (identifier' "ImS16") $> ''CShort
+    , try $ (identifier' "ImU16") $> ''CUShort
+    , try $ (identifier' "ImS32") $> ''CInt
+    , try $ (identifier' "ImU32") $> ''CUInt
+    , try $ (identifier' "ImS64") $> ''CLLong
+    , try $ (identifier' "ImU64") $> ''CULLong
+    , keyword "int" $> ''CInt
+    ]
+  <?> "cTypeName"
 
 --------------------------------------------------------------------------------
 -- Parsing enumerations.
@@ -211,6 +250,7 @@ data EnumState = EnumState
 
 enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
 enumeration enumNamesAndTypes = do
+  void $ many (try $ comment >> cppConditional)
   inlineDocs <- try do
     inlineDocs <- many comment
     keyword "enum"
@@ -331,13 +371,20 @@ comment = CommentText <$>
     <?> "comment"
 
 keyword :: MonadParsec e [ Tok ] m => Text -> m ()
-keyword kw = token ( \ case { Keyword kw' | kw == kw' -> Just (); _ -> Nothing } ) mempty
+keyword = void . keyword'
+
+keyword' :: MonadParsec e [ Tok ] m => Text -> m Text
+keyword' kw = token ( \ case { Keyword kw' | kw == kw' -> Just kw; _ -> Nothing } ) mempty
   <?> ( Text.unpack kw <> " (keyword)" )
 
 identifier :: MonadParsec e [ Tok ] m => m Text
 identifier = token ( \ case { Identifier i -> Just i; _ -> Nothing } ) mempty
   <?> "identifier"
 
+identifier' :: MonadParsec e [ Tok ] m => Text -> m Text
+identifier' ident = token ( \ case { Identifier i | i == ident -> Just ident; _ -> Nothing } ) mempty
+  <?> ( Text.unpack ident <> " (identifier)" )
+
 {-
 prefixedIdentifier :: MonadParsec e [ Tok ] m => Text -> m Text
 prefixedIdentifier prefix =
@@ -452,7 +499,7 @@ cppDirective f = token ( \case { BeginCPP a -> f a; _ -> Nothing } ) mempty
 
 cppConditional :: MonadParsec e [Tok] m => m ()
 cppConditional = do
-  void $ cppDirective ( \case { "ifdef" -> Just True; "ifndef" -> Just False; _ -> Nothing } )
+  void $ cppDirective ( \case { "if" -> Just True; "ifdef" -> Just True; "ifndef" -> Just False; _ -> Nothing } )
   -- assumes no nesting
   void $ skipManyTill anySingle ( cppDirective ( \case { "endif" -> Just (); _ -> Nothing } ) )
   void $ skipManyTill anySingle ( single EndCPPLine )

src/DearImGui/SDL/Renderer.hs

@@ -69,6 +69,6 @@ sdlRendererNewFrame = liftIO do
   [C.exp| void { ImGui_ImplSDLRenderer2_NewFrame(); } |]
 
 -- | Wraps @ImGui_ImplSDLRenderer2_RenderDrawData@.
-sdlRendererRenderDrawData :: MonadIO m => DrawData -> m ()
-sdlRendererRenderDrawData (DrawData ptr) = liftIO do
-  [C.exp| void { ImGui_ImplSDLRenderer2_RenderDrawData((ImDrawData*) $( void* ptr )) } |]
+sdlRendererRenderDrawData :: MonadIO m => Renderer -> DrawData -> m ()
+sdlRendererRenderDrawData (Renderer renderPtr) (DrawData ptr) = liftIO do
+  [C.exp| void { ImGui_ImplSDLRenderer2_RenderDrawData((ImDrawData*) $( void* ptr ), (SDL_Renderer*) $( void* renderPtr )) } |]