diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 3b36c93..0bc71b9 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -175,10 +175,14 @@ 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 diff --git a/generator/DearImGui/Generator.hs b/generator/DearImGui/Generator.hs index 431dc35..f2f2056 100644 --- a/generator/DearImGui/Generator.hs +++ b/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 $ - "Couldn't parse Dear ImGui headers:\n\n" <> - ( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) ) + Left err -> do + let + 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 - enumNameStr = Text.unpack enumName + tyName, conName :: TH.Name + ( 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,6 +133,7 @@ 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 null docs diff --git a/generator/DearImGui/Generator/Parser.hs b/generator/DearImGui/Generator/Parser.hs index 13b5994..684c06e 100644 --- a/generator/DearImGui/Generator/Parser.hs +++ b/generator/DearImGui/Generator/Parser.hs @@ -111,27 +111,44 @@ 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 "Obsolete functions" ) + + _ <- skipManyTill anySingle ( namedSection "Helpers" ) + + _ <- skipManyTill anySingle ( namedSection "Drawing API" ) + skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" ) + drawingEnums <- many ( enumeration enumNamesAndTypes ) + + _ <- skipManyTill anySingle ( namedSection "Font API" ) + skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" ) + fontEnums <- many ( enumeration enumNamesAndTypes ) + + let + enums :: [ Enumeration () ] + enums = basicEnums <> drawingEnums <> fontEnums pure ( Headers { enums } ) -------------------------------------------------------------------------------- @@ -151,7 +168,7 @@ forwardDeclarations = do _ <- many comment enums <- many do keyword "typedef" - ty <- enumTypeName + ty <- cTypeName enumName <- identifier reservedSymbol ';' doc <- commentText <$> comment @@ -159,8 +176,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 -enumTypeName = keyword "int" $> ''CInt +cTypeName :: MonadParsec e [Tok] m => m TH.Name +cTypeName = keyword "int" $> ''CInt -------------------------------------------------------------------------------- -- Parsing enumerations. @@ -172,15 +189,19 @@ 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 - keyword "enum" + inlineDocs <- try do + 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 diff --git a/generator/DearImGui/Generator/Types.hs b/generator/DearImGui/Generator/Types.hs index dffd94c..6f34968 100644 --- a/generator/DearImGui/Generator/Types.hs +++ b/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.Traversable + ( for ) + -- 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,30 @@ 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 () -> TH.Q ( Headers ( TH.Name, TH.Name ) ) +generateNames ( Headers { enums = basicEnums } ) = do + enums <- for basicEnums \ enum@( Enumeration { enumName } ) -> do + let + enumNameStr :: String + enumNameStr = Text.unpack enumName + tyName <- TH.newName enumNameStr + conName <- TH.newName enumNameStr + pure $ enum { enumTypeName = ( tyName, conName ) } + pure $ Headers { enums } diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 9e807f3..f8e47cf 100644 --- a/src/DearImGui/Context.hs +++ b/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 - [ ( TypeName "ImGuiCol" , [t| ImGuiCol |] ) - , ( TypeName "ImGuiCond", [t| ImGuiCond |] ) - , ( TypeName "ImGuiDir" , [t| ImGuiDir |] ) - , ( TypeName "ImGuiStyleVar" , [t| ImGuiStyleVar |] ) - , ( TypeName "ImGuiTabBarFlags" , [t| ImGuiTabBarFlags |] ) - , ( TypeName "ImGuiTabItemFlags", [t| ImGuiTabItemFlags |] ) - , ( TypeName "ImVec2", [t| ImVec2 |] ) + { ctxTypesTable = enumerationsTypesTable <> + Map.fromList + [ ( TypeName "ImVec2", [t| ImVec2 |] ) , ( TypeName "ImVec3", [t| ImVec3 |] ) , ( TypeName "ImVec4", [t| ImVec4 |] ) ]