From 46b499e864276762d593070eb437514c83628050 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 18 Mar 2022 19:30:15 +0100 Subject: [PATCH] At least it compiles :sweat_smile: --- .gitignore | 4 +- .gitmodules | 7 +- README.md | 4 +- cabal.project | 2 - dear-imgui.hs | 1 + dear-implot.cabal | 28 +- imgui | 2 +- src/DearImGui/Context.hs | 1 + src/DearImGui/Enums.hs | 1 + src/DearImGui/Generator | 1 + src/DearImGui/Generator.hs | 1 + src/DearImGui/Plot.hs | 23 +- src/DearImGui/Plot/Context.hs | 32 +- src/DearImGui/Plot/Enums.hs | 2 +- src/DearImGui/Plot/Generator.hs | 29 +- src/DearImGui/Plot/Generator/Parser.hs | 449 +++++++++++++++++++++++++ src/DearImGui/Plot/Structs.hs | 101 ------ src/DearImGui/Raw/Plot.hs | 20 +- src/DearImGui/Structs.hs | 1 + 19 files changed, 537 insertions(+), 172 deletions(-) create mode 160000 dear-imgui.hs mode change 160000 => 120000 imgui create mode 120000 src/DearImGui/Context.hs create mode 120000 src/DearImGui/Enums.hs create mode 120000 src/DearImGui/Generator create mode 120000 src/DearImGui/Generator.hs create mode 100644 src/DearImGui/Plot/Generator/Parser.hs create mode 120000 src/DearImGui/Structs.hs diff --git a/.gitignore b/.gitignore index 16566ff..a6ebdfc 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ -/imgui.ini +imgui.ini +dist-newstyle +.stack-work diff --git a/.gitmodules b/.gitmodules index 1490475..752edc3 100644 --- a/.gitmodules +++ b/.gitmodules @@ -2,7 +2,6 @@ path = implot url = https://github.com/epezent/implot branch = v0.13 -[submodule "imgui"] - path = imgui - url = https://github.com/ocornut/imgui - branch = v1.87 +[submodule "dear-imgui.hs"] + path = dear-imgui.hs + url = https://github.com/haskell-game/dear-imgui.hs diff --git a/README.md b/README.md index 9912b10..b620bea 100644 --- a/README.md +++ b/README.md @@ -6,10 +6,10 @@ This project contains Haskell bindings to the ## Contribute -To build the project, make sure the subprojects: +To build the project, make sure the subprojects are checked out recursively: ```ShellSession -$ git submodule update --init +$ git submodule update --init --recursive ``` then ```ShellSession diff --git a/cabal.project b/cabal.project index deb98e2..c660f08 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,3 @@ packages: *.cabal -package dear-imgui - flags: -sdl +glfw package dear-implot ghc-options: -Wall -Wcompat -fno-warn-unused-do-bind diff --git a/dear-imgui.hs b/dear-imgui.hs new file mode 160000 index 0000000..e5969f6 --- /dev/null +++ b/dear-imgui.hs @@ -0,0 +1 @@ +Subproject commit e5969f6b358dab01d9e2bea8d3538fdfbee0c2f1 diff --git a/dear-implot.cabal b/dear-implot.cabal index b83326c..d2ea253 100644 --- a/dear-implot.cabal +++ b/dear-implot.cabal @@ -7,6 +7,20 @@ library exposed-modules: DearImGui.Raw.Plot DearImGui.Plot + other-modules: + DearImGui.Plot.Generator + DearImGui.Plot.Generator.Parser + DearImGui.Plot.Context + DearImGui.Plot.Enums + DearImGui.Plot.Structs + --- from imgui via symlink: + DearImGui.Generator + DearImGui.Generator.Parser + DearImGui.Generator.Tokeniser + DearImGui.Generator.Types + DearImGui.Structs + DearImGui.Enums + DearImGui.Context hs-source-dirs: src default-language: @@ -22,7 +36,7 @@ library stdc++ include-dirs: implot - imgui + dear-imgui.hs/imgui build-depends: base , StateVar , containers @@ -30,3 +44,15 @@ library , inline-c , inline-c-cpp , managed + , template-haskell + , directory + , filepath + , text + , megaparsec + , parser-combinators + , scientific + , unordered-containers + , th-lift + , transformers + , vector + , unliftio diff --git a/imgui b/imgui deleted file mode 160000 index 4df5713..0000000 --- a/imgui +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 4df57136e9832327c11e48b5bfe00b0326bd5b63 diff --git a/imgui b/imgui new file mode 120000 index 0000000..378f854 --- /dev/null +++ b/imgui @@ -0,0 +1 @@ +dear-imgui.hs/imgui/ \ No newline at end of file diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs new file mode 120000 index 0000000..8c285c1 --- /dev/null +++ b/src/DearImGui/Context.hs @@ -0,0 +1 @@ +../../dear-imgui.hs/src/DearImGui/Context.hs \ No newline at end of file diff --git a/src/DearImGui/Enums.hs b/src/DearImGui/Enums.hs new file mode 120000 index 0000000..a6da1a6 --- /dev/null +++ b/src/DearImGui/Enums.hs @@ -0,0 +1 @@ +../../dear-imgui.hs/src/DearImGui/Enums.hs \ No newline at end of file diff --git a/src/DearImGui/Generator b/src/DearImGui/Generator new file mode 120000 index 0000000..c55970e --- /dev/null +++ b/src/DearImGui/Generator @@ -0,0 +1 @@ +../../dear-imgui.hs/generator/DearImGui/Generator \ No newline at end of file diff --git a/src/DearImGui/Generator.hs b/src/DearImGui/Generator.hs new file mode 120000 index 0000000..9d8d641 --- /dev/null +++ b/src/DearImGui/Generator.hs @@ -0,0 +1 @@ +../../dear-imgui.hs/generator/DearImGui/Generator.hs \ No newline at end of file diff --git a/src/DearImGui/Plot.hs b/src/DearImGui/Plot.hs index db918ab..f4e90f3 100644 --- a/src/DearImGui/Plot.hs +++ b/src/DearImGui/Plot.hs @@ -26,6 +26,9 @@ module DearImGui.Plot -- * Demo so you can play with all features , Raw.Plot.showPlotDemoWindow + + -- * TEST + , plotLine ) where @@ -72,16 +75,16 @@ import qualified Data.Vector.Unboxed as VU plotLine :: (MonadIO m) => String -> [Float] -> [Float] -> m () plotLine label xs ys = liftIO $ do let size = fromIntegral $ length xs - withCString desc \descPtr -> do + withCString label \labelPtr -> do withArray (map realToFrac xs) \xsPtr -> do withArray (map realToFrac ys) \ysPtr -> do - Raw.Plot.plotLine label xsPtr ysPtr size + Raw.Plot.plotLine labelPtr xsPtr ysPtr size -setNextPlotLimits :: MonadIO m => (Double, Double) -> (Double, Double) -> m () -setNextPlotLimits (minX, maxX) (minY, maxY) = liftIO $ do - Raw.Plot.setNextPlotLimits (minX', maxX') (minY', maxY') - where - minX' = realToFrac minX - maxX' = realToFrac maxX - minY' = realToFrac minY - maxY' = realToFrac maxY +-- setNextPlotLimits :: MonadIO m => (Double, Double) -> (Double, Double) -> m () +-- setNextPlotLimits (minX, maxX) (minY, maxY) = liftIO $ do +-- Raw.Plot.setNextPlotLimits (minX', maxX') (minY', maxY') +-- where +-- minX' = realToFrac minX +-- maxX' = realToFrac maxX +-- minY' = realToFrac minY +-- maxY' = realToFrac maxY diff --git a/src/DearImGui/Plot/Context.hs b/src/DearImGui/Plot/Context.hs index 2a0e366..fa1290e 100644 --- a/src/DearImGui/Plot/Context.hs +++ b/src/DearImGui/Plot/Context.hs @@ -6,7 +6,7 @@ {-# language PatternSynonyms #-} {-# language TemplateHaskell #-} -module DearImGui.Context where +module DearImGui.Plot.Context where -- containers import qualified Data.Map.Strict as Map @@ -17,38 +17,18 @@ import Language.C.Inline.Context import Language.C.Types ( pattern TypeName ) --- dear-imgui -import DearImGui.Structs +-- dear-implot +import DearImGui.Plot.Structs --- dear-imgui-generator -import DearImGui.Generator +-- dear-imgui-generator -> implot +import DearImGui.Plot.Generator ( enumerationsTypesTable ) -------------------------------------------------------------------------------- -imguiContext :: Context -imguiContext = mempty - { ctxTypesTable = enumerationsTypesTable <> - Map.fromList - [ ( TypeName "ImVec2", [t| ImVec2 |] ) - , ( TypeName "ImVec3", [t| ImVec3 |] ) - , ( TypeName "ImVec4", [t| ImVec4 |] ) - , ( TypeName "ImU32", [t| ImU32 |] ) - , ( TypeName "ImGuiID", [t| ImGuiID |] ) - , ( TypeName "ImWchar", [t| ImWchar |] ) - , ( TypeName "ImDrawList", [t| ImDrawList |] ) - , ( TypeName "ImGuiContext", [t| ImGuiContext |] ) - , ( TypeName "ImFont", [t| ImFont |] ) - , ( TypeName "ImFontConfig", [t| ImFontConfig |] ) - , ( TypeName "ImFontGlyphRangesBuilder", [t| ImFontGlyphRangesBuilder |] ) - , ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] ) - , ( TypeName "ImGuiTableSortSpecs", [t| ImGuiTableSortSpecs |] ) - ] - } - implotContext :: Context implotContext = mempty - { ctxTypesTable = + { ctxTypesTable = enumerationsTypesTable <> Map.fromList [ ( TypeName "ImPlotContext", [t| ImPlotContext |] ) ] diff --git a/src/DearImGui/Plot/Enums.hs b/src/DearImGui/Plot/Enums.hs index 597a14b..080c19f 100644 --- a/src/DearImGui/Plot/Enums.hs +++ b/src/DearImGui/Plot/Enums.hs @@ -10,7 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module DearImGui.Enums where +module DearImGui.Plot.Enums where -- base import GHC.Exts diff --git a/src/DearImGui/Plot/Generator.hs b/src/DearImGui/Plot/Generator.hs index b3d5083..26c052d 100644 --- a/src/DearImGui/Plot/Generator.hs +++ b/src/DearImGui/Plot/Generator.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module DearImGui.Generator +module DearImGui.Plot.Generator ( declareEnumerations, enumerationsTypesTable ) where @@ -56,8 +56,8 @@ import qualified Data.Text.IO as Text ( readFile ) -- dear-imgui-generator -import qualified DearImGui.Generator.Parser as Parser - ( headers ) +import qualified DearImGui.Plot.Generator.Parser as Parser + ( plotHeaders ) import DearImGui.Generator.Tokeniser ( Tok, tokenise ) import DearImGui.Generator.Types @@ -71,33 +71,34 @@ import DearImGui.Generator.Types headers :: Headers ( TH.Name, TH.Name ) headers = $( do currentPath <- TH.loc_filename <$> TH.location + let + patchEnums :: Text.Text -> Text.Text + patchEnums = Text.replace "ImGuiCond_None" "0" + . Text.replace "ImGuiCond_Always" "1 << 0" + . Text.replace "ImGuiCond_Once" "1 << 1" basicHeaders <- TH.runIO do - headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" ) - headersSource <- Text.readFile headersPath - tokensImGui <- case tokenise headersSource of - Left err -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err ) - Right toks -> pure toks - headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../implot/implot.h" ) - headersSource <- Text.readFile headersPath + headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../../implot/implot.h" ) + headersSource <- patchEnums <$> Text.readFile headersPath tokensImPlot <- case tokenise headersSource of Left err -> error ( "Couldn't tokenise Dear ImPlot headers:\n\n" <> show err ) Right toks -> pure toks - let tokens = tokensImGui<>tokensImPlot - case Megaparsec.parse Parser.headers "" tokens of + case Megaparsec.parse Parser.plotHeaders "" tokensImPlot of 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 + ( prev, rest ) = second ( take 15 ) . splitAt 5 . drop ( errorPos - 5 ) $ tokensImPlot error $ - "Couldn't parse Dear ImGui headers:\n\n" <> + "Couldn't parse Dear ImPlot 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. diff --git a/src/DearImGui/Plot/Generator/Parser.hs b/src/DearImGui/Plot/Generator/Parser.hs new file mode 100644 index 0000000..853be97 --- /dev/null +++ b/src/DearImGui/Plot/Generator/Parser.hs @@ -0,0 +1,449 @@ +{-# 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.Plot.Generator.Parser + ( CustomParseError(..) + , plotHeaders + ) + 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(..) + , (), 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, 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(..) ) + +import DearImGui.Generator.Parser + +-------------------------------------------------------------------------------- +-- Parsing headers. + +plotHeaders :: MonadParsec CustomParseError [Tok] m => m ( Headers () ) +plotHeaders = do + _ <- skipManyTill anySingle ( namedSection "Macros and Defines" ) + + _ <- skipManyTill anySingle ( namedSection "Enums and Types" ) + + ( _structNames, enumNamesAndTypes ) <- forwardDeclarations + + ( _defines, basicEnums ) <- partitionEithers <$> + manyTill + ( ( Left <$> try ignoreDefine) + <|> ( Right <$> enumeration enumNamesAndTypes) + <|> ( Left <$> ignoreStruct) + ) + ( namedSection "Callbacks" ) + + _ <- skipManyTill anySingle ( namedSection "Contexts" ) + + _ <- skipManyTill anySingle ( namedSection "Begin/End Plot" ) + + _ <- skipManyTill anySingle ( namedSection "Begin/End Subplot" ) + + _ <- skipManyTill anySingle ( namedSection "Setup" ) + + _ <- skipManyTill anySingle ( namedSection "SetNext" ) + + _ <- skipManyTill anySingle ( namedSection "Plot Items" ) + + _ <- skipManyTill anySingle ( namedSection "Plot Tools" ) + + _ <- skipManyTill anySingle ( namedSection "Plot Utils" ) + + _ <- skipManyTill anySingle ( namedSection "Legend Utils" ) + + _ <- skipManyTill anySingle ( namedSection "Drag and Drop" ) + + _ <- skipManyTill anySingle ( namedSection "Styling" ) + + _ <- skipManyTill anySingle ( namedSection "Colormaps" ) + + _ <- skipManyTill anySingle ( namedSection "Input Mapping" ) + + _ <- skipManyTill anySingle ( namedSection "Miscellaneous" ) + + _ <- skipManyTill anySingle ( namedSection "Demo" ) + + _ <- skipManyTill anySingle ( namedSection "Obsolete API" ) + + let + enums :: [ Enumeration () ] + enums = basicEnums + pure ( Headers { enums } ) + +ignoreStruct :: MonadParsec CustomParseError [Tok] m => m () +ignoreStruct = do + void $ many comment + keyword "struct" + _structName <- identifier + ignoreInsideBraces + reservedSymbol ';' + +ignoreInsideBraces :: MonadParsec CustomParseError [Tok] m => m () +ignoreInsideBraces = do + reservedSymbol '{' + go (1 :: Int) + where + go 0 = return () + go n = void $ skipManyTill anySingle ((reservedSymbol '{' *> go (n+1)) <|> reservedSymbol '}' *> go (n-1)) -- collect 1 more } than found { + +--- COPY/PASTE FROM Parser.hs of dear-imgui-generator + +-------------------------------------------------------------------------------- +-- 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 <- cTypeName + 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 ) + +cTypeName :: MonadParsec e [Tok] m => m TH.Name +cTypeName = 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 <- try do + inlineDocs <- many comment + keyword "enum" + pure inlineDocs + fullEnumName <- identifier + let + enumName :: Text + enumName = Text.dropWhileEnd ( == '_' ) fullEnumName + 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 } ) <- + ( `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' ( \ ( EnumState {..} ) -> EnumState { enumSize = sz, hasExplicitCount = True, .. } ) + pure Nothing + <|> do + pat@( _, val ) <- value + modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = enumSize + 1, currEnumTag = val + 1, .. } ) + pure ( Just pat ) + where + count :: StateT EnumState m Integer + count = do + let idName = enumName <> "COUNT" + _ <- single ( Identifier idName ) + + mbVal <- optional do + _ <- reservedSymbol '=' + EnumState{enumValues} <- get + integerExpression enumValues + + countVal <- case mbVal of + Nothing -> currEnumTag <$> get + Just ct -> pure ct + + modify' ( \ st -> st { enumValues = HashMap.insert idName countVal ( enumValues st ) } ) + pure countVal + + 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 '=' + EnumState{enumValues} <- get + try disjunction <|> try (integerExpression enumValues) + ) + <|> ( currEnumTag <$> get ) + + disjunction :: StateT EnumState m Integer + disjunction = do + initial <- identifier <* symbol "|" + ( rest :: [Text] ) <- identifier `sepBy1` symbol "|" + let summands = initial : rest + 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 => HashMap Text Integer -> m Integer +integerExpression enums = try integerPower <|> try integerAdd <|> try integerSub <|> integer + where + integerPower :: MonadParsec e [ Tok ] m => m Integer + integerPower = do + a <- integer + _ <- symbol "<<" + i <- integer + pure ( a `shiftL` fromIntegral i ) + + integerAdd :: MonadParsec e [ Tok ] m => m Integer + integerAdd = do + a <- integer + _ <- symbol "+" + i <- integer + pure ( a + i ) + + integerSub :: MonadParsec e [ Tok ] m => m Integer + integerSub = do + a <- integer + _ <- symbol "-" + i <- integer + pure ( a - 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' + + Identifier name -> + HashMap.lookup name enums + + _ -> + 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/src/DearImGui/Plot/Structs.hs b/src/DearImGui/Plot/Structs.hs index bd2f887..6e69ed1 100644 --- a/src/DearImGui/Plot/Structs.hs +++ b/src/DearImGui/Plot/Structs.hs @@ -15,107 +15,6 @@ import Data.Word import Foreign ( Storable(..), castPtr, plusPtr ) --------------------------------------------------------------------------------- -data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float } - deriving (Show) - - -instance Storable ImVec2 where - sizeOf ~ImVec2{x, y} = sizeOf x + sizeOf y - - alignment _ = 0 - - poke ptr ImVec2{ x, y } = do - poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x - poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y - - peek ptr = do - x <- peek (castPtr ptr ) - y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) - return ImVec2{ x, y } - - -data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float } - deriving (Show) - - -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 } - deriving (Show) - - -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 } - --------------------------------------------------------------------------------- - --- | DearImGui context handle. -data ImGuiContext - --- | Individual font handle. -data ImFont - --- | Font configuration handle. -data ImFontConfig - --- | Glyph ranges builder handle. -data ImFontGlyphRangesBuilder - --- | Opaque DrawList handle. -data ImDrawList - --- | 'DearImGui.Raw.ListClipper.ListClipper' pointer tag. -data ImGuiListClipper - --- | A unique ID used by widgets (typically the result of hashing a stack of string) --- unsigned Integer (same as ImU32) -type ImGuiID = Word32 - --- | 32-bit unsigned integer (often used to store packed colors). -type ImU32 = Word32 - -type ImS16 = Int16 - --- | Single wide character (used mostly in glyph management) -#ifdef IMGUI_USE_WCHAR32 -type ImWchar = Word32 -#else -type ImWchar = Word16 -#endif - --------------------------------------------------------------------------------- - -- | DearImPlot context handle data ImPlotContext diff --git a/src/DearImGui/Raw/Plot.hs b/src/DearImGui/Raw/Plot.hs index c142c60..b2112e9 100644 --- a/src/DearImGui/Raw/Plot.hs +++ b/src/DearImGui/Raw/Plot.hs @@ -27,7 +27,7 @@ module DearImGui.Raw.Plot , endPlot , plotLine - , setNextPlotLimits + -- , setNextPlotLimits ) where -- base @@ -39,10 +39,12 @@ import System.IO.Unsafe ( unsafePerformIO ) -- dear-imgui +import DearImGui import DearImGui.Context - ( imguiContext, implotContext ) -import DearImGui.Enums -import DearImGui.Structs +import DearImGui.Plot.Context + ( implotContext ) +import DearImGui.Plot.Enums +import DearImGui.Plot.Structs import DearImGui.Raw.DrawList (DrawList(..)) -- inline-c @@ -97,10 +99,10 @@ endPlot :: MonadIO m => m () endPlot = liftIO do [C.exp| void { EndPlot(); } |] -plotLine :: MonadIO m => CString -> Ptr Float -> Ptr Float -> CInt -> m () +plotLine :: MonadIO m => CString -> Ptr CFloat -> Ptr CFloat -> CInt -> m () plotLine label xsPtr ysPtr size = liftIO do - [C.exp| void { PlotLine( $(char* descPtr), $(float *xsPtr), $(float *ysPtr), $(int size) ) } |] + [C.exp| void { PlotLine( $(char* label), $(float *xsPtr), $(float *ysPtr), $(int size) ) } |] -setNextPlotLimits :: MonadIO m => (Double, Double) -> (Double, Double) -> m () -setNextPlotLimits (minX, maxX) (minY, maxY) = liftIO do - [C.exp| void { SetNextPlotLimits( $(double minX), $(double maxX), $(double minY), $(double maxY) ) } |] +-- setNextPlotLimits :: MonadIO m => (CDouble, CDouble) -> (CDouble, CDouble) -> m () +-- setNextPlotLimits (minX, maxX) (minY, maxY) = liftIO do +-- [C.exp| void { SetNextPlotLimits( $(double minX), $(double maxX), $(double minY), $(double maxY) ) } |] diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs new file mode 120000 index 0000000..c3d0560 --- /dev/null +++ b/src/DearImGui/Structs.hs @@ -0,0 +1 @@ +../../dear-imgui.hs/src/DearImGui/Structs.hs \ No newline at end of file