Handle remaining enums (#36)

This handles the remaining enum types in the headers that aren't in the enums section.

It also automatically handles adding all the enumerations to the inline-c context types table, and a small improvement to the display of parse error messages.

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

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

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 }