Fix missing headers in source dist (#71)

Fixes #50 again

ChangeLog.md

@@ -0,0 +1,12 @@
+# Changelog for dear-imgui
+
+## [1.0.1] Initial Hackage release
+
+- Fixed missing headers in source dist.
+
+## [1.0.0]
+
+Initial Hackage release based on 1.83.
+
+[1.0.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.0
+[1.0.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.1

README.md

@@ -25,7 +25,7 @@ OpenGL:
 
 ```
 package dear-imgui
-  flags: +sdl +opengl
+  flags: +sdl +opengl3
 ```
 
 With this done, the following module is the "Hello, World!" of ImGui:

cabal.project

@@ -1,3 +1,3 @@
 packages: *.cabal
 package dear-imgui
-  flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan
+  flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan +examples

dear-imgui.cabal

@@ -1,9 +1,32 @@
 cabal-version: 3.0
+
 name: dear-imgui
-version: 1.0.0
+version: 1.0.1
+author: Oliver Charles
+maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com
+license: BSD-3-Clause
+
+category: Graphics
+synopsis: Haskell bindings for Dear ImGui.
+description:
+  The package supports multiple rendering backends.
+  Set package flags according to your needs.
+
 build-type: Simple
-data-files:
+extra-source-files:
-  imgui/imgui.h
+  README.md,
+  ChangeLog.md
+
+extra-source-files:
+  imgui/*.h,
+  imgui/backends/*.h,
+  imgui/backends/*.mm,
+  imgui/imconfig.h,
+  imgui/LICENSE.txt
+
+source-repository head
+  type: git
+  location: https://github.com/haskell-game/dear-imgui.hs
 
 flag opengl2
   description:
@@ -11,7 +34,7 @@ flag opengl2
   default:
     False
   manual:
-    False
+    True
 
 flag opengl3
   description:
@@ -19,7 +42,7 @@ flag opengl3
   default:
     True
   manual:
-    False
+    True
 
 flag vulkan
   description:
@@ -35,7 +58,7 @@ flag sdl
   default:
     True
   manual:
-    False
+    True
 
 flag glfw
   description:
@@ -45,6 +68,14 @@ flag glfw
   manual:
     True
 
+flag examples
+  description:
+    Build executable examples.
+  default:
+    False
+  manual:
+    True
+
 common common
   build-depends:
       base
@@ -60,6 +91,7 @@ library
     src
   exposed-modules:
     DearImGui
+    DearImGui.Raw
   other-modules:
     DearImGui.Context
     DearImGui.Enums
@@ -83,6 +115,7 @@ library
     , inline-c
     , inline-c-cpp
     , StateVar
+    , unliftio
 
   if flag(opengl2)
     exposed-modules:
@@ -97,16 +130,8 @@ library
       DearImGui.OpenGL3
     cxx-sources:
       imgui/backends/imgui_impl_opengl3.cpp
-    if os(windows)
+    pkgconfig-depends:
-      buildable:
+      glew
-        False
-    else
-      if os(darwin)
-        buildable:
-          False
-      else
-        pkgconfig-depends:
-          glew
 
   if flag(vulkan)
     exposed-modules:
@@ -183,16 +208,20 @@ library dear-imgui-generator
   build-depends:
       template-haskell
         >= 2.15 && < 2.19
+    , containers
+       ^>= 0.6.2.1
     , directory
         >= 1.3 && < 1.4
     , filepath
         >= 1.4 && < 1.5
+    , inline-c
+        >= 0.9.0.0 && < 0.10
     , megaparsec
         >= 9.0 && < 9.1
     , parser-combinators
         >= 1.2.0 && < 1.3
     , scientific
-        >= 0.3.6.2 && < 0.3.7
+        >= 0.3.6.2 && < 0.3.8
     , text
         >= 1.2.4 && < 1.3
     , th-lift
@@ -200,27 +229,35 @@ library dear-imgui-generator
     , transformers
         >= 0.5.6 && < 0.6
     , unordered-containers
-        >= 0.2.11 && < 0.2.14
+        >= 0.2.11 && < 0.2.15
 
 executable test
   import: common
   main-is: Main.hs
   default-language: Haskell2010
-  build-depends: base, sdl2, gl, dear-imgui
   ghc-options: -Wall
+  if (!flag(examples) || !flag(sdl) || !flag(opengl2))
+    buildable: False
+  else
+    build-depends: base, sdl2, gl, dear-imgui
 
 executable glfw
   main-is: Main.hs
   hs-source-dirs: examples/glfw
   default-language: Haskell2010
-  build-depends: base, GLFW-b, gl, dear-imgui, managed
   ghc-options: -Wall
+  if (!flag(examples) || !flag(glfw) || !flag(opengl2))
+    buildable: False
+  else
+    build-depends: base, GLFW-b, gl, dear-imgui, managed
 
 executable readme
   import: common
   main-is: Readme.hs
   hs-source-dirs: examples
   build-depends: sdl2, gl, dear-imgui, managed
+  if (!flag(examples) || !flag(sdl) || !flag(opengl2))
+    buildable: False
 
 executable vulkan
   import: common
@@ -228,30 +265,33 @@ executable vulkan
   other-modules: Attachments, Backend, Input, Util
   hs-source-dirs: examples/vulkan
   default-language: Haskell2010
-  build-depends:
-      dear-imgui
-    , bytestring
-        >= 0.10.10.0 && < 0.12
-    , containers
-       ^>= 0.6.2.1
-    , logging-effect
-       ^>= 1.3.12
-    , resourcet
-       ^>= 1.2.4.2
-    , sdl2
-       ^>= 2.5.3.0
-    , text-short
-       ^>= 0.1.3
-    , transformers
-       ^>= 0.5.6.2
-    , unliftio
-        >= 0.2.13 && < 0.2.15
-    , unliftio-core
-       ^>= 0.2.0.1
-    , vector
-       ^>= 0.12.1.2
-    , vulkan
-       ^>= 3.9
-    , vulkan-utils
-       ^>= 0.4.1
   ghc-options: -Wall
+  if (!flag(examples) || !flag(sdl) || !flag(vulkan))
+    buildable: False
+  else
+    build-depends:
+        dear-imgui
+      , bytestring
+          >= 0.10.10.0 && < 0.12
+      , containers
+         ^>= 0.6.2.1
+      , logging-effect
+         ^>= 1.3.12
+      , resourcet
+         ^>= 1.2.4.2
+      , sdl2
+         ^>= 2.5.3.0
+      , text-short
+         ^>= 0.1.3
+      , transformers
+         ^>= 0.5.6.2
+      , unliftio
+          >= 0.2.13 && < 0.2.19
+      , unliftio-core
+         ^>= 0.2.0.1
+      , vector
+         ^>= 0.12.1.2
+      , vulkan
+         ^>= 3.9
+      , vulkan-utils
+         ^>= 0.4.1

examples/Readme.hs

@@ -55,7 +55,7 @@ mainLoop w = do
   newFrame
 
   -- Build the GUI
-  bracket_ (begin "Hello, ImGui!") end do
+  withWindowOpen "Hello, ImGui!" do
     -- Add a text widget
     text "Hello, ImGui!"
 

generator/DearImGui/Generator.hs

@@ -6,21 +6,33 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module DearImGui.Generator
-  ( declareEnumerations )
+  ( declareEnumerations, enumerationsTypesTable )
   where
 
 -- base
+import Control.Arrow
+  ( second )
 import Data.Coerce
   ( coerce )
 import Data.Bits
   ( Bits )
 import Data.Foldable
   ( toList )
+import qualified Data.List.NonEmpty as NonEmpty
+  ( head )
+import Data.String
+  ( fromString )
 import Data.Traversable
   ( for )
 import Foreign.Storable
   ( Storable )
 
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( fromList )
+
 -- directory
 import System.Directory
   ( canonicalizePath )
@@ -29,9 +41,12 @@ import System.Directory
 import System.FilePath
   ( takeDirectory )
 
+-- inline-c
+import qualified Language.C.Types as InlineC
+  ( TypeSpecifier(TypeName) )
+
 -- megaparsec
 import qualified Text.Megaparsec as Megaparsec
-  ( ParseErrorBundle(bundleErrors), parse, parseErrorPretty )
 
 -- template-haskell
 import qualified Language.Haskell.TH        as TH
@@ -47,53 +62,68 @@ import qualified Data.Text.IO as Text
 import qualified DearImGui.Generator.Parser as Parser
   ( headers )
 import DearImGui.Generator.Tokeniser
-  ( tokenise )
+  ( Tok, tokenise )
 import DearImGui.Generator.Types
-  ( Comment(..), Enumeration(..), Headers(..) )
+  ( Comment(..), Enumeration(..), Headers(..)
+  , generateNames
+  )
 
 --------------------------------------------------------------------------------
 -- Obtaining parsed header data.
 
-headers :: Headers
+headers :: Headers ( TH.Name, TH.Name )
 headers = $( do
   currentPath <- TH.loc_filename <$> TH.location
-  TH.lift =<< TH.runIO do
+  basicHeaders <- TH.runIO do
     headersPath  <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" )
     headersSource <- Text.readFile headersPath
     tokens <- case tokenise headersSource of
       Left  err  -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err )
       Right toks -> pure toks
     case Megaparsec.parse Parser.headers "" tokens of
-      Left  err -> error $
+      Left  err -> do
-        "Couldn't parse Dear ImGui headers:\n\n" <>
+        let
-        ( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) )
+          errorPos :: Int
+          errorPos = Megaparsec.errorOffset . NonEmpty.head $ Megaparsec.bundleErrors err
+          prev, rest :: [ Tok ]
+          ( prev, rest ) = second ( take 15 ) . splitAt 5 . drop ( errorPos - 5 ) $ tokens
+        error $
+          "Couldn't parse Dear ImGui headers:\n\n" <>
+          ( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) ) <> "\n" <>
+          ( unlines ( map show prev ) <> "\n\n" <> unlines ( map show rest ) )
       Right res -> pure res
+  TH.lift $ generateNames basicHeaders
   )
 
 --------------------------------------------------------------------------------
 -- Generating TH splices.
 
+enumerationsTypesTable :: Map InlineC.TypeSpecifier ( TH.Q TH.Type )
+enumerationsTypesTable = Map.fromList . map mkTypePair $ enums headers
+  where
+    mkTypePair :: Enumeration ( TH.Name, TH.Name ) -> ( InlineC.TypeSpecifier, TH.Q TH.Type )
+    mkTypePair ( Enumeration { enumName, enumTypeName } ) =
+      ( InlineC.TypeName $ fromString ( Text.unpack enumName )
+      , TH.conT ( fst $ enumTypeName )
+      )
+
 declareEnumerations :: TH.Name -> TH.Name -> TH.Q [ TH.Dec ]
 declareEnumerations finiteEnumName countName = do
   concat <$> mapM ( declareEnumeration finiteEnumName countName ) ( enums headers )
 
-declareEnumeration :: TH.Name -> TH.Name -> Enumeration -> TH.Q [ TH.Dec ]
+declareEnumeration :: TH.Name -> TH.Name -> Enumeration ( TH.Name, TH.Name ) -> TH.Q [ TH.Dec ]
 declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
   let
-    enumNameStr :: String
+    tyName, conName :: TH.Name
-    enumNameStr = Text.unpack enumName
+    ( tyName, conName ) = enumTypeName
     isFlagEnum :: Bool
     isFlagEnum = "Flags" `Text.isInfixOf` enumName
-  tyName  <- TH.newName enumNameStr
-
-  conName <- TH.newName enumNameStr
-  let
     newtypeCon :: TH.Q TH.Con
     newtypeCon =
       TH.normalC conName
         [ TH.bangType
           ( TH.bang TH.noSourceUnpackedness TH.noSourceStrictness )
-          ( TH.conT enumType )
+          ( TH.conT underlyingType )
         ]
     classes :: [ TH.Q TH.Type ]
     classes
@@ -103,14 +133,15 @@ declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
       = map TH.conT [ ''Eq, ''Ord, ''Storable ]
     derivClause :: TH.Q TH.DerivClause
     derivClause = TH.derivClause ( Just TH.NewtypeStrategy ) classes
+
   newtypeDecl <-
-#if MIN_VERSION_base(4,16,0)
+#if MIN_VERSION_template_haskell(2,18,0)
     ( if   null docs
       then TH.newtypeD
       else
         \ ctx name bndrs kd con derivs ->
-          TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, "", [] ) derivs
+          TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, Nothing, [] ) derivs
-            ( Text.unpack . Text.unlines . coerce $ docs )
+            ( Just . Text.unpack . Text.unlines . coerce $ docs )
     )
 #else
     TH.newtypeD
@@ -137,13 +168,13 @@ declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
     patName   <- TH.newName patNameStr
     patSynSig <- TH.patSynSigD patName ( TH.conT tyName )
     pat       <-
-#if MIN_VERSION_base(4,16,0)
+#if MIN_VERSION_template_haskell(2,18,0)
       ( if   Text.null patDoc
         then TH.patSynD
         else
           \ nm args dir pat ->
           TH.patSynD_doc nm args dir pat
-            ( Text.unpack patDoc ) []
+            ( Just $ Text.unpack patDoc ) []
       )
 #else
       TH.patSynD

generator/DearImGui/Generator/Parser.hs

@@ -75,7 +75,7 @@ import Data.HashMap.Strict
 import qualified Data.HashMap.Strict as HashMap
   ( fromList, insert, lookup )
 
--- dear-imgui-generator 
+-- dear-imgui-generator
 import DearImGui.Generator.Tokeniser
   ( Tok(..) )
 import DearImGui.Generator.Types
@@ -111,27 +111,46 @@ instance ShowErrorComponent CustomParseError where
 --------------------------------------------------------------------------------
 -- Parsing headers.
 
-headers :: MonadParsec CustomParseError [Tok] m => m Headers
+headers :: MonadParsec CustomParseError [Tok] m => m ( Headers () )
 headers = do
   _ <- skipManyTill anySingle ( namedSection "Header mess" )
+
   _ <- skipManyTill anySingle ( namedSection "Forward declarations" )
   ( _structNames, enumNamesAndTypes ) <- forwardDeclarations
+
   _ <- skipManyTill anySingle ( namedSection "Dear ImGui end-user API functions" )
+
   _ <- skipManyTill anySingle ( namedSection "Flags & Enumerations" )
-  ( _defines, enums ) <- partitionEithers <$>
+  ( _defines, basicEnums ) <- partitionEithers <$>
     manyTill
       (   ( Left  <$> try ignoreDefine )
       <|> ( Right <$> enumeration enumNamesAndTypes )
       )
       ( namedSection "Helpers: Memory allocations macros, ImVector<>" )
-  _ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
-  _ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
-  _ <- skipManyTill anySingle ( namedSection "Misc data structures" )
-  _ <- skipManyTill anySingle ( namedSection "Obsolete functions" )
-  _ <- skipManyTill anySingle ( namedSection "Helpers" )
-  _ <- skipManyTill anySingle ( namedSection "Drawing API" )
-  _ <- skipManyTill anySingle ( namedSection "Font API" )
 
+  _ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
+
+  _ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
+
+  _ <- skipManyTill anySingle ( namedSection "Misc data structures" )
+
+  _ <- skipManyTill anySingle ( namedSection "Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor)" )
+
+  _ <- skipManyTill anySingle ( namedSection "Drawing API (ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawListFlags, ImDrawList, ImDrawData)" )
+  skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
+  drawingEnums <- many ( enumeration enumNamesAndTypes )
+
+  _ <- skipManyTill anySingle ( namedSection "Font API (ImFontConfig, ImFontGlyph, ImFontAtlasFlags, ImFontAtlas, ImFontGlyphRangesBuilder, ImFont)" )
+  skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
+  fontEnums <- many ( enumeration enumNamesAndTypes )
+
+  _ <- skipManyTill anySingle ( namedSection "Viewports" )
+
+  _ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" )
+
+  let
+    enums :: [ Enumeration () ]
+    enums = basicEnums <> drawingEnums <> fontEnums
   pure ( Headers { enums } )
 
 --------------------------------------------------------------------------------
@@ -151,7 +170,7 @@ forwardDeclarations = do
   _ <- many comment
   enums <- many do
     keyword "typedef"
-    ty <- enumTypeName
+    ty <- cTypeName
     enumName <- identifier
     reservedSymbol ';'
     doc <- commentText <$> comment
@@ -159,8 +178,8 @@ forwardDeclarations = do
   -- Stopping after simple structs and enums for now.
   pure ( HashMap.fromList structs, HashMap.fromList enums )
 
-enumTypeName :: MonadParsec e [Tok] m => m TH.Name
+cTypeName :: MonadParsec e [Tok] m => m TH.Name
-enumTypeName = keyword "int" $> ''CInt
+cTypeName = keyword "int" $> ''CInt
 
 --------------------------------------------------------------------------------
 -- Parsing enumerations.
@@ -172,22 +191,26 @@ data EnumState = EnumState
   , hasExplicitCount :: Bool
   }
 
-enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m Enumeration
+enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
 enumeration enumNamesAndTypes = do
-  inlineDocs <- many comment
+  inlineDocs <- try do
-  keyword "enum"
+    inlineDocs <- many comment
+    keyword "enum"
+    pure inlineDocs
   fullEnumName <- identifier
   let
     enumName :: Text
     enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
-  ( enumType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
+    enumTypeName :: ()
+    enumTypeName = ()
+  ( underlyingType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
     Just res -> pure res
     Nothing  -> customFailure ( MissingForwardDeclaration { enumName } )
   let
     docs :: [Comment]
     docs = forwardDoc : CommentText "" : inlineDocs
   reservedSymbol '{'
-  ( patterns, EnumState { enumSize, hasExplicitCount } ) <- 
+  ( patterns, EnumState { enumSize, hasExplicitCount } ) <-
     ( `runStateT` EnumState { enumValues = mempty, currEnumTag = 0, enumSize = 0, hasExplicitCount = False } ) $
       catMaybes
           <$> many
@@ -222,11 +245,11 @@ patternNameAndValue
 patternNameAndValue enumName =
   try do
       sz <- count
-      modify' ( ( \ st -> st { enumSize = sz, hasExplicitCount = True } ) :: EnumState -> EnumState )
+      modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = sz, hasExplicitCount = True, .. } )
       pure Nothing
   <|> do
         pat@( _, val ) <- value
-        modify' ( \ st -> st { enumSize = ( enumSize :: EnumState -> Integer ) st + 1, currEnumTag = val + 1} )
+        modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = enumSize + 1, currEnumTag = val + 1, .. } )
         pure ( Just pat )
   where
     count :: StateT EnumState m Integer

generator/DearImGui/Generator/Types.hs

@@ -1,19 +1,27 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
 
 module DearImGui.Generator.Types where
 
+-- base
+import Data.Functor
+  ( (<&>) )
+
 -- template-haskell
+import qualified Language.Haskell.TH        as TH
 import qualified Language.Haskell.TH.Syntax as TH
-  ( Lift(..), Name(..) )
 
 -- text
 import Data.Text
   ( Text )
+import qualified Data.Text as Text
+  ( unpack )
 
 -- th-lift
 import Language.Haskell.TH.Lift
@@ -25,18 +33,33 @@ newtype Comment = CommentText { commentText :: Text }
   deriving stock   ( Show, TH.Lift )
   deriving newtype ( Eq, Ord )
 
-data Enumeration
+data Enumeration typeName
   = Enumeration
   { docs             :: ![Comment]
   , enumName         :: !Text
+  , enumTypeName     :: !typeName
   , enumSize         :: !Integer
-  , enumType         :: !TH.Name
+  , underlyingType   :: !TH.Name
   , hasExplicitCount :: !Bool
   , patterns         :: [ ( Text, Integer, Comment ) ]
   }
   deriving stock ( Show, TH.Lift )
 
-data Headers
+data Headers typeName
   = Headers
-  { enums :: [ Enumeration ] }
+  { enums :: [ Enumeration typeName ] }
   deriving stock ( Show, TH.Lift )
+
+generateNames :: Headers () -> Headers ( TH.Name, TH.Name )
+generateNames ( Headers { enums = basicEnums } ) = Headers { enums = namedEnums }
+  where
+    namedEnums :: [ Enumeration ( TH.Name, TH.Name ) ]
+    namedEnums = basicEnums <&> \ enum@( Enumeration { enumName } ) ->
+      let
+        enumNameStr :: String
+        enumNameStr = Text.unpack enumName
+        tyName, conName :: TH.Name
+        tyName  = TH.mkName enumNameStr
+        conName = TH.mkName enumNameStr
+      in
+        enum { enumTypeName = ( tyName, conName ) }

src/DearImGui/Context.hs

@@ -18,21 +18,19 @@ import Language.C.Types
   ( pattern TypeName )
 
 -- dear-imgui
-import DearImGui.Enums
 import DearImGui.Structs
 
+-- dear-imgui-generator
+import DearImGui.Generator
+  ( enumerationsTypesTable )
+
 --------------------------------------------------------------------------------
 
 imguiContext :: Context
 imguiContext = mempty
-  { ctxTypesTable = Map.fromList
+  { ctxTypesTable = enumerationsTypesTable <>
-      [ ( TypeName "ImGuiCol" , [t| ImGuiCol |] )
+    Map.fromList
-      , ( TypeName "ImGuiCond", [t| ImGuiCond |] )
+      [ ( TypeName "ImVec2", [t| ImVec2 |] )
-      , ( TypeName "ImGuiDir" , [t| ImGuiDir |] )
-      , ( TypeName "ImGuiStyleVar"    , [t| ImGuiStyleVar |] )
-      , ( TypeName "ImGuiTabBarFlags" , [t| ImGuiTabBarFlags |] )
-      , ( TypeName "ImGuiTabItemFlags", [t| ImGuiTabItemFlags |] )
-      , ( TypeName "ImVec2", [t| ImVec2 |] )
       , ( TypeName "ImVec3", [t| ImVec3 |] )
       , ( TypeName "ImVec4", [t| ImVec4 |] )
       ]

src/DearImGui/Vulkan.hs

@@ -12,6 +12,8 @@ Vulkan backend for Dear ImGui.
 module DearImGui.Vulkan
   ( InitInfo(..)
   , withVulkan
+  , vulkanInit
+  , vulkanShutdown
   , vulkanNewFrame
   , vulkanRenderDrawData
   , vulkanCreateFontsTexture
@@ -28,7 +30,7 @@ import Data.Word
 import Foreign.Marshal.Alloc
   ( alloca )
 import Foreign.Ptr
-  ( Ptr, freeHaskellFunPtr, nullPtr )
+  ( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
 import Foreign.Storable
   ( Storable(poke) )
 
@@ -83,7 +85,18 @@ data InitInfo =
 
 -- | Wraps @ImGui_ImplVulkan_Init@ and @ImGui_ImplVulkan_Shutdown@.
 withVulkan :: MonadUnliftIO m => InitInfo -> Vulkan.RenderPass -> ( Bool -> m a ) -> m a
-withVulkan ( InitInfo {..} ) renderPass action = do
+withVulkan initInfo renderPass action =
+  bracket
+    ( vulkanInit initInfo renderPass )
+    vulkanShutdown
+    ( \ ( _, initResult ) -> action initResult )
+
+-- | Wraps @ImGui_ImplVulkan_Init@.
+-- 
+-- Use 'vulkanShutdown' to clean up on shutdown.
+-- Prefer using 'withVulkan' when possible, as it automatically handles cleanup.
+vulkanInit :: MonadIO m => InitInfo -> Vulkan.RenderPass -> m (FunPtr (Vulkan.Result -> IO ()), Bool)
+vulkanInit ( InitInfo {..} ) renderPass = do
   let
     instancePtr :: Ptr Vulkan.Instance_T
     instancePtr = Vulkan.instanceHandle instance'
@@ -97,38 +110,39 @@ withVulkan ( InitInfo {..} ) renderPass action = do
     withCallbacks f = case mbAllocator of
       Nothing        -> f nullPtr
       Just callbacks -> alloca ( \ ptr -> poke ptr callbacks *> f ptr )
-  bracket
+  liftIO do
-    ( liftIO do
+    checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
-        checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
+    initResult <- withCallbacks \ callbacksPtr ->
-        initResult <- withCallbacks \ callbacksPtr ->
+        [C.block| bool {
-            [C.block| bool {
+          ImGui_ImplVulkan_InitInfo initInfo;
-              ImGui_ImplVulkan_InitInfo initInfo;
+          VkInstance instance = { $( VkInstance_T* instancePtr ) };
-              VkInstance instance = { $( VkInstance_T* instancePtr ) };
+          initInfo.Instance = instance;
-              initInfo.Instance = instance;
+          VkPhysicalDevice physicalDevice = { $( VkPhysicalDevice_T* physicalDevicePtr ) };
-              VkPhysicalDevice physicalDevice = { $( VkPhysicalDevice_T* physicalDevicePtr ) };
+          initInfo.PhysicalDevice = physicalDevice;
-              initInfo.PhysicalDevice = physicalDevice;
+          VkDevice device = { $( VkDevice_T* devicePtr ) };
-              VkDevice device = { $( VkDevice_T* devicePtr ) };
+          initInfo.Device = device;
-              initInfo.Device = device;
+          initInfo.QueueFamily = $(uint32_t queueFamily);
-              initInfo.QueueFamily = $(uint32_t queueFamily);
+          VkQueue queue = { $( VkQueue_T* queuePtr ) };
-              VkQueue queue = { $( VkQueue_T* queuePtr ) };
+          initInfo.Queue = queue;
-              initInfo.Queue = queue;
+          initInfo.PipelineCache = $(VkPipelineCache pipelineCache);
-              initInfo.PipelineCache = $(VkPipelineCache pipelineCache);
+          initInfo.DescriptorPool = $(VkDescriptorPool descriptorPool);
-              initInfo.DescriptorPool = $(VkDescriptorPool descriptorPool);
+          initInfo.Subpass = $(uint32_t subpass);
-              initInfo.Subpass = $(uint32_t subpass);
+          initInfo.MinImageCount = $(uint32_t minImageCount);
-              initInfo.MinImageCount = $(uint32_t minImageCount);
+          initInfo.ImageCount = $(uint32_t imageCount);
-              initInfo.ImageCount = $(uint32_t imageCount);
+          initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
-              initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
+          initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
-              initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
+          initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
-              initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
+          return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
-              return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
+        }|]
-            }|]
+    pure ( checkResultFunPtr, initResult /= 0 )
-        pure ( checkResultFunPtr, initResult /= 0 )
+
-    )
+-- | Wraps @ImGui_ImplVulkan_Shutdown@.
-    ( \ ( checkResultFunPtr, _ ) -> liftIO do
+--
-      [C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
+-- Counterpart to 'vulkanInit', for clean-up.
-      freeHaskellFunPtr checkResultFunPtr
+vulkanShutdown :: MonadIO m => (FunPtr a, b) -> m ()
-    )
+vulkanShutdown ( checkResultFunPtr, _ ) = liftIO do
-    ( \ ( _, initResult ) -> action initResult )
+  [C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
+  freeHaskellFunPtr checkResultFunPtr
 
 -- | Wraps @ImGui_ImplVulkan_NewFrame@.
 vulkanNewFrame :: MonadIO m => m ()