From 895f5c192680640b24bd1fa79b3cdc0f0c5ccf78 Mon Sep 17 00:00:00 2001 From: sheaf Date: Fri, 5 Feb 2021 21:57:17 +0100 Subject: [PATCH] Parse enums from headers & generate code (#19) --- Main.hs | 2 +- dear-imgui.cabal | 70 +++- generator/DearImGui/Generator.hs | 159 +++++++++ generator/DearImGui/Generator/Parser.hs | 392 +++++++++++++++++++++ generator/DearImGui/Generator/Tokeniser.hs | 197 +++++++++++ generator/DearImGui/Generator/Types.hs | 42 +++ src/DearImGui.hs | 23 +- src/DearImGui/Context.hs | 56 +-- src/DearImGui/Enums.hs | 34 ++ src/DearImGui/Structs.hs | 51 +++ 10 files changed, 947 insertions(+), 79 deletions(-) create mode 100644 generator/DearImGui/Generator.hs create mode 100644 generator/DearImGui/Generator/Parser.hs create mode 100644 generator/DearImGui/Generator/Tokeniser.hs create mode 100644 generator/DearImGui/Generator/Types.hs create mode 100644 src/DearImGui/Enums.hs create mode 100644 src/DearImGui/Structs.hs diff --git a/Main.hs b/Main.hs index 2f47e00..f5d8b0b 100644 --- a/Main.hs +++ b/Main.hs @@ -70,7 +70,7 @@ loop w checked color slider r = do True -> putStrLn "Oh hi Mark" False -> return () - sameLine >> arrowButton "Arrow" ImGuiDirUp + sameLine >> arrowButton "Arrow" ImGuiDir_Up sameLine >> checkbox "Check!" checked >>= \case True -> readIORef checked >>= print diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 7d77c14..358e896 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -2,6 +2,8 @@ cabal-version: 3.0 name: dear-imgui version: 1.0.0 build-type: Simple +data-files: + imgui/imgui.h flag opengl description: @@ -27,16 +29,25 @@ flag sdl manual: False +common common + build-depends: + base + >= 4.12 && < 4.17 + default-language: + Haskell2010 + ghc-options: + -Wall + library - exposed-modules: - DearImGui - DearImGui.Context + import: common hs-source-dirs: src - default-language: - Haskell2010 - ghc-options: - -Wall + exposed-modules: + DearImGui + other-modules: + DearImGui.Context + DearImGui.Enums + DearImGui.Structs cxx-sources: imgui/imgui.cpp imgui/imgui_demo.cpp @@ -50,7 +61,7 @@ library include-dirs: imgui build-depends: - base + dear-imgui-generator , containers , managed , inline-c @@ -117,30 +128,55 @@ library exposed-modules: DearImGui.SDL.Vulkan +library dear-imgui-generator + import: common + hs-source-dirs: generator + exposed-modules: + DearImGui.Generator + , DearImGui.Generator.Parser + , DearImGui.Generator.Tokeniser + , DearImGui.Generator.Types + build-depends: + template-haskell + >= 2.15 && < 2.19 + , directory + >= 1.3 && < 1.4 + , filepath + >= 1.4 && < 1.5 + , megaparsec + >= 9.0 && < 9.1 + , parser-combinators + >= 1.2.0 && < 1.3 + , scientific + >= 0.3.6.2 && < 0.3.7 + , text + >= 1.2.4 && < 1.3 + , th-lift + >= 0.7 && < 0.9 + , transformers + >= 0.5.6 && < 0.6 + , unordered-containers + >= 0.2.11 && < 0.2.14 executable test + import: common main-is: Main.hs - default-language: Haskell2010 - build-depends: base, sdl2, gl, dear-imgui - ghc-options: -Wall - + build-depends: sdl2, gl, dear-imgui executable readme + import: common main-is: Readme.hs hs-source-dirs: examples - default-language: Haskell2010 - build-depends: base, sdl2, gl, dear-imgui, managed - ghc-options: -Wall + build-depends: sdl2, gl, dear-imgui, managed executable vulkan + import: common main-is: Main.hs other-modules: Attachments, Backend, Input, Util hs-source-dirs: examples/vulkan default-language: Haskell2010 build-depends: dear-imgui - , base - >= 4.13 && < 4.16 , bytestring >= 0.10.10.0 && < 0.12 , containers diff --git a/generator/DearImGui/Generator.hs b/generator/DearImGui/Generator.hs new file mode 100644 index 0000000..431dc35 --- /dev/null +++ b/generator/DearImGui/Generator.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module DearImGui.Generator + ( declareEnumerations ) + where + +-- base +import Data.Coerce + ( coerce ) +import Data.Bits + ( Bits ) +import Data.Foldable + ( toList ) +import Data.Traversable + ( for ) +import Foreign.Storable + ( Storable ) + +-- directory +import System.Directory + ( canonicalizePath ) + +-- filepath +import System.FilePath + ( takeDirectory ) + +-- megaparsec +import qualified Text.Megaparsec as Megaparsec + ( ParseErrorBundle(bundleErrors), parse, parseErrorPretty ) + +-- template-haskell +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + +-- text +import qualified Data.Text as Text + ( isInfixOf, null, unpack, unlines ) +import qualified Data.Text.IO as Text + ( readFile ) + +-- dear-imgui-generator +import qualified DearImGui.Generator.Parser as Parser + ( headers ) +import DearImGui.Generator.Tokeniser + ( tokenise ) +import DearImGui.Generator.Types + ( Comment(..), Enumeration(..), Headers(..) ) + +-------------------------------------------------------------------------------- +-- Obtaining parsed header data. + +headers :: Headers +headers = $( do + currentPath <- TH.loc_filename <$> TH.location + TH.lift =<< 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 ) ) + Right res -> pure res + ) + +-------------------------------------------------------------------------------- +-- Generating TH splices. + +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 finiteEnumName countName ( Enumeration {..} ) = do + let + enumNameStr :: String + enumNameStr = Text.unpack enumName + 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 ) + ] + classes :: [ TH.Q TH.Type ] + classes + | isFlagEnum + = map TH.conT [ ''Eq, ''Ord, ''Storable, ''Bits ] + | otherwise + = 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 + then TH.newtypeD + else + \ ctx name bndrs kd con derivs -> + TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, "", [] ) derivs + ( Text.unpack . Text.unlines . coerce $ docs ) + ) +#else + TH.newtypeD +#endif + ( pure [] ) tyName [] Nothing newtypeCon [ derivClause ] + + mbAddFiniteEnumInst <- + if hasExplicitCount + then do + finiteEnumInst <- + TH.instanceD ( pure [] ) ( TH.appT ( TH.conT finiteEnumName ) ( TH.conT tyName ) ) + [ TH.tySynInstD ( TH.TySynEqn Nothing + <$> TH.appT ( TH.conT countName ) ( TH.conT tyName ) + <*> TH.litT ( TH.numTyLit enumSize ) + ) + ] + pure ( finiteEnumInst : ) + else pure id + + synonyms <- for patterns \ ( patternName, patternValue, CommentText patDoc ) -> do + let + patNameStr :: String + patNameStr = Text.unpack patternName + patName <- TH.newName patNameStr + patSynSig <- TH.patSynSigD patName ( TH.conT tyName ) + pat <- +#if MIN_VERSION_base(4,16,0) + ( if Text.null patDoc + then TH.patSynD + else + \ nm args dir pat -> + TH.patSynD_doc nm args dir pat + ( Text.unpack patDoc ) [] + ) +#else + TH.patSynD +#endif + patName ( TH.prefixPatSyn [] ) TH.implBidir + ( TH.conP conName [ TH.litP $ TH.integerL patternValue ] ) + pure ( patSynSig, pat ) + + pure ( newtypeDecl : mbAddFiniteEnumInst ( unpairs synonyms ) ) + +unpairs :: [ ( a, a ) ] -> [ a ] +unpairs [] = [] +unpairs ( ( x, y ) : as ) = x : y : unpairs as diff --git a/generator/DearImGui/Generator/Parser.hs b/generator/DearImGui/Generator/Parser.hs new file mode 100644 index 0000000..13b5994 --- /dev/null +++ b/generator/DearImGui/Generator/Parser.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module DearImGui.Generator.Parser + ( CustomParseError(..) + , headers + ) + where + +-- base +import Control.Applicative + ( (<|>), many, optional, some ) +import Control.Monad + ( void ) +import Data.Bits + ( Bits(shiftL) ) +import Data.Char + ( isSpace, toLower ) +import Data.Either + ( partitionEithers ) +import Data.Functor + ( ($>) ) +import Data.Int + ( Int64 ) +import Data.Maybe + ( catMaybes, fromMaybe ) +import Foreign.C.Types + ( CInt ) + +-- template-haskell +import qualified Language.Haskell.TH as TH + ( Name ) + +-- megaparsec +import Text.Megaparsec + ( MonadParsec(..), ShowErrorComponent(..) + , (), anySingle, customFailure, single + ) + +-- parser-combinators +import Control.Applicative.Combinators + ( manyTill, option, sepBy1, skipManyTill ) + +-- scientific +import Data.Scientific + ( floatingOrInteger, toBoundedInteger ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( all, any, breakOn, drop, dropWhile, dropWhileEnd + , length, stripPrefix, unlines, unpack + ) + +-- transformers +import Control.Monad.Trans.State.Strict + ( StateT(..) + , get, modify' + ) + +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap + ( fromList, insert, lookup ) + +-- dear-imgui-generator +import DearImGui.Generator.Tokeniser + ( Tok(..) ) +import DearImGui.Generator.Types + ( Comment(..), Enumeration(..), Headers(..) ) + +-------------------------------------------------------------------------------- +-- Parse error type. + +data CustomParseError + = Couldn'tLookupEnumValues + { enumName :: !Text + , problems :: ![Text] + } + | MissingForwardDeclaration + { enumName :: !Text } + | UnexpectedSection + { sectionName :: !Text + , problem :: ![Text] + } + deriving stock ( Show, Eq, Ord ) + +instance ShowErrorComponent CustomParseError where + showErrorComponent ( Couldn'tLookupEnumValues { enumName, problems } ) = Text.unpack $ + "Couldn't lookup the following values in enum " <> enumName <> ":\n" + <> Text.unlines ( map ( " - " <> ) problems ) + showErrorComponent ( MissingForwardDeclaration { enumName } ) = Text.unpack $ + "Missing forward declaration for enum named " <> enumName + showErrorComponent ( UnexpectedSection { sectionName, problem } ) = Text.unpack $ + "Unexpected section name.\n\ + \Expected: " <> sectionName <> "\n\ + \ Actual: " <> Text.unlines ( map ( " " <> ) problem ) + +-------------------------------------------------------------------------------- +-- Parsing 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 <$> + 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" ) + + pure ( Headers { enums } ) + +-------------------------------------------------------------------------------- +-- Parsing forward declarations. + +forwardDeclarations + :: MonadParsec CustomParseError [Tok] m + => m ( HashMap Text Comment, HashMap Text ( TH.Name, Comment ) ) +forwardDeclarations = do + _ <- many comment + structs <- many do + keyword "struct" + structName <- identifier + reservedSymbol ';' + doc <- comment + pure ( structName, doc ) + _ <- many comment + enums <- many do + keyword "typedef" + ty <- enumTypeName + enumName <- identifier + reservedSymbol ';' + doc <- commentText <$> comment + pure ( enumName, ( ty, CommentText <$> Text.drop 2 . snd $ Text.breakOn "//" doc ) ) + -- 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 + +-------------------------------------------------------------------------------- +-- Parsing enumerations. + +data EnumState = EnumState + { enumValues :: HashMap Text Integer + , currEnumTag :: Integer + , enumSize :: Integer + , hasExplicitCount :: Bool + } + +enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m Enumeration +enumeration enumNamesAndTypes = do + inlineDocs <- many comment + keyword "enum" + fullEnumName <- identifier + let + enumName :: Text + enumName = Text.dropWhileEnd ( == '_' ) fullEnumName + ( enumType, 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 } ) <- + ( `runStateT` EnumState { enumValues = mempty, currEnumTag = 0, enumSize = 0, hasExplicitCount = False } ) $ + catMaybes + <$> many + ( some ignoredPatternContent $> Nothing + <|> enumerationPattern fullEnumName + ) + reservedSymbol '}' + reservedSymbol ';' + pure ( Enumeration { .. } ) + +ignoredPatternContent :: MonadParsec e [Tok] m => m () +ignoredPatternContent = void ( try comment ) <|> cppConditional + +enumerationPattern + :: MonadParsec CustomParseError [ Tok ] m + => Text + -> StateT EnumState m ( Maybe ( Text, Integer, Comment ) ) +enumerationPattern enumName = do + mbPatNameVal <- patternNameAndValue enumName + _ <- optional $ reservedSymbol ',' + comm <- fromMaybe ( CommentText "" ) <$> optional comment + pure $ + case mbPatNameVal of + Nothing -> Nothing + Just ( patName, patValue ) -> Just ( patName, patValue, comm ) + +patternNameAndValue + :: forall m + . MonadParsec CustomParseError [ Tok ] m + => Text + -> StateT EnumState m ( Maybe ( Text, Integer ) ) +patternNameAndValue enumName = + try do + sz <- count + modify' ( ( \ st -> st { enumSize = sz, hasExplicitCount = True } ) :: EnumState -> EnumState ) + pure Nothing + <|> do + pat@( _, val ) <- value + modify' ( \ st -> st { enumSize = ( enumSize :: EnumState -> Integer ) st + 1, currEnumTag = val + 1} ) + pure ( Just pat ) + where + count :: StateT EnumState m Integer + count = do + _ <- single ( Identifier $ enumName <> "COUNT" ) + mbVal <- optional do + _ <- reservedSymbol '=' + integerExpression + case mbVal of + Nothing -> currEnumTag <$> get + Just ct -> pure ct + value :: StateT EnumState m ( Text, Integer ) + value = do + name <- identifier + val <- patternRHS + modify' ( \ st -> st { enumValues = HashMap.insert name val ( enumValues st ) } ) + pure ( name, val ) + patternRHS :: StateT EnumState m Integer + patternRHS = + ( do + reservedSymbol '=' + try integerExpression <|> try disjunction + ) + <|> ( currEnumTag <$> get ) + + disjunction :: StateT EnumState m Integer + disjunction = do + ( summands :: [Text] ) <- identifier `sepBy1` symbol "|" + valsMap <- enumValues <$> get + let + res :: Either [ Text ] Integer + res = foldr + ( \ summand errsOrVal -> case HashMap.lookup summand valsMap of + Nothing -> case errsOrVal of { Right _ -> Left [ summand ]; Left errs -> Left ( summand : errs ) } + Just v -> case errsOrVal of { Right v' -> Right ( v + v' ); Left errs -> Left errs } + ) + ( Right 0 ) + summands + case res of + Left problems -> customFailure ( Couldn'tLookupEnumValues { enumName, problems } ) + Right v -> pure v + +-------------------------------------------------------------------------------- +-- Simple token parsers. + +comment :: MonadParsec e [ Tok ] m => m Comment +comment = CommentText <$> + token ( \ case { Comment comm -> Just comm; _ -> Nothing } ) mempty + "comment" + +keyword :: MonadParsec e [ Tok ] m => Text -> m () +keyword kw = token ( \ case { Keyword kw' | kw == kw' -> Just (); _ -> Nothing } ) mempty + ( Text.unpack kw <> " (keyword)" ) + +identifier :: MonadParsec e [ Tok ] m => m Text +identifier = token ( \ case { Identifier i -> Just i; _ -> Nothing } ) mempty + "identifier" + +{- +prefixedIdentifier :: MonadParsec e [ Tok ] m => Text -> m Text +prefixedIdentifier prefix = + token + ( \ case + { Identifier i -> Text.dropWhile ( == '_' ) <$> Text.stripPrefix prefix i + ; _ -> Nothing + } + ) mempty +-} + +reservedSymbol :: MonadParsec e [ Tok ] m => Char -> m () +reservedSymbol s = token ( \ case { ReservedSymbol s' | s == s' -> Just (); _ -> Nothing } ) mempty + ( [s] <> " (reserved symbol)" ) + +symbol :: MonadParsec e [ Tok ] m => Text -> m () +symbol s = token ( \ case { Symbolic s' | s == s' -> Just (); _ -> Nothing } ) mempty + ( Text.unpack s <> " (symbol)" ) + +integerExpression :: MonadParsec e [ Tok ] m => m Integer +integerExpression = try integerPower <|> integer + +integerPower :: MonadParsec e [ Tok ] m => m Integer +integerPower = do + a <- integer + _ <- symbol "<<" + i <- integer + pure ( a `shiftL` fromIntegral i ) + +integer :: forall e m. MonadParsec e [ Tok ] m => m Integer +integer = + option id mkSign <*> + token + ( \ case { + Number i suff + | Just _ <- toBoundedInteger @Int64 i + , Right i' <- floatingOrInteger @Float @Integer i + , not ( Text.any ( (== 'f' ) . toLower ) suff ) + -> Just i'; + _ -> Nothing + } + ) + mempty + "integer" + where + mkSign :: m ( Integer -> Integer ) + mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate ) + +section :: MonadParsec e [ Tok ] m => m [Text] +section = + do + sectionText <- try do + separator + token + ( \ case + { Comment txt -> fmap ( Text.dropWhile isSpace ) + . Text.stripPrefix "[SECTION]" + . Text.dropWhile isSpace + $ txt + ; _ -> Nothing + } + ) mempty + rest <- endOfSectionHeader + pure ( sectionText : filter ( not . Text.all ( \ c -> c == '-' || isSpace c ) ) rest ) + "section" + +separator :: MonadParsec e [ Tok ] m => m () +separator = token + ( \ case + { Comment hyphens | Text.length hyphens > 10 && Text.all ( == '-') hyphens -> Just () + ; _ -> Nothing + } + ) mempty + "separator" + +endOfSectionHeader :: MonadParsec e [ Tok ] m => m [Text] +endOfSectionHeader = try ( (:) <$> ( commentText <$> comment ) <*> endOfSectionHeader ) + <|> ( separator $> [] ) + +namedSection :: MonadParsec CustomParseError [ Tok ] m => Text -> m () +namedSection sectionName = + do + sectionTexts <- section + case sectionTexts of + sectionText : _ + | Just _ <- Text.stripPrefix sectionName sectionText + -> pure () + _ -> customFailure ( UnexpectedSection { sectionName, problem = sectionTexts } ) + ( "section named " <> Text.unpack sectionName ) + +cppDirective :: MonadParsec e [Tok] m => ( Text -> Maybe a ) -> m a +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 } ) + -- assumes no nesting + void $ skipManyTill anySingle ( cppDirective ( \case { "endif" -> Just (); _ -> Nothing } ) ) + void $ skipManyTill anySingle ( single EndCPPLine ) + +ignoreDefine :: MonadParsec e [Tok] m => m () +ignoreDefine = do + void $ many comment + void $ cppDirective ( \case { "define" -> Just (); _ -> Nothing } ) + void $ skipManyTill anySingle ( single EndCPPLine ) diff --git a/generator/DearImGui/Generator/Tokeniser.hs b/generator/DearImGui/Generator/Tokeniser.hs new file mode 100644 index 0000000..12c70f7 --- /dev/null +++ b/generator/DearImGui/Generator/Tokeniser.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module DearImGui.Generator.Tokeniser where + +-- base +import Control.Arrow + ( first, second ) +import Control.Applicative + ( (<|>), some ) +import Data.Char + ( isAlpha, isAlphaNum, isDigit, isPunctuation, isSpace, isSymbol, toLower ) +import Data.Function + ( (&) ) +import Data.Functor + ( ($>) ) +import Data.Monoid + ( Sum(..) ) + +-- megaparsec +import Text.Megaparsec + ( MonadParsec, VisualStream(..) + , chunk, parseMaybe, satisfy, try + ) +import Text.Megaparsec.Char.Lexer + ( hexadecimal, scientific ) + +-- parser-combinators +import Control.Monad.Combinators + ( optional ) + +-- scientific +import Data.Scientific + ( Scientific ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( break, breakOn, cons, drop, dropWhile + , head, last, length + , pack, snoc, span, strip, tail, take + , uncons, unpack + ) + +-- unordered-containers +import Data.HashSet + ( HashSet ) +import qualified Data.HashSet as HashSet + ( fromList, member ) + +-------------------------------------------------------------------------------- + +data TokeniserError + = Couldn'tParseNumber { problem :: !Text } + | UnhandledCase { unhandled :: !( Char, Text ) } + deriving stock ( Eq, Ord, Show ) + +data Tok + = Keyword !Text + | ReservedSymbol !Char + | Symbolic !Text + | Identifier !Text + | Comment !Text + | Char !Char + | String !Text + | Number !Scientific !Text + | BeginCPP !Text + | EndCPPLine + deriving stock ( Show, Eq, Ord ) + +showToken :: Tok -> String +showToken = \case + Keyword t -> Text.unpack t + ReservedSymbol c -> [c] + Symbolic t -> Text.unpack t + Identifier t -> Text.unpack t + Comment t -> Text.unpack t + Char c -> [c] + String t -> Text.unpack t + Number s t -> show s <> Text.unpack t + BeginCPP t -> "#" <> Text.unpack t + EndCPPLine -> "EndCppLine" + +tokenLength :: Tok -> Int +tokenLength = \case + Keyword t -> Text.length t + ReservedSymbol _ -> 1 + Symbolic t -> Text.length t + Identifier t -> Text.length t + Comment t -> Text.length t + Char _ -> 1 + String t -> Text.length t + Number s t -> length ( show s ) + Text.length t + BeginCPP t -> 1 + Text.length t + EndCPPLine -> length ( "EndCPPLine" :: String ) + +instance VisualStream [Tok] where + showTokens _ = foldMap showToken + tokensLength _ = getSum . foldMap ( Sum . tokenLength ) + +keywords :: HashSet Text +keywords = HashSet.fromList + [ "auto", "break", "case", "char", "const", "continue", "default", "do", "double" + , "else", "enum", "extern", "float", "for", "goto", "if", "inline", "int", "long" + , "register", "restrict", "return", "short", "signed", "sizeof", "static", "struct" + , "switch", "typedef", "union", "unsigned", "void", "volatile", "while" + ] + +reservedSymbols :: HashSet Char +reservedSymbols = HashSet.fromList [ '(', ')', '{', '}', ',', ';', '=', '#' ] + +tokenise :: Text -> Either TokeniserError [ Tok ] +tokenise ( Text.uncons -> Just ( c, cs ) ) + | isSpace c + = tokenise ( Text.dropWhile isSpace cs ) + | isAlpha c || c == '_' + , let + this, rest :: Text + ( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> isAlphaNum x || x == '_' ) cs + = if this `HashSet.member` keywords + then ( Keyword this : ) <$> tokenise rest + else ( Identifier this : ) <$> tokenise rest + | isDigit c + , let + this, rest :: Text + ( this, rest ) = continuePastExponent $ first ( c `Text.cons` ) $ Text.span ( \ x -> isAlphaNum x || x == '.' ) cs + = case parseMaybe @() parseNumber this of + Just numTok -> ( numTok : ) <$> tokenise rest + Nothing -> Left ( Couldn'tParseNumber { problem = this } ) + | c == '\'' + , Just ( '\'', rest ) <- Text.uncons ( Text.drop 1 cs ) + = ( Char ( Text.head cs ) : ) <$> tokenise rest + | c == '\"' + , let + this, rest :: Text + ( this, rest ) = second Text.tail $ Text.break ( == '"') cs + = ( String this : ) <$> tokenise rest + | c == '#' + , let + directive, line, rest :: Text + ( directive, ( line, rest ) ) + = cs + & Text.break ( isSpace ) + & second ( Text.break ( `elem` [ '\n', '\r' ] ) ) + = do + lineTokens <- tokenise line + restTokens <- tokenise rest + pure ( ( BeginCPP directive : lineTokens ) <> ( EndCPPLine : restTokens ) ) + | c `HashSet.member` reservedSymbols + = ( ReservedSymbol c : ) <$> tokenise cs + | c == '/' + = case Text.take 1 cs of + "/" -> + let + comm, rest :: Text + ( comm, rest ) = first Text.strip $ Text.break ( `elem` [ '\n', '\r' ] ) ( Text.drop 1 cs ) + in ( Comment comm : ) <$> tokenise rest + "*" -> + let + comm, rest :: Text + ( comm, rest ) = Text.breakOn "*/" ( Text.drop 1 cs ) + in ( Comment comm : ) <$> tokenise rest + _ -> + let + this, rest :: Text + ( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> x /= '_' && ( isSymbol x || isPunctuation x ) ) cs + in ( Symbolic this : ) <$> tokenise rest + | isSymbol c || isPunctuation c + , let + this, rest :: Text + ( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> x /= '_' && ( isSymbol x || isPunctuation x ) ) cs + = ( Symbolic this : ) <$> tokenise rest + | otherwise + = Left $ UnhandledCase { unhandled = ( c, cs ) } +tokenise _ = Right [] + +continuePastExponent :: ( Text, Text ) -> ( Text, Text ) +continuePastExponent ( this, rest ) + | toLower ( Text.last this ) `elem` [ 'e', 'p' ] + , Just ( r, rs ) <- Text.uncons rest + , r `elem` [ '+', '-' ] + , ( this', rest' ) <- Text.span isAlphaNum rs + = ( this `Text.snoc` r <> this', rest' ) + | otherwise + = ( this, rest ) + +parseNumber :: MonadParsec e Text m => m Tok +parseNumber = try ( chunk "0.f" $> Number 0 "f" ) <|> do + value <- try ( chunk "0x" *> hexadecimal ) <|> scientific + mbSuffix <- fmap ( maybe "" Text.pack ) . optional . some $ satisfy ( \ s -> toLower s `elem` ( "uflz" :: String ) ) + pure ( Number value mbSuffix ) diff --git a/generator/DearImGui/Generator/Types.hs b/generator/DearImGui/Generator/Types.hs new file mode 100644 index 0000000..dffd94c --- /dev/null +++ b/generator/DearImGui/Generator/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module DearImGui.Generator.Types where + +-- template-haskell +import qualified Language.Haskell.TH.Syntax as TH + ( Lift(..), Name(..) ) + +-- text +import Data.Text + ( Text ) + +-- th-lift +import Language.Haskell.TH.Lift + () -- 'Lift' instance for Name + +-------------------------------------------------------------------------------- + +newtype Comment = CommentText { commentText :: Text } + deriving stock ( Show, TH.Lift ) + deriving newtype ( Eq, Ord ) + +data Enumeration + = Enumeration + { docs :: ![Comment] + , enumName :: !Text + , enumSize :: !Integer + , enumType :: !TH.Name + , hasExplicitCount :: !Bool + , patterns :: [ ( Text, Integer, Comment ) ] + } + deriving stock ( Show, TH.Lift ) + +data Headers + = Headers + { enums :: [ Enumeration ] } + deriving stock ( Show, TH.Lift ) diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 4f3f892..da135a8 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -122,13 +122,8 @@ module DearImGui , isItemHovered -- * Types - , ImGuiDir - , pattern ImGuiDirLeft - , pattern ImGuiDirRight - , pattern ImGuiDirUp - , pattern ImGuiDirDown - , ImVec3(..) - , ImVec4(..) + , module DearImGui.Enums + , module DearImGui.Structs ) where @@ -139,6 +134,9 @@ import Foreign.C -- dear-imgui import DearImGui.Context + ( imguiContext ) +import DearImGui.Enums +import DearImGui.Structs -- inline-c import qualified Language.C.Inline as C @@ -777,17 +775,6 @@ isItemHovered = liftIO do (0 /=) <$> [C.exp| bool { IsItemHovered() } |] --- | A cardinal direction. -newtype ImGuiDir = ImGuiDir CInt - - -pattern ImGuiDirLeft, ImGuiDirRight, ImGuiDirUp, ImGuiDirDown :: ImGuiDir -pattern ImGuiDirLeft = ImGuiDir 0 -pattern ImGuiDirRight = ImGuiDir 1 -pattern ImGuiDirUp = ImGuiDir 2 -pattern ImGuiDirDown = ImGuiDir 3 - - withCStringOrNull :: Maybe String -> (Ptr CChar -> IO a) -> IO a withCStringOrNull Nothing k = k nullPtr withCStringOrNull (Just s) k = withCString s k diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 3220ae3..cbfd48d 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -1,57 +1,27 @@ +{-# language DerivingStrategies #-} {-# language DuplicateRecordFields #-} +{-# language GeneralizedNewtypeDeriving #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} +{-# language PatternSynonyms #-} {-# language TemplateHaskell #-} module DearImGui.Context where -import Language.C.Types -import Language.C.Inline.Context +-- containers import qualified Data.Map.Strict as Map -import Foreign +-- inline-c +import Language.C.Inline.Context + ( Context(..) ) +import Language.C.Types + ( pattern TypeName ) -data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float } - - -instance Storable ImVec3 where - sizeOf ~ImVec3{x, y, z} = sizeOf x + sizeOf y + sizeOf z - - alignment _ = 0 - - poke ptr ImVec3{ x, y, z } = do - poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x - poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y - poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z - - peek ptr = do - x <- peek (castPtr ptr ) - y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) - z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2)) - return ImVec3{ x, y, z } - - -data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float } - - -instance Storable ImVec4 where - sizeOf ~ImVec4{x, y, z, w} = sizeOf x + sizeOf y + sizeOf z + sizeOf w - - alignment _ = 0 - - poke ptr ImVec4{ x, y, z, w } = do - poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x - poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y - poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z - poke (castPtr ptr `plusPtr` (sizeOf x * 3)) w - - peek ptr = do - x <- peek (castPtr ptr ) - y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) - z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2)) - w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3)) - return ImVec4{ x, y, z, w } +-- dear-imgui +import DearImGui.Structs + ( ImVec3, ImVec4 ) +-------------------------------------------------------------------------------- imguiContext :: Context imguiContext = mempty diff --git a/src/DearImGui/Enums.hs b/src/DearImGui/Enums.hs new file mode 100644 index 0000000..0ee776b --- /dev/null +++ b/src/DearImGui/Enums.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module DearImGui.Enums where + +-- base +import GHC.Exts + ( proxy# ) +import GHC.TypeNats + ( Nat, KnownNat, natVal' ) +import Numeric.Natural + ( Natural ) + +-- dear-imgui-generator +import DearImGui.Generator + ( declareEnumerations ) + +-------------------------------------------------------------------------------- + +class KnownNat ( Count a ) => FiniteEnum a where + type Count a :: Nat + count :: Natural + count = natVal' @( Count a ) proxy# + +declareEnumerations ''FiniteEnum ''Count diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs new file mode 100644 index 0000000..45af7b0 --- /dev/null +++ b/src/DearImGui/Structs.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} + +module DearImGui.Structs where + +-- base +import Foreign + ( Storable(..), castPtr, plusPtr ) + +-------------------------------------------------------------------------------- + +data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float } + + +instance Storable ImVec3 where + sizeOf ~ImVec3{x, y, z} = sizeOf x + sizeOf y + sizeOf z + + alignment _ = 0 + + poke ptr ImVec3{ x, y, z } = do + poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x + poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y + poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z + + peek ptr = do + x <- peek (castPtr ptr ) + y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) + z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2)) + return ImVec3{ x, y, z } + + +data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float } + + +instance Storable ImVec4 where + sizeOf ~ImVec4{x, y, z, w} = sizeOf x + sizeOf y + sizeOf z + sizeOf w + + alignment _ = 0 + + poke ptr ImVec4{ x, y, z, w } = do + poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x + poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y + poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z + poke (castPtr ptr `plusPtr` (sizeOf x * 3)) w + + peek ptr = do + x <- peek (castPtr ptr ) + y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) + z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2)) + w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3)) + return ImVec4{ x, y, z, w }