Merge pull request #112 from well-typed/edsko/basic-comments

Basic comment parsing support

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
  */

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

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

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.

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

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;
+};

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;

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

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
+

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