diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.c b/hs-bindgen-libclang/cbits/clang_wrappers.c index 0805409d..f2dffaaa 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.c +++ b/hs-bindgen-libclang/cbits/clang_wrappers.c @@ -52,6 +52,19 @@ CXString* wrap_malloc_getCursorSpelling(CXCursor* cursor) { return result; } +CXString* wrap_malloc_Cursor_getRawCommentText(CXCursor* C) { + CXString* result = malloc(sizeof(CXString)); + *result = clang_Cursor_getRawCommentText(*C); + return result; +} + +CXString* wrap_malloc_Cursor_getBriefCommentText(CXCursor* C) { + CXString* result = malloc(sizeof(CXString)); + *result = clang_Cursor_getBriefCommentText(*C); + return result; +} + + /** * Type information for CXCursors */ diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.h b/hs-bindgen-libclang/cbits/clang_wrappers.h index 9de678f7..aa93f458 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.h +++ b/hs-bindgen-libclang/cbits/clang_wrappers.h @@ -31,6 +31,8 @@ unsigned wrap_malloc_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor); CXString* wrap_malloc_getCursorDisplayName(CXCursor* cursor); CXString* wrap_malloc_getCursorSpelling(CXCursor* cursor); +CXString* wrap_malloc_Cursor_getRawCommentText(CXCursor* C); +CXString* wrap_malloc_Cursor_getBriefCommentText(CXCursor* C); /** * Type information for CXCursors diff --git a/hs-bindgen-libclang/src/HsBindgen/C/Clang.hs b/hs-bindgen-libclang/src/HsBindgen/C/Clang.hs index 1031ccfd..b940c2e5 100644 --- a/hs-bindgen-libclang/src/HsBindgen/C/Clang.hs +++ b/hs-bindgen-libclang/src/HsBindgen/C/Clang.hs @@ -58,6 +58,8 @@ module HsBindgen.C.Clang ( , CXString , clang_getCursorDisplayName , clang_getCursorSpelling + , clang_Cursor_getRawCommentText + , clang_Cursor_getBriefCommentText -- * Type information for CXCursors , CXTypeKind(..) , CXType @@ -389,6 +391,34 @@ clang_getCursorSpelling cursor = withForeignPtr cursor $ \cursor' -> packCXString =<< clang_getCursorSpelling' cursor' +foreign import capi unsafe "clang_wrappers.h wrap_malloc_Cursor_getRawCommentText" + clang_Cursor_getRawCommentText' :: + Ptr CXCursor + -> IO (Ptr CXString) + +-- | Given a cursor that represents a declaration, return the associated comment +-- text, including comment markers. +clang_Cursor_getRawCommentText :: + ForeignPtr CXCursor + -> IO Strict.ByteString +clang_Cursor_getRawCommentText cursor = + withForeignPtr cursor $ \cursor' -> packCXString =<< + clang_Cursor_getRawCommentText' cursor' + +foreign import capi unsafe "clang_wrappers.h wrap_malloc_Cursor_getBriefCommentText" + clang_Cursor_getBriefCommentText' :: + Ptr CXCursor + -> IO (Ptr CXString) + +-- | Given a cursor that represents a documentable entity (e.g., declaration), +-- return the associated brief comment. +clang_Cursor_getBriefCommentText :: + ForeignPtr CXCursor + -> IO Strict.ByteString +clang_Cursor_getBriefCommentText cursor = + withForeignPtr cursor $ \cursor' -> packCXString =<< + clang_Cursor_getBriefCommentText' cursor' + {------------------------------------------------------------------------------- Type information for CXCursors @@ -661,9 +691,11 @@ foreign import capi unsafe "clang_wrappers.h wrap_disposeString" packCXString :: Ptr CXString -> IO Strict.ByteString packCXString str = bracket - (clang_getCString str) - (\_ -> clang_disposeString str >> free str) $ - BS.Strict.packCString + (clang_getCString str) + (\_ -> clang_disposeString str >> free str) $ \cstr -> + if cstr == nullPtr + then return BS.Strict.empty + else BS.Strict.packCString cstr {------------------------------------------------------------------------------- Checking for error results diff --git a/hs-bindgen-libclang/src/HsBindgen/C/Clang/Enums.hs b/hs-bindgen-libclang/src/HsBindgen/C/Clang/Enums.hs index e82c6286..467cff94 100644 --- a/hs-bindgen-libclang/src/HsBindgen/C/Clang/Enums.hs +++ b/hs-bindgen-libclang/src/HsBindgen/C/Clang/Enums.hs @@ -95,7 +95,7 @@ data CXTranslationUnit_Flag = -- | Sets the preprocessor in a mode for parsing a single file only. | CXTranslationUnit_SingleFileParse - -- | Used in combination with CXTranslationUnit_SkipFunctionBodies to + -- | Used in combination with 'CXTranslationUnit_SkipFunctionBodies' to -- constrain the skipping of function bodies to the preamble. -- -- The function bodies of the main file are not skipped. diff --git a/hs-bindgen/app/Main.hs b/hs-bindgen/app/Main.hs index a0d95bd4..00e516bf 100644 --- a/hs-bindgen/app/Main.hs +++ b/hs-bindgen/app/Main.hs @@ -20,5 +20,6 @@ main = do preprocess tracer clangArgs input moduleOpts renderOpts output ParseCHeader{input} -> prettyC =<< parseCHeader tracer clangArgs input - ShowClangAST{input} -> - putStr . drawForest =<< showClangAST clangArgs input + ShowClangAST{input} -> do + ast <- getClangAST clangArgs input + putStr . drawForest $ fmap (fmap show) ast diff --git a/hs-bindgen/examples/comments.h b/hs-bindgen/examples/comments.h new file mode 100644 index 00000000..b56f9250 --- /dev/null +++ b/hs-bindgen/examples/comments.h @@ -0,0 +1,18 @@ +/** + * A struct with a Doxygen comment + */ +struct S4 { + /** + * A field preceded by a Doxygen comment + */ + char a; + + int b; /**< A field followed by a Doxygen comment */ + + /** + * A field that refers to another field + * + * See also @ref S4::a + */ + float c; +}; \ No newline at end of file diff --git a/hs-bindgen/examples/simple_structs.h b/hs-bindgen/examples/simple_structs.h index 0ffc5bd3..b1a62ff4 100644 --- a/hs-bindgen/examples/simple_structs.h +++ b/hs-bindgen/examples/simple_structs.h @@ -6,7 +6,7 @@ struct S1 { // struct with typedef typedef struct S2 { - char a; + char a; int b; float c; } S2_t; diff --git a/hs-bindgen/src/HsBindgen/C/Parser.hs b/hs-bindgen/src/HsBindgen/C/Parser.hs index 8b8b8e65..dc6352c7 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser.hs +++ b/hs-bindgen/src/HsBindgen/C/Parser.hs @@ -6,7 +6,10 @@ module HsBindgen.C.Parser ( parseHeaderWith , foldDecls - , foldShowAST + -- * Debugging + , Element(..) + , foldClangAST + -- * Logging , ParseMsg(..) ) where @@ -139,6 +142,16 @@ primType = either (const Nothing) aux . fromSimpleEnum Debugging -------------------------------------------------------------------------------} +-- | An element in the @libclang@ AST +data Element = Element { + elementDisplayName :: Strict.ByteString + , elementTypeKind :: SimpleEnum CXTypeKind + , elementTypeKindSpelling :: Strict.ByteString + , elementRawComment :: Strict.ByteString + , elementBriefComment :: Strict.ByteString + } + deriving (Show) + -- | Fold that simply tries to show the @libclang@ AST -- -- We can use this at the top-level in 'dumpClangAST', but it is also useful @@ -151,25 +164,30 @@ primType = either (const Nothing) aux . fromSimpleEnum -- > cursorType <- clang_getCursorType current -- > case fromSimpleEnum $ cxtKind cursorType of -- > Right CXType_Record -> do --- > return $ Recurse foldShowAST $ \t -> print t >> return Nothing +-- > return $ Recurse foldClangAST $ \t -> print t >> return Nothing -- -- to see the AST under the @struct@ parent node. -foldShowAST :: Fold (Tree String) -foldShowAST = go +foldClangAST :: Fold (Tree Element) +foldClangAST = go where - go :: Fold (Tree String) + go :: Fold (Tree Element) go current = do - displayName <- clang_getCursorDisplayName current - cursorType <- clang_getCursorType current - typeKind <- clang_getTypeKindSpelling (cxtKind cursorType) - - let node = mconcat - [ show displayName - , " :: " - , show typeKind - ] - - return $ Recurse go (return . Just . Node node) + elementDisplayName <- clang_getCursorDisplayName current + elementTypeKind <- cxtKind <$> clang_getCursorType current + elementTypeKindSpelling <- clang_getTypeKindSpelling elementTypeKind + elementRawComment <- clang_Cursor_getRawCommentText current + elementBriefComment <- clang_Cursor_getBriefCommentText current + + let element :: Element + element = Element { + elementDisplayName + , elementTypeKind + , elementTypeKindSpelling + , elementRawComment + , elementBriefComment + } + + return $ Recurse go (return . Just . Node element) {------------------------------------------------------------------------------- Auxiliary: strings diff --git a/hs-bindgen/src/HsBindgen/Lib.hs b/hs-bindgen/src/HsBindgen/Lib.hs index 2dd0b090..52e2e5be 100644 --- a/hs-bindgen/src/HsBindgen/Lib.hs +++ b/hs-bindgen/src/HsBindgen/Lib.hs @@ -18,7 +18,6 @@ module HsBindgen.Lib ( , ParseMsg -- opaque , ClangArgs , parseCHeader - , showClangAST -- * Translation , HsModuleOpts(..) @@ -34,6 +33,10 @@ module HsBindgen.Lib ( -- * Common pipelines , preprocess + -- * Debugging + , Element(..) + , getClangAST + -- * Logging , Tracer , contramap @@ -49,7 +52,7 @@ import Text.Show.Pretty qualified as Pretty import HsBindgen.C.AST qualified as C import HsBindgen.C.Clang.Args -import HsBindgen.C.Parser (ParseMsg) +import HsBindgen.C.Parser (ParseMsg, Element(..)) import HsBindgen.C.Parser qualified as C import HsBindgen.Hs.Annotation import HsBindgen.Hs.Render (HsRenderOpts(..)) @@ -93,12 +96,6 @@ parseCHeader :: parseCHeader tracer args fp = WrapCHeader . C.Header <$> C.parseHeaderWith args fp (C.foldDecls tracer) --- | Show the raw @libclang@ AST --- --- This is primarily for debugging. -showClangAST :: ClangArgs -> FilePath -> IO (Forest String) -showClangAST args fp = C.parseHeaderWith args fp C.foldShowAST - {------------------------------------------------------------------------------- Translation -------------------------------------------------------------------------------} @@ -138,3 +135,13 @@ preprocess tracer clangArgs inp modOpts renderOpts out = do modl <- genModule modOpts <$> parseCHeader tracer clangArgs inp prettyHs renderOpts out modl +{------------------------------------------------------------------------------- + Debugging +-------------------------------------------------------------------------------} + +-- | Show the raw @libclang@ AST +-- +-- This is primarily for debugging. +getClangAST :: ClangArgs -> FilePath -> IO (Forest Element) +getClangAST args fp = C.parseHeaderWith args fp C.foldClangAST + diff --git a/hs-bindgen/tests/golden.hs b/hs-bindgen/tests/golden.hs index 2ff491ae..ab8860ec 100644 --- a/hs-bindgen/tests/golden.hs +++ b/hs-bindgen/tests/golden.hs @@ -16,17 +16,25 @@ main = do [ goldenVsStringDiff "simple_structs" diff "fixtures/simple_structs.dump.txt" $ do let fp = "examples/simple_structs.h" args = [] - res <- showClangAST args fp + res <- getClangAST args fp return $ LBS8.pack $ unlines $ concatMap treeToLines res ] where diff ref new = ["diff", "-u", ref, new] -treeToLines :: Tree String -> [String] +treeToLines :: Tree Element -> [String] treeToLines tree = go 0 tree [] where - go :: Int -> Tree String -> [String] -> [String] - go !n (Node l xs) next = (replicate (n * 2) ' ' ++ l) : foldr (go (n + 1)) next xs + go :: Int -> Tree Element -> [String] -> [String] + go !n (Node l xs) next = (replicate (n * 2) ' ' ++ showElem l) : foldr (go (n + 1)) next xs + +showElem :: Element -> [Char] +showElem Element{elementDisplayName, elementTypeKindSpelling} = mconcat [ + show elementDisplayName + , " :: " + , show elementTypeKindSpelling + ] + -- | In multi-package projects @cabal run test-suite@ will run the test-suite -- from your current working directory (e.g. project root), which is often