From 1bcdb8391f11021d0e635ce2758cefa5b7d0393c Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 3 Oct 2024 12:55:34 +0200 Subject: [PATCH] Overhaul treatment of source locations We are now much more precise; see discussion of `MultiLoc` in `src/HsBindgen/Clang/Util/SourceLoc/Type.hs` for details. --- hs-bindgen-libclang/cbits/clang_wrappers.c | 10 + hs-bindgen-libclang/cbits/clang_wrappers.h | 28 +- hs-bindgen-libclang/hs-bindgen-libclang.cabal | 1 + .../src/HsBindgen/Clang/Core.hs | 301 +++++++++++++++--- .../src/HsBindgen/Clang/Internal/ByValue.hs | 2 +- .../HsBindgen/Clang/Util/Classification.hs | 36 ++- .../src/HsBindgen/Clang/Util/Diagnostics.hs | 8 +- .../src/HsBindgen/Clang/Util/SourceLoc.hs | 271 ++++++++-------- .../HsBindgen/Clang/Util/SourceLoc/Type.hs | 208 ++++++++++++ .../src/HsBindgen/Clang/Util/Tokens.hs | 23 +- .../app/HsBindgen/App/RenderComments.hs | 16 +- hs-bindgen/fixtures/enums.tree-diff.txt | 16 +- .../fixtures/macro_functions.tree-diff.txt | 32 +- hs-bindgen/fixtures/macros.tree-diff.txt | 208 +++++++----- hs-bindgen/fixtures/uses_utf8.tree-diff.txt | 16 +- hs-bindgen/src/HsBindgen/Bootstrap/Prelude.hs | 17 +- hs-bindgen/src/HsBindgen/C/AST.hs | 7 +- hs-bindgen/src/HsBindgen/C/AST/Macro.hs | 9 +- hs-bindgen/src/HsBindgen/C/Parser.hs | 43 ++- hs-bindgen/src/HsBindgen/C/Parser/Macro.hs | 30 +- hs-bindgen/src/HsBindgen/Lib.hs | 4 +- hs-bindgen/tests/Orphans.hs | 7 +- 22 files changed, 921 insertions(+), 372 deletions(-) create mode 100644 hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc/Type.hs diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.c b/hs-bindgen-libclang/cbits/clang_wrappers.c index 0f2f64a..9b78f57 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.c +++ b/hs-bindgen-libclang/cbits/clang_wrappers.c @@ -13,3 +13,13 @@ enum CXChildVisitResult wrap_visitor(CXCursor cursor, CXCursor parent, CXClientD WrapCXCursorVisitor visitor = client_data; return visitor(&cursor, &parent); } + +/** + * Debugging + */ + +void clang_breakpoint(void) { + static int i = 0; + fprintf(stderr, "clang_breakpoint: %d\n", ++i); +} + diff --git a/hs-bindgen-libclang/cbits/clang_wrappers.h b/hs-bindgen-libclang/cbits/clang_wrappers.h index 71e6b09..c071dd0 100644 --- a/hs-bindgen-libclang/cbits/clang_wrappers.h +++ b/hs-bindgen-libclang/cbits/clang_wrappers.h @@ -217,6 +217,10 @@ static inline void wrap_getCursorKindSpelling(enum CXCursorKind Kind, CXString* *result = clang_getCursorKindSpelling(Kind); } +static inline CXTranslationUnit wrap_Cursor_getTranslationUnit(const CXCursor* cursor) { + return clang_Cursor_getTranslationUnit(*cursor); +} + /** * Traversing the AST with cursors * @@ -419,10 +423,26 @@ static inline void wrap_getExpansionLocation(const CXSourceLocation* location, C clang_getExpansionLocation(*location, file, line, column, offset); } +static inline void wrap_getPresumedLocation(const CXSourceLocation* location, CXString* filename, unsigned* line, unsigned* column) { + clang_getPresumedLocation(*location, filename, line, column); +} + static inline void wrap_getSpellingLocation(const CXSourceLocation* location, CXFile* file, unsigned* line, unsigned* column, unsigned* offset) { clang_getSpellingLocation(*location, file, line, column, offset); } +static inline void wrap_getFileLocation(const CXSourceLocation* location, CXFile* file, unsigned* line, unsigned* column, unsigned* offset) { + clang_getFileLocation(*location, file, line, column, offset); +} + +static inline void wrap_getLocation(CXTranslationUnit tu, CXFile file, unsigned line, unsigned column, CXSourceLocation* result) { + *result = clang_getLocation(tu, file, line, column); +} + +static inline void wrap_getRange(const CXSourceLocation* begin, const CXSourceLocation* end, CXSourceRange* result) { + *result = clang_getRange(*begin, *end); +} + static inline int wrap_Location_isFromMainFile(const CXSourceLocation* location) { return clang_Location_isFromMainFile(*location); } @@ -448,4 +468,10 @@ static inline void wrap_disposeString(const CXString* string) { clang_disposeString(*string); } -#endif +/** + * Debugging + */ + +void clang_breakpoint(void); + +#endif \ No newline at end of file diff --git a/hs-bindgen-libclang/hs-bindgen-libclang.cabal b/hs-bindgen-libclang/hs-bindgen-libclang.cabal index 3deec79..8edcb3c 100644 --- a/hs-bindgen-libclang/hs-bindgen-libclang.cabal +++ b/hs-bindgen-libclang/hs-bindgen-libclang.cabal @@ -65,6 +65,7 @@ library HsBindgen.Clang.Util.Diagnostics HsBindgen.Clang.Util.Fold HsBindgen.Clang.Util.SourceLoc + HsBindgen.Clang.Util.SourceLoc.Type HsBindgen.Clang.Util.Tokens other-modules: HsBindgen.Clang.Core.Enums diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs index ba14ca4..39a9776 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Core.hs @@ -98,6 +98,8 @@ module HsBindgen.Clang.Core ( , clang_getCursorLexicalParent , clang_getCursorKind , clang_getCursorKindSpelling + , clang_Cursor_getTranslationUnit + , clang_isDeclaration -- * Traversing the AST with cursors , CXChildVisitResult(..) , clang_visitChildren @@ -152,13 +154,21 @@ module HsBindgen.Clang.Core ( , index_CXCursorArray -- * Physical source locations , CXSourceLocation + , CXFile , clang_getRangeStart , clang_getRangeEnd , clang_getExpansionLocation + , clang_getPresumedLocation , clang_getSpellingLocation + , clang_getFileLocation + , clang_getLocation + , clang_getRange + , clang_getFile , clang_Location_isFromMainFile -- * File manipulation routines , clang_getFileName + -- * Debugging + , clang_breakpoint -- * Exceptions , CallFailed(..) , Unsupported(..) @@ -610,6 +620,9 @@ foreign import capi unsafe "clang_wrappers.h wrap_getCursorKind" foreign import capi unsafe "clang_wrappers.h wrap_getCursorKindSpelling" wrap_getCursorKindSpelling :: SimpleEnum CXCursorKind -> W CXString_ -> IO () +foreign import capi unsafe "wrap_Cursor_getTranslationUnit" + wrap_Cursor_getTranslationUnit :: R CXCursor_ -> IO CXTranslationUnit + -- | Retrieve the cursor that represents the given translation unit. -- -- The translation unit cursor can be used to start traversing the various @@ -722,6 +735,23 @@ clang_getCursorKindSpelling :: SimpleEnum CXCursorKind -> IO Text clang_getCursorKindSpelling kind = preallocate_ $ wrap_getCursorKindSpelling kind +-- | Returns the translation unit that a cursor originated from. +-- +-- +clang_Cursor_getTranslationUnit :: CXCursor -> IO (Maybe CXTranslationUnit) +clang_Cursor_getTranslationUnit cursor = checkNotNull $ + onHaskellHeap cursor $ \cursor' -> + wrap_Cursor_getTranslationUnit cursor' + +foreign import capi unsafe "clang-c/Index.h clang_isDeclaration" + nowrapper_isDeclaration :: SimpleEnum CXCursorKind -> IO CUInt + +-- | Determine whether the given cursor kind represents a declaration. +-- +-- +clang_isDeclaration :: SimpleEnum CXCursorKind -> IO Bool +clang_isDeclaration kind = cToBool <$> nowrapper_isDeclaration kind + {------------------------------------------------------------------------------- Traversing the AST with cursors @@ -1031,12 +1061,11 @@ clang_getTypeSpelling typ = ensure (not . Text.null) $ -- | Retrieve the underlying type of a typedef declaration. -- --- If the cursor does not reference a typedef declaration, an invalid type is --- returned. +-- Throws 'CallFailed' if the cursor does not reference a typedef declaration. -- -- clang_getTypedefDeclUnderlyingType :: CXCursor -> IO CXType -clang_getTypedefDeclUnderlyingType cursor = +clang_getTypedefDeclUnderlyingType cursor = ensureValidType $ onHaskellHeap cursor $ \cursor' -> preallocate_ $ wrap_getTypedefDeclUnderlyingType cursor' @@ -1190,10 +1219,9 @@ clang_getTypeDeclaration typ = -- -- clang_Type_getNamedType :: HasCallStack => CXType -> IO CXType -clang_Type_getNamedType typ = - ensureOn (fromSimpleEnum . cxtKind) (/= Right CXType_Invalid) $ - onHaskellHeap typ $ \typ' -> - preallocate_ $ wrap_Type_getNamedType typ' +clang_Type_getNamedType typ = ensureValidType $ + onHaskellHeap typ $ \typ' -> + preallocate_ $ wrap_Type_getNamedType typ' -- | Return the type that was modified by this attributed type. -- @@ -1201,10 +1229,9 @@ clang_Type_getNamedType typ = -- -- clang_Type_getModifiedType :: HasCallStack => CXType -> IO CXType -clang_Type_getModifiedType typ = - ensureOn (fromSimpleEnum . cxtKind) (/= Right CXType_Invalid) $ - onHaskellHeap typ $ \typ' -> - preallocate_ $ wrap_Type_getModifiedType typ' +clang_Type_getModifiedType typ = ensureValidType $ + onHaskellHeap typ $ \typ' -> + preallocate_ $ wrap_Type_getModifiedType typ' -- | Gets the type contained by this atomic type. -- @@ -1212,10 +1239,9 @@ clang_Type_getModifiedType typ = -- -- clang_Type_getValueType :: HasCallStack => CXType -> IO CXType -clang_Type_getValueType typ = - ensureOn (fromSimpleEnum . cxtKind) (/= Right CXType_Invalid) $ - onHaskellHeap typ $ \typ' -> - preallocate_ $ wrap_Type_getValueType typ' +clang_Type_getValueType typ = ensureValidType $ + onHaskellHeap typ $ \typ' -> + preallocate_ $ wrap_Type_getValueType typ' {------------------------------------------------------------------------------- Mapping between cursors and source code @@ -1431,34 +1457,105 @@ foreign import capi unsafe "clang_wrappers.h wrap_getRangeStart" foreign import capi unsafe "clang_wrappers.h wrap_getRangeEnd" wrap_getRangeEnd :: R CXSourceRange_ -> W CXSourceLocation_ -> IO () -foreign import capi "clang_wrappers.h wrap_getExpansionLocation" +foreign import capi unsafe "clang_wrappers.h wrap_getExpansionLocation" wrap_getExpansionLocation :: R CXSourceLocation_ - -- ^ the location within a source file that will be decomposed into its parts. + -- ^ the location within a source file that will be decomposed into its + -- parts. -> Ptr CXFile - -- ^ [out] if non-NULL, will be set to the file to which the given source location points. + -- ^ [out] if non-NULL, will be set to the file to which the given source + -- location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the line to which the given source location points. + -- ^ [out] if non-NULL, will be set to the line to which the given source + -- location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the column to which the given source location points. + -- ^ [out] if non-NULL, will be set to the column to which the given + -- source location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the offset into the buffer to which the given source location points. + -- ^ [out] if non-NULL, will be set to the offset into the buffer to + -- which the given source location points. -> IO () -foreign import capi "clang_wrappers.h wrap_getSpellingLocation" +foreign import capi unsafe "clang_wrappers.h wrap_getPresumedLocation" + wrap_getPresumedLocation :: + R CXSourceLocation_ + -- ^ the location within a source file that will be decomposed into its + -- parts. + -> W CXString_ + -- ^ [out] if non-NULL, will be set to the filename of the source + -- location. + -- + -- Note that filenames returned will be for "virtual" files, which don't + -- necessarily exist on the machine running clang - e.g. when parsing + -- preprocessed output obtained from a different environment. If a + -- non-NULL value is passed in, remember to dispose of the returned value + -- using clang_disposeString() once you've finished with it. For an + -- invalid source location, an empty string is returned. + -> Ptr CUInt + -- ^ [out] if non-NULL, will be set to the line number of the source + -- location. For an invalid source location, zero is returned. + -> Ptr CUInt + -- ^ [out] if non-NULL, will be set to the column number of the source + -- location. For an invalid source location, zero is returned. + -> IO () + +foreign import capi unsafe "clang_wrappers.h wrap_getSpellingLocation" wrap_getSpellingLocation :: R CXSourceLocation_ - -- ^ the location within a source file that will be decomposed into its parts. + -- ^ the location within a source file that will be decomposed into its + -- parts. + -> Ptr CXFile + -- ^ [out] if non-NULL, will be set to the file to which the given source + -- location points. + -> Ptr CUInt + -- ^ [out] if non-NULL, will be set to the line to which the given source + -- location points. + -> Ptr CUInt + -- ^ [out] if non-NULL, will be set to the column to which the given + -- source location points. + -> Ptr CUInt + -- ^ [out] if non-NULL, will be set to the offset into the buffer to + -- which the given source location points. + -> IO () + +foreign import capi unsafe "clang_wrappers.h wrap_getFileLocation" + wrap_getFileLocation :: + R CXSourceLocation_ + -- ^ the location within a source file that will be decomposed into its + -- parts. -> Ptr CXFile - -- ^ [out] if non-NULL, will be set to the file to which the given source location points. + -- ^ [out] if non-NULL, will be set to the file to which the given source + -- location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the line to which the given source location points. + -- ^ [out] if non-NULL, will be set to the line to which the given source + -- location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the column to which the given source location points. + -- ^ [out] if non-NULL, will be set to the column to which the given + -- source location points. -> Ptr CUInt - -- ^ [out] if non-NULL, will be set to the offset into the buffer to which the given source location points. + -- ^ [out] if non-NULL, will be set to the offset into the buffer to + -- which the given source location points. + -> IO () + +foreign import capi unsafe "clang_wrappers.h wrap_getLocation" + wrap_getLocation :: + CXTranslationUnit + -> CXFile + -> CUInt + -> CUInt + -> W CXSourceLocation_ -> IO () +foreign import capi unsafe "clang_wrappers.h wrap_getRange" + wrap_getRange :: + R CXSourceLocation_ + -> R CXSourceLocation_ + -> W CXSourceRange_ + -> IO () + +foreign import capi unsafe "clang-c/Index.h clang_getFile" + nowrapper_getFile :: CXTranslationUnit -> CString -> IO CXFile + foreign import capi "clang_wrappers.h wrap_Location_isFromMainFile" wrap_Location_isFromMainFile :: R CXSourceLocation_ -> IO CInt @@ -1486,20 +1583,54 @@ clang_getRangeEnd range = -- If the location refers into a macro expansion, retrieves the location of the -- macro expansion. -- --- Returns the file, line, column and offset into the buffer. +-- NOTE: this replaces @clang_getInstantiationLocation@ (now legacy). -- -- clang_getExpansionLocation :: CXSourceLocation -> IO (CXFile, CUInt, CUInt, CUInt) clang_getExpansionLocation location = - onHaskellHeap location $ \location' -> - alloca $ \file -> - alloca $ \line -> - alloca $ \column -> - alloca $ \offset -> do - wrap_getExpansionLocation location' file line column offset - (,,,) <$> peek file <*> peek line <*> peek column <*> peek offset + onHaskellHeap location $ \location' -> + alloca $ \file -> + alloca $ \line -> + alloca $ \column -> + alloca $ \offset -> do + wrap_getExpansionLocation location' file line column offset + (,,,) <$> peek file <*> peek line <*> peek column <*> peek offset + +-- | Retrieve the file, line and column represented by the given source +-- location, as specified in a @#line@ directive. +-- +-- Note that filenames returned will be for "virtual" files, which don't +-- necessarily exist on the machine running clang - e.g. when parsing +-- preprocessed output obtained from a different environment. +-- +-- Example: given the following source code in a file somefile.c +-- +-- > #123 "dummy.c" 1 +-- > +-- > static int func(void) +-- > { +-- > return 0; +-- > } +-- +-- the location information returned by this function would be +-- +-- > File: dummy.c Line: 124 Column: 12 +-- +-- whereas 'clang_getExpansionLocation' would have returned +-- +-- > File: somefile.c Line: 3 Column: 12 +-- +-- +clang_getPresumedLocation :: CXSourceLocation -> IO (Text, CUInt, CUInt) +clang_getPresumedLocation location = + onHaskellHeap location $ \location' -> + alloca $ \line -> + alloca $ \column -> do + filename' <- preallocate_ $ \filename -> + wrap_getPresumedLocation location' filename line column + (filename',,) <$> peek line <*> peek column -- | Retrieve the file, line, column, and offset represented by the given source -- location. @@ -1507,20 +1638,71 @@ clang_getExpansionLocation location = -- If the location refers into a macro instantiation, return where the location -- was originally spelled in the source file. -- --- See also 'clang_getExpansionLocation'. --- -- clang_getSpellingLocation :: CXSourceLocation -> IO (CXFile, CUInt, CUInt, CUInt) clang_getSpellingLocation location = - onHaskellHeap location $ \location' -> - alloca $ \file -> - alloca $ \line -> - alloca $ \column -> - alloca $ \offset -> do - wrap_getSpellingLocation location' file line column offset - (,,,) <$> peek file <*> peek line <*> peek column <*> peek offset + onHaskellHeap location $ \location' -> + alloca $ \file -> + alloca $ \line -> + alloca $ \column -> + alloca $ \offset -> do + wrap_getSpellingLocation location' file line column offset + (,,,) <$> peek file <*> peek line <*> peek column <*> peek offset + +-- | Retrieve the file, line, column, and offset represented by the given source +-- location. +-- +-- If the location refers into a macro expansion, return where the macro was +-- expanded or where the macro argument was written, if the location points at a +-- macro argument. +-- +-- +clang_getFileLocation :: + CXSourceLocation + -> IO (CXFile, CUInt, CUInt, CUInt) +clang_getFileLocation location = + onHaskellHeap location $ \location' -> + alloca $ \file -> + alloca $ \line -> + alloca $ \column -> + alloca $ \offset -> do + wrap_getFileLocation location' file line column offset + (,,,) <$> peek file <*> peek line <*> peek column <*> peek offset + +-- | Retrieves the source location associated with a given file/line/column in a +-- particular translation unit. +-- +-- +clang_getLocation :: + CXTranslationUnit + -> CXFile + -> CUInt -- ^ Line + -> CUInt -- ^ Column + -> IO CXSourceLocation +clang_getLocation unit file line col = + preallocate_ $ wrap_getLocation unit file line col + +-- | Retrieve a source range given the beginning and ending source locations. +-- +-- +clang_getRange :: CXSourceLocation -> CXSourceLocation -> IO CXSourceRange +clang_getRange begin end = + onHaskellHeap begin $ \begin' -> + onHaskellHeap end $ \end' -> + preallocate_ $ wrap_getRange begin' end' + +-- | Retrieve a file handle within the given translation unit. +-- +-- Returns the file handle for the named file in the translation unit. +-- Throws 'CallFailed' if the file was not a part of this translation unit. +-- +-- +clang_getFile :: CXTranslationUnit -> Text -> IO CXFile +clang_getFile unit file = ensureNotNull $ + withCString (Text.unpack file) $ \file' -> + nowrapper_getFile unit file' -- | Check if the given source location is in the main file of the corresponding -- translation unit. @@ -1545,3 +1727,34 @@ foreign import capi "clang_wrappers.h wrap_getFileName" -- clang_getFileName :: CXFile -> IO Text clang_getFileName file = preallocate_$ wrap_getFileName file + +{------------------------------------------------------------------------------- + Debugging +-------------------------------------------------------------------------------} + +-- | Debugging breakpoint hook +-- +-- Every call to @clang_breakpoint@ prints +-- +-- > clang_breakpoint: +-- +-- to @stderr@, for an ever increasing @@ (starting at 1). This is useful +-- for debugging; for example, if you want a breakpoint on the 13th invocation: +-- +-- > break clang_breakpoint +-- > ignore 1 12 +foreign import capi "clang_wrappers.h clang_breakpoint" + clang_breakpoint :: IO () + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +ensureValidType :: HasCallStack => IO CXType -> IO CXType +ensureValidType = ensure (aux . fromSimpleEnum . cxtKind) + where + aux :: Either CInt CXTypeKind -> Bool + aux (Left _) = False + aux (Right CXType_Invalid) = False + aux _otherwise = True + diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Internal/ByValue.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Internal/ByValue.hs index c04deb9..9dcd7c4 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Internal/ByValue.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Internal/ByValue.hs @@ -104,7 +104,7 @@ class Preallocate a where -- See 'onHaskellHeap' for rationale. preallocate :: (Writing a -> IO r) -> IO (a, r) -preallocate_ :: Preallocate a => (Writing a -> IO ()) -> IO a +preallocate_ :: Preallocate a => (Writing a -> IO ()) -> IO a preallocate_ = fmap fst . preallocate instance HasKnownSize tag => Preallocate (OnHaskellHeap tag) where diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Classification.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Classification.hs index 12ea7c0..35f5d66 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Classification.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Classification.hs @@ -57,23 +57,29 @@ getUserProvided (LibclangProvided _) = Nothing -- @libclang@ fills in a name (\"spelling\") for the struct tag, even though the -- user did not provide one; recent versions of @llvm@ fill in @S3_t@ (@""@ in -- older versions). -getUserProvidedName :: - CXTranslationUnit - -> CXCursor - -> IO (UserProvided Text) -getUserProvidedName unit cursor = do +getUserProvidedName :: CXCursor -> IO (UserProvided Text) +getUserProvidedName cursor = do nameSpelling <- clang_getCursorSpelling cursor - nameRange <- clang_Cursor_getSpellingNameRange cursor 0 0 - nameStart <- clang_getRangeStart nameRange - mNameToken <- clang_getToken unit nameStart - case mNameToken of - Just nameToken -> do - nameTokenSpelling <- clang_getTokenSpelling unit nameToken - return $ if nameSpelling == nameTokenSpelling - then UserProvided nameSpelling - else LibclangProvided nameSpelling + -- We could /ask/ for the @unit@ to be given to us, but the call to + -- 'clang_getCursorSpelling' is a useful check; for example, it may reveal + -- that the result of a call to 'clang_getTypeDeclaration' is not a cursor + -- for which we have a translation unit, and hence not one on which we can + -- call 'clang_Cursor_getSpellingNameRange'. + mUnit <- clang_Cursor_getTranslationUnit cursor + case mUnit of Nothing -> return $ LibclangProvided nameSpelling + Just unit -> do + nameRange <- clang_Cursor_getSpellingNameRange cursor 0 0 + nameStart <- clang_getRangeStart nameRange + mNameToken <- clang_getToken unit nameStart - + case mNameToken of + Just nameToken -> do + nameTokenSpelling <- clang_getTokenSpelling unit nameToken + return $ if nameSpelling == nameTokenSpelling + then UserProvided nameSpelling + else LibclangProvided nameSpelling + Nothing -> + return $ LibclangProvided nameSpelling diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Diagnostics.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Diagnostics.hs index dec30bb..ad508f3 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Diagnostics.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Diagnostics.hs @@ -11,7 +11,7 @@ import Data.Text qualified as Text import Foreign.C import HsBindgen.Clang.Core -import HsBindgen.Clang.Util.SourceLoc (SourceLoc, SourceRange) +import HsBindgen.Clang.Util.SourceLoc.Type import HsBindgen.Clang.Util.SourceLoc qualified as SourceLoc import HsBindgen.Patterns @@ -27,7 +27,7 @@ data Diagnostic = Diagnostic { , diagnosticSeverity :: SimpleEnum CXDiagnosticSeverity -- | Source location (where Clang would print the caret @^@) - , diagnosticLocation :: SourceLoc + , diagnosticLocation :: MultiLoc -- | Text of the diagnostic , diagnosticSpelling :: Text @@ -49,7 +49,7 @@ data Diagnostic = Diagnostic { -- A diagnostic's source ranges highlight important elements in the source -- code. On the command line, Clang displays source ranges by underlining -- them with @~@ characters. - , diagnosticRanges :: [SourceRange] + , diagnosticRanges :: [Range MultiLoc] -- | Fix-it hints , diagnosticFixIts :: [FixIt] @@ -76,7 +76,7 @@ data FixIt = FixIt { -- replaced with the returned replacement string. Note that source ranges -- are half-open ranges [a, b), so the source code should be replaced from -- a and up to (but not including) b. - fixItRange :: SourceRange + fixItRange :: Range MultiLoc -- | Text that should replace the source code , fixItReplacement :: Text diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc.hs index ee97f44..77ae847 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc.hs @@ -1,178 +1,183 @@ -- | Utilities for working with source locations -- --- The functions in this module intentionally have the same names as the --- corresponding functions in "HsBindgen.Clang.Core", and therefore the same --- names as in @libclang@ itself. --- -- Intended for qualified import. -- --- > import HsBindgen.Clang.Util.SourceLoc (SourceLoc(..), SourceRange(..)) +-- > import HsBindgen.Clang.Util.SourceLoc.Type -- > import HsBindgen.Clang.Util.SourceLoc qualified as SourceLoc module HsBindgen.Clang.Util.SourceLoc ( - SourcePath(..) - , SourceLoc(..) - , SourceRange(..) - -- * Construction - , clang_Cursor_getSpellingNameRange - , clang_getCursorExtent - , clang_getCursorLocation - , clang_getDiagnosticFixIt + -- * Conversion + toMulti + , toRange + , fromSingle + , fromRange + -- * Get single location + , clang_getExpansionLocation + , clang_getPresumedLocation + , clang_getSpellingLocation + , clang_getFileLocation + -- * Convenience wrappers + -- * for @CXSourceLocation@ , clang_getDiagnosticLocation + , clang_getCursorLocation + , clang_getTokenLocation + -- ** for @CXSourceRange@ , clang_getDiagnosticRange + , clang_getDiagnosticFixIt + , clang_Cursor_getSpellingNameRange + , clang_getCursorExtent , clang_getTokenExtent - , clang_getTokenLocation - -- * Low-level - , toSourcePath - , toSourceLoc - , toSourceRange ) where -import Data.List (intercalate) +import Control.Monad import Data.Text (Text) -import Data.Text qualified as Text import Foreign.C -import GHC.Generics (Generic) -import Text.Show.Pretty (PrettyVal(..)) import HsBindgen.Clang.Core qualified as Core -import HsBindgen.Clang.Core hiding ( - clang_Cursor_getSpellingNameRange - , clang_getCursorExtent - , clang_getCursorLocation - , clang_getDiagnosticFixIt - , clang_getDiagnosticLocation - , clang_getDiagnosticRange - , clang_getTokenExtent - , clang_getTokenLocation - ) +import HsBindgen.Clang.Util.SourceLoc.Type {------------------------------------------------------------------------------- - Definition + Conversion -------------------------------------------------------------------------------} --- | Paths as reported by @libclang@ --- --- Clang uses UTF-8 internally for everything, including paths, which is why --- this is 'Text', not 'OsPath'. There might still be differences between --- platforms of course (such as directory separators). -newtype SourcePath = SourcePath { - getSourcePath :: Text - } - deriving newtype (Eq, Ord) - -data SourceLoc = SourceLoc { - sourceLocFile :: !SourcePath - , sourceLocLine :: !Int - , sourceLocColumn :: !Int - } - deriving stock (Eq, Ord, Generic) - -data SourceRange = SourceRange { - sourceRangeStart :: !SourceLoc - , sourceRangeEnd :: !SourceLoc - } - deriving stock (Eq, Ord, Generic) +toMulti :: Core.CXSourceLocation -> IO MultiLoc +toMulti location = do + expansion <- clang_getExpansionLocation location + + let unlessIsExpanion :: SingleLoc -> Maybe SingleLoc + unlessIsExpanion loc = do + guard $ loc /= expansion + return loc + + MultiLoc expansion + <$> (unlessIsExpanion <$> clang_getPresumedLocation location) + <*> (unlessIsExpanion <$> clang_getSpellingLocation location) + <*> (unlessIsExpanion <$> clang_getFileLocation location) + +toRange :: Core.CXSourceRange -> IO (Range MultiLoc) +toRange = toRangeWith toMulti + +fromSingle :: Core.CXTranslationUnit -> SingleLoc -> IO Core.CXSourceLocation +fromSingle unit SingleLoc{singleLocPath, singleLocLine, singleLocColumn} = do + file <- Core.clang_getFile unit (getSourcePath singleLocPath) + Core.clang_getLocation + unit + file + (fromIntegral singleLocLine) + (fromIntegral singleLocColumn) + +fromRange :: Core.CXTranslationUnit -> Range SingleLoc -> IO Core.CXSourceRange +fromRange unit Range{rangeStart, rangeEnd} = do + rangeStart' <- fromSingle unit rangeStart + rangeEnd' <- fromSingle unit rangeEnd + Core.clang_getRange rangeStart' rangeEnd' {------------------------------------------------------------------------------- - Show instances - - These are defined so that we could, if we wanted to, also provide an inverse - 'IsString' instance; this is the reason for the @show . pretty...@ + Get single location -------------------------------------------------------------------------------} -instance Show SourcePath where - show = show . getSourcePath - -instance Show SourceLoc where - show = show . prettySourceLoc True - -instance Show SourceRange where - show = show . prettySourceRange +clang_getExpansionLocation :: Core.CXSourceLocation -> IO SingleLoc +clang_getExpansionLocation location = + toSingle' =<< Core.clang_getExpansionLocation location -instance PrettyVal SourcePath where - prettyVal = prettyVal . show +clang_getPresumedLocation :: Core.CXSourceLocation -> IO SingleLoc +clang_getPresumedLocation location = + toSingle <$> Core.clang_getPresumedLocation location -instance PrettyVal SourceLoc where - prettyVal = prettyVal . show +clang_getSpellingLocation :: Core.CXSourceLocation -> IO SingleLoc +clang_getSpellingLocation location = + toSingle' =<< Core.clang_getSpellingLocation location -instance PrettyVal SourceRange where - prettyVal = prettyVal . show - -prettySourceLoc :: - Bool -- ^ Should we show the file? - -> SourceLoc -> String -prettySourceLoc showFile (SourceLoc file line col) = - intercalate ":" . concat $ [ - [ Text.unpack (getSourcePath file) | showFile ] - , [ show line, show col ] - ] - -prettySourceRange :: SourceRange -> String -prettySourceRange (SourceRange start end) = concat [ - prettySourceLoc True start - , "-" - , prettySourceLoc (sourceLocFile start /= sourceLocFile end) end - ] +clang_getFileLocation :: Core.CXSourceLocation -> IO SingleLoc +clang_getFileLocation location = + toSingle' =<< Core.clang_getFileLocation location {------------------------------------------------------------------------------- - Construction + Convenience wrappers for @CXSourceLocation@ -------------------------------------------------------------------------------} -clang_Cursor_getSpellingNameRange :: CXCursor -> IO SourceRange -clang_Cursor_getSpellingNameRange cursor = - toSourceRange =<< Core.clang_Cursor_getSpellingNameRange cursor 0 0 +-- | Retrieve the source location of the given diagnostic. +clang_getDiagnosticLocation :: Core.CXDiagnostic -> IO MultiLoc +clang_getDiagnosticLocation diagnostic = + toMulti =<< Core.clang_getDiagnosticLocation diagnostic -clang_getCursorLocation :: CXCursor -> IO SourceLoc +-- | Retrieve the physical location of the source constructor referenced by the +-- given cursor. +clang_getCursorLocation :: Core.CXCursor -> IO MultiLoc clang_getCursorLocation cursor = - toSourceLoc =<< Core.clang_getCursorLocation cursor + toMulti =<< Core.clang_getCursorLocation cursor -clang_getCursorExtent :: CXCursor -> IO SourceRange -clang_getCursorExtent cursor = - toSourceRange =<< Core.clang_getCursorExtent cursor +-- | Retrieve the source location of the given token. +clang_getTokenLocation :: Core.CXTranslationUnit -> Core.CXToken -> IO MultiLoc +clang_getTokenLocation unit token = + toMulti =<< Core.clang_getTokenLocation unit token -clang_getDiagnosticLocation :: CXDiagnostic -> IO SourceLoc -clang_getDiagnosticLocation diag = - toSourceLoc =<< Core.clang_getDiagnosticLocation diag +{------------------------------------------------------------------------------- + Convenience wrappers for @CXSourceRange@ +-------------------------------------------------------------------------------} -clang_getDiagnosticRange :: CXDiagnostic -> CUInt -> IO SourceRange -clang_getDiagnosticRange diag i = - toSourceRange =<< Core.clang_getDiagnosticRange diag i +-- | Retrieve a source range associated with the diagnostic. +clang_getDiagnosticRange :: Core.CXDiagnostic -> CUInt -> IO (Range MultiLoc) +clang_getDiagnosticRange diagnostic range = + toRange =<< Core.clang_getDiagnosticRange diagnostic range +-- | Retrieve the replacement information for a given fix-it. clang_getDiagnosticFixIt :: - CXDiagnostic + Core.CXDiagnostic -> CUInt - -> IO (SourceRange, Text) -clang_getDiagnosticFixIt diag i = do - (range, bs) <- Core.clang_getDiagnosticFixIt diag i - (,bs) <$> toSourceRange range + -> IO (Range MultiLoc, Text) +clang_getDiagnosticFixIt diagnostic fixit = do + (range, replacement) <- Core.clang_getDiagnosticFixIt diagnostic fixit + (, replacement) <$> toRange range -clang_getTokenLocation :: CXTranslationUnit -> CXToken -> IO SourceLoc -clang_getTokenLocation unit token = - toSourceLoc =<< Core.clang_getTokenLocation unit token +-- | Retrieve a range for a piece that forms the cursors spelling name. +-- +-- TODO: This currently returns 'Range' 'SingleLoc' as I am assuming that the +-- relevant part of the returned range is the /spelling/ location. That +-- assumption may be false. +clang_Cursor_getSpellingNameRange :: + Core.CXCursor + -> CUInt + -> CUInt + -> IO (Range SingleLoc) +clang_Cursor_getSpellingNameRange cursor pieceIndex options = do + range <- Core.clang_Cursor_getSpellingNameRange cursor pieceIndex options + toRangeWith clang_getSpellingLocation range + +-- | Retrieve the physical extent of the source construct referenced by the +-- given cursor. +clang_getCursorExtent :: Core.CXCursor -> IO (Range MultiLoc) +clang_getCursorExtent cursor = + toRange =<< Core.clang_getCursorExtent cursor -clang_getTokenExtent :: CXTranslationUnit -> CXToken -> IO SourceRange +-- | Retrieve a source range that covers the given token. +clang_getTokenExtent :: + Core.CXTranslationUnit + -> Core.CXToken + -> IO (Range MultiLoc) clang_getTokenExtent unit token = - toSourceRange =<< Core.clang_getTokenExtent unit token + toRange =<< Core.clang_getTokenExtent unit token {------------------------------------------------------------------------------- - Internal auxiliary + Auxiliary -------------------------------------------------------------------------------} -toSourcePath :: Text -> SourcePath -toSourcePath = SourcePath - -toSourceRange :: CXSourceRange -> IO SourceRange -toSourceRange rng = do - begin <- clang_getRangeStart rng - end <- clang_getRangeEnd rng - SourceRange - <$> toSourceLoc begin - <*> toSourceLoc end - -toSourceLoc :: CXSourceLocation -> IO SourceLoc -toSourceLoc loc = do - (file, line, col, _bufOffset) <- clang_getSpellingLocation loc - SourceLoc - <$> (toSourcePath <$> clang_getFileName file) - <*> (pure $ fromIntegral line) - <*> (pure $ fromIntegral col) +toSingle :: (Text, CUInt, CUInt) -> SingleLoc +toSingle (singleLocPath, singleLocLine, singleLocColumn) = SingleLoc{ + singleLocPath = SourcePath singleLocPath + , singleLocLine = fromIntegral singleLocLine + , singleLocColumn = fromIntegral singleLocColumn + } + +toSingle' :: (Core.CXFile, CUInt, CUInt, CUInt) -> IO SingleLoc +toSingle' (file, singleLocLine, singleLocColumn, _offset) = do + singleLocPath <- Core.clang_getFileName file + return $ toSingle (singleLocPath, singleLocLine, singleLocColumn) + +toRangeWith :: + (Core.CXSourceLocation -> IO a) + -> Core.CXSourceRange -> IO (Range a) +toRangeWith f range = + Range + <$> (f =<< Core.clang_getRangeStart range) + <*> (f =<< Core.clang_getRangeEnd range) + diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc/Type.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc/Type.hs new file mode 100644 index 0000000..9c33b88 --- /dev/null +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/SourceLoc/Type.hs @@ -0,0 +1,208 @@ +-- | Definition of the source location types +-- +-- Intended for unqualified import (unlike "HsBindgen.Clang.Util.SourceLoc"). +-- We introduce this split so that these type can be exported (unqualified) +-- from "HsBindgen.C.AST". +module HsBindgen.Clang.Util.SourceLoc.Type ( + -- * Definition + SourcePath(..) + , SingleLoc(..) + , MultiLoc(..) + , Range(..) + ) where + +import Data.List (intercalate) +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics (Generic) +import Text.Show.Pretty (PrettyVal(..)) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Paths as reported by @libclang@ +-- +-- Clang uses UTF-8 internally for everything, including paths, which is why +-- this is 'Text', not @OsPath@. There might still be differences between +-- platforms of course (such as directory separators). +newtype SourcePath = SourcePath { + getSourcePath :: Text + } + deriving newtype (Eq, Ord) + +-- | A /single/ location in a file +-- +-- See 'MultiLoc' for additional discussion. +data SingleLoc = SingleLoc { + singleLocPath :: !SourcePath + , singleLocLine :: !Int + , singleLocColumn :: !Int + } + deriving stock (Eq, Ord, Generic) + +-- | Multiple related source locations +-- +-- 'Core.CXSourceLocation' in @libclang@ corresponds to @SourceLocation@ in +-- @clang@, which can actually correspond to /multiple/ source locations in a +-- file; for example, in a header file such as +-- +-- > #define M1 int +-- > +-- > struct ExampleStruct { +-- > M1 m1; +-- > ^ +-- > }; +-- +-- then the source location at the caret (@^@) has an \"expansion location\", +-- which is the position at the caret, and a \"spelling location\", which +-- corresponds to the location of the @int@ token in the macro definition. +-- +-- References: +-- +-- * +-- * +-- (@getExpansionLoc@, @getSpellingLoc@, @getDecomposedSpellingLoc@) +data MultiLoc = MultiLoc { + -- | Expansion location + -- + -- If the location refers into a macro expansion, this corresponds to the + -- location of the macro expansion. + -- + -- See + multiLocExpansion :: !SingleLoc + + -- | Presumed location + -- + -- The given source location as specified in a @#line@ directive. + -- + -- See + , multiLocPresumed :: !(Maybe SingleLoc) + + -- | Spelling location + -- + -- If the location refers into a macro instantiation, this corresponds to + -- the /original/ location of the spelling in the source file. + -- + -- /WARNING/: This field is only populated correctly from @llvm >= 191.0@; + -- prior to that this is equal to 'multiLocFile'. + -- See . + -- + -- See + , multiLocSpelling :: !(Maybe SingleLoc) + + -- | File location + -- + -- If the location refers into a macro expansion, this corresponds to the + -- location of the macro expansion. + -- If the location points at a macro argument, this corresponds to the + -- location of the use of the argument. + -- + -- See + , multiLocFile :: !(Maybe SingleLoc) + } + deriving stock (Eq, Ord, Generic) + +-- | Range +-- +-- 'Core.CXSourceRange' corresponds to @SourceRange@ in @clang@ +-- , +-- and therefore to @Range MultiLoc@; see 'MultiLoc' for additional discussion. +data Range a = Range { + rangeStart :: !a + , rangeEnd :: !a + } + deriving stock (Eq, Ord, Generic) + deriving stock (Functor, Foldable, Traversable) + +{------------------------------------------------------------------------------- + Show instances + + Technically speaking the validity of these instances depends on 'IsString' + instances which we do not (yet?) define. +-------------------------------------------------------------------------------} + +instance Show SourcePath where show = show . getSourcePath +instance Show SingleLoc where show = show . prettySingleLoc True +instance Show MultiLoc where show = show . prettyMultiLoc True +instance Show (Range SingleLoc) where show = show . prettyRangeSingleLoc +instance Show (Range MultiLoc) where show = show . prettyRangeMultiLoc + +deriving stock instance {-# OVERLAPPABLE #-} Show a => Show (Range a) + +{------------------------------------------------------------------------------- + Pretty-printing + + These instances mimick the behaviour of @SourceLocation::print@ and + @SourceRange::print@ in @clang@. +-------------------------------------------------------------------------------} + +type ShowFile = Bool + +prettySingleLoc :: ShowFile -> SingleLoc -> String +prettySingleLoc showFile loc = + intercalate ":" . concat $ [ + [ Text.unpack (getSourcePath singleLocPath) | showFile ] + , [ show singleLocLine + , show singleLocColumn + ] + ] + where + SingleLoc{singleLocPath, singleLocLine, singleLocColumn} = loc + +prettyMultiLoc :: ShowFile -> MultiLoc -> String +prettyMultiLoc showFile multiLoc = + intercalate " " . concat $ [ + [ prettySingleLoc showFile multiLocExpansion ] + , [ "" | Just loc <- [multiLocPresumed] ] + , [ "" | Just loc <- [multiLocSpelling] ] + , [ "" | Just loc <- [multiLocFile] ] + ] + where + MultiLoc{ + multiLocExpansion + , multiLocPresumed + , multiLocSpelling + , multiLocFile} = multiLoc + + aux :: SingleLoc -> [Char] + aux loc = + prettySingleLoc + (singleLocPath loc /= singleLocPath multiLocExpansion) + loc + +prettyRangeSingleLoc :: Range SingleLoc -> String +prettyRangeSingleLoc = prettySourceRangeWith + singleLocPath + prettySingleLoc + +prettyRangeMultiLoc :: Range MultiLoc -> String +prettyRangeMultiLoc = + prettySourceRangeWith + (singleLocPath . multiLocExpansion) + prettyMultiLoc + +prettySourceRangeWith :: + (a -> SourcePath) + -> (ShowFile -> a -> String) + -> Range a -> String +prettySourceRangeWith path pretty Range{rangeStart, rangeEnd} = concat [ + "<" + , pretty True rangeStart + , "-" + , pretty (path rangeStart /= path rangeEnd) rangeEnd + , ">" + ] + +{------------------------------------------------------------------------------- + PrettyVal instances + + These just piggy-back on the 'Show' instances. +-------------------------------------------------------------------------------} + +instance PrettyVal SourcePath where prettyVal = prettyVal . show +instance PrettyVal SingleLoc where prettyVal = prettyVal . show +instance PrettyVal MultiLoc where prettyVal = prettyVal . show + +instance Show a => PrettyVal (Range a) where + prettyVal = prettyVal. show diff --git a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Tokens.hs b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Tokens.hs index d9119b3..ec106a2 100644 --- a/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Tokens.hs +++ b/hs-bindgen-libclang/src/HsBindgen/Clang/Util/Tokens.hs @@ -10,7 +10,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Text.Show.Pretty (PrettyVal(..)) -import HsBindgen.Clang.Util.SourceLoc (SourceRange) +import HsBindgen.Clang.Util.SourceLoc.Type import HsBindgen.Clang.Util.SourceLoc qualified as SourceLoc import HsBindgen.Patterns @@ -20,13 +20,13 @@ import HsBindgen.Clang.Core hiding ( ) {------------------------------------------------------------------------------- - Token extraction and manipulation + Definition -------------------------------------------------------------------------------} data Token a = Token { tokenKind :: !(SimpleEnum CXTokenKind) , tokenSpelling :: !a - , tokenExtent :: !SourceRange + , tokenExtent :: !(Range MultiLoc) , tokenCursorKind :: !(SimpleEnum CXCursorKind) } deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic) @@ -40,11 +40,24 @@ newtype TokenSpelling = TokenSpelling { instance PrettyVal TokenSpelling where prettyVal = prettyVal . show +{------------------------------------------------------------------------------- + Extraction +-------------------------------------------------------------------------------} + -- | Get all tokens in the specified range -clang_tokenize :: CXTranslationUnit -> CXSourceRange -> IO [Token TokenSpelling] +clang_tokenize :: + CXTranslationUnit + -> Range SingleLoc + -- ^ Range + -- + -- We use 'Range' 'SingleLoc' here instead of 'CXSourceRange' in order to + -- avoid ambiguity; see 'HsBindgen.Clang.Util.SourceLoc.Multi' for + -- discussion. + -> IO [Token TokenSpelling] clang_tokenize unit range = do + range' <- SourceLoc.fromRange unit range bracket - (Core.clang_tokenize unit range) + (Core.clang_tokenize unit range') (uncurry $ Core.clang_disposeTokens unit) $ \(tokens, numTokens) -> do cursors <- clang_annotateTokens unit tokens numTokens forM [0 .. pred numTokens] $ \i -> do diff --git a/hs-bindgen/app/HsBindgen/App/RenderComments.hs b/hs-bindgen/app/HsBindgen/App/RenderComments.hs index 6b4f70d..5cfbc92 100644 --- a/hs-bindgen/app/HsBindgen/App/RenderComments.hs +++ b/hs-bindgen/app/HsBindgen/App/RenderComments.hs @@ -17,16 +17,16 @@ import HsBindgen.C.AST -------------------------------------------------------------------------------} -- | Generate HTML page with comments -renderComments :: Forest (SourceLoc, Text, Maybe Text) -> Html +renderComments :: Forest (MultiLoc, Text, Maybe Text) -> Html renderComments comments = H.docTypeHtml $ H.body $ do mapM_ renderNode comments -renderNode :: Tree (SourceLoc, Text, Maybe Text) -> Html +renderNode :: Tree (MultiLoc, Text, Maybe Text) -> Html renderNode (Node (sourceLoc, name, mComment) children) = do H.b $ Blaze.text name " (" - toMarkup sourceLoc + toMarkup (multiLocExpansion sourceLoc) ")" mapM_ Blaze.text mComment H.div ! A.style "margin-left: 1em;" $ do @@ -35,10 +35,10 @@ renderNode (Node (sourceLoc, name, mComment) children) = do instance ToMarkup SourcePath where toMarkup = Blaze.text . getSourcePath -instance ToMarkup SourceLoc where - toMarkup SourceLoc{sourceLocFile, sourceLocLine, sourceLocColumn} = do - toMarkup sourceLocFile +instance ToMarkup SingleLoc where + toMarkup SingleLoc{singleLocPath, singleLocLine, singleLocColumn} = do + toMarkup singleLocPath ":" - toMarkup sourceLocLine + toMarkup singleLocLine ":" - toMarkup sourceLocColumn + toMarkup singleLocColumn diff --git a/hs-bindgen/fixtures/enums.tree-diff.txt b/hs-bindgen/fixtures/enums.tree-diff.txt index bae5d54..1fbea0c 100644 --- a/hs-bindgen/fixtures/enums.tree-diff.txt +++ b/hs-bindgen/fixtures/enums.tree-diff.txt @@ -4,12 +4,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "enums.h"], - sourceLocLine = 2, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "enums.h"], + singleLocLine = 2, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "ENUMS_H", macroArgs = [], macroBody = MTerm MEmpty}), diff --git a/hs-bindgen/fixtures/macro_functions.tree-diff.txt b/hs-bindgen/fixtures/macro_functions.tree-diff.txt index 8d6486c..57b8411 100644 --- a/hs-bindgen/fixtures/macro_functions.tree-diff.txt +++ b/hs-bindgen/fixtures/macro_functions.tree-diff.txt @@ -4,12 +4,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macro_functions.h"], - sourceLocLine = 1, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macro_functions.h"], + singleLocLine = 1, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "INCR", macroArgs = [CName "x"], macroBody = MAdd @@ -22,12 +26,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macro_functions.h"], - sourceLocLine = 2, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macro_functions.h"], + singleLocLine = 2, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "ADD", macroArgs = [ CName "x", diff --git a/hs-bindgen/fixtures/macros.tree-diff.txt b/hs-bindgen/fixtures/macros.tree-diff.txt index aeeb8b8..19054d8 100644 --- a/hs-bindgen/fixtures/macros.tree-diff.txt +++ b/hs-bindgen/fixtures/macros.tree-diff.txt @@ -4,12 +4,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 1, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 1, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "OBJECTLIKE1", macroArgs = [], macroBody = MTerm @@ -20,12 +24,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 2, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 2, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "OBJECTLIKE2", macroArgs = [], macroBody = MTerm @@ -36,12 +44,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 3, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 3, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "OBJECTLIKE3", macroArgs = [], macroBody = MAdd @@ -58,12 +70,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 4, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 4, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "OBJECTLIKE4", macroArgs = [], macroBody = MAdd @@ -80,12 +96,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 6, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 6, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "MEANING_OF_LIFE1", macroArgs = [], @@ -97,12 +117,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 7, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 7, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "MEANING_OF_LIFE2", macroArgs = [], @@ -114,12 +138,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 8, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 8, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "MEANING_OF_LIFE3", macroArgs = [], @@ -131,12 +159,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 9, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 9, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "MEANING_OF_LIFE4", macroArgs = [], @@ -148,12 +180,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 10, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 10, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "MEANING_OF_LIFE5", macroArgs = [], @@ -165,12 +201,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 12, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 12, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "LONG_INT_TOKEN1", macroArgs = [], @@ -184,12 +224,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 13, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 13, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "LONG_INT_TOKEN2", macroArgs = [], @@ -203,12 +247,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 14, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 14, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "LONG_INT_TOKEN3", macroArgs = [], @@ -222,12 +270,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "macros.h"], - sourceLocLine = 15, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "macros.h"], + singleLocLine = 15, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "LONG_INT_TOKEN4", macroArgs = [], diff --git a/hs-bindgen/fixtures/uses_utf8.tree-diff.txt b/hs-bindgen/fixtures/uses_utf8.tree-diff.txt index fccde76..55afa3e 100644 --- a/hs-bindgen/fixtures/uses_utf8.tree-diff.txt +++ b/hs-bindgen/fixtures/uses_utf8.tree-diff.txt @@ -4,12 +4,16 @@ WrapCHeader DeclMacro (Right Macro { - macroLoc = SourceLoc { - sourceLocFile = [ - "examples", - "uses_utf8.h"], - sourceLocLine = 2, - sourceLocColumn = 9}, + macroLoc = MultiLoc { + multiLocExpansion = SingleLoc { + singleLocPath = [ + "examples", + "uses_utf8.h"], + singleLocLine = 2, + singleLocColumn = 9}, + multiLocPresumed = Nothing, + multiLocSpelling = Nothing, + multiLocFile = Nothing}, macroName = CName "USES_UTF8_H", macroArgs = [], macroBody = MTerm MEmpty}), diff --git a/hs-bindgen/src/HsBindgen/Bootstrap/Prelude.hs b/hs-bindgen/src/HsBindgen/Bootstrap/Prelude.hs index 3415f55..6303e26 100644 --- a/hs-bindgen/src/HsBindgen/Bootstrap/Prelude.hs +++ b/hs-bindgen/src/HsBindgen/Bootstrap/Prelude.hs @@ -13,7 +13,7 @@ import HsBindgen.C.Parser.Macro qualified as Macro import HsBindgen.Clang.Args import HsBindgen.Clang.Core import HsBindgen.Clang.Util.Fold -import HsBindgen.Clang.Util.SourceLoc (SourceLoc(..)) +import HsBindgen.Clang.Util.SourceLoc.Type import HsBindgen.Clang.Util.SourceLoc qualified as SourceLoc import HsBindgen.Clang.Util.Tokens qualified as Tokens import HsBindgen.Patterns @@ -68,8 +68,10 @@ fold tracer standardHeaders unit = go Right CXCursor_MacroExpansion -> skip Right CXCursor_MacroDefinition -> do - cursorExtent <- clang_getCursorExtent current - tokens <- Tokens.clang_tokenize unit cursorExtent + cursorExtent <- SourceLoc.clang_getCursorExtent current + tokens <- Tokens.clang_tokenize + unit + (multiLocExpansion <$> cursorExtent) case Macro.parse tokens of Right macro -> appendFile "macros-recognized.log" (show (loc, macro) ++ "\n") @@ -80,11 +82,12 @@ fold tracer standardHeaders unit = go _otherwise -> Continue <$> unrecognized tracer current - checkLoc :: (SourceLoc -> Fold a) -> Fold a + checkLoc :: (MultiLoc -> Fold a) -> Fold a checkLoc k parent current = do loc <- SourceLoc.clang_getCursorLocation current let fp :: FilePath - fp = Text.unpack (SourceLoc.getSourcePath $ sourceLocFile loc) + fp = Text.unpack . getSourcePath . singleLocPath $ + multiLocExpansion loc if | fp == "" -> -- TODO: Should we do anything with the macro definitions from @@ -104,8 +107,8 @@ fold tracer standardHeaders unit = go -------------------------------------------------------------------------------} data GenPreludeMsg = - Skipping SourceLoc (SimpleEnum CXCursorKind) - | UnrecognizedElement SourceLoc (SimpleEnum CXCursorKind) Text + Skipping MultiLoc (SimpleEnum CXCursorKind) + | UnrecognizedElement MultiLoc (SimpleEnum CXCursorKind) Text | UnrecognizedMacro UnrecognizedMacro deriving stock (Show) deriving anyclass (Exception) diff --git a/hs-bindgen/src/HsBindgen/C/AST.hs b/hs-bindgen/src/HsBindgen/C/AST.hs index 1619af0..1094a8c 100644 --- a/hs-bindgen/src/HsBindgen/C/AST.hs +++ b/hs-bindgen/src/HsBindgen/C/AST.hs @@ -41,8 +41,9 @@ module HsBindgen.C.AST ( , TokenSpelling(..) -- * Source locations , SourcePath(..) - , SourceLoc(..) - , SourceRange(..) + , SingleLoc(..) + , MultiLoc(..) + , Range(..) ) where import GHC.Generics (Generic) @@ -53,8 +54,8 @@ import HsBindgen.C.AST.Macro import HsBindgen.C.AST.Name import HsBindgen.C.AST.Type import HsBindgen.C.Parser.Macro (UnrecognizedMacro(..)) -import HsBindgen.Clang.Util.SourceLoc import HsBindgen.Clang.Util.Tokens +import HsBindgen.Clang.Util.SourceLoc.Type {------------------------------------------------------------------------------- Top-level diff --git a/hs-bindgen/src/HsBindgen/C/AST/Macro.hs b/hs-bindgen/src/HsBindgen/C/AST/Macro.hs index 1f171dd..0e32b83 100644 --- a/hs-bindgen/src/HsBindgen/C/AST/Macro.hs +++ b/hs-bindgen/src/HsBindgen/C/AST/Macro.hs @@ -17,21 +17,21 @@ import Data.Char (toUpper) import Data.String import Data.Text qualified as Text import GHC.Generics (Generic) -import HsBindgen.Clang.Util.SourceLoc -import HsBindgen.Clang.Util.Tokens import System.FilePath (takeBaseName) import Text.Show.Pretty (PrettyVal) import HsBindgen.C.AST.Literal import HsBindgen.C.AST.Name import HsBindgen.C.AST.Type +import HsBindgen.Clang.Util.SourceLoc.Type +import HsBindgen.Clang.Util.Tokens {------------------------------------------------------------------------------- Top-level -------------------------------------------------------------------------------} data Macro = Macro { - macroLoc :: SourceLoc + macroLoc :: MultiLoc , macroName :: CName , macroArgs :: [CName] , macroBody :: MExpr @@ -142,7 +142,8 @@ isIncludeGuard Macro{macroLoc, macroName, macroArgs, macroBody} = ] where sourcePath :: FilePath - sourcePath = Text.unpack . getSourcePath $ sourceLocFile macroLoc + sourcePath = Text.unpack . getSourcePath . singleLocPath $ + multiLocExpansion macroLoc includeGuards :: [CName] includeGuards = possibleIncludeGuards (takeBaseName sourcePath) diff --git a/hs-bindgen/src/HsBindgen/C/Parser.hs b/hs-bindgen/src/HsBindgen/C/Parser.hs index 6a6b3f9..7ccccc8 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser.hs +++ b/hs-bindgen/src/HsBindgen/C/Parser.hs @@ -142,8 +142,8 @@ foldDecls tracer p unit = checkPredicate tracer p $ \_parent current -> do mkDecl types = error $ "mkTypedef: unexpected " ++ show types return $ Recurse (foldTyp tracer unit) mkDecl Right CXCursor_MacroDefinition -> do - range <- clang_getCursorExtent current - tokens <- Tokens.clang_tokenize unit range + range <- SourceLoc.clang_getCursorExtent current + tokens <- Tokens.clang_tokenize unit (multiLocExpansion <$> range) let decl :: Decl decl = DeclMacro $ Macro.parse tokens return $ Continue $ Just decl @@ -167,15 +167,11 @@ checkPredicate tracer p k parent current = do -------------------------------------------------------------------------------} -- | Parse struct --- --- Implementation note: It seems libclang will give us a name for the struct if --- the struct it a tag, but also when it's anonymous but the surrounding typedef --- has a name. parseStruct :: CXTranslationUnit -> CXCursor -> IO ([StructField] -> Struct) -parseStruct unit current = do +parseStruct _unit current = do cursorType <- clang_getCursorType current structTag <- fmap CName . getUserProvided <$> - getUserProvidedName unit current + getUserProvidedName current structSizeof <- fromIntegral <$> clang_Type_getSizeOf cursorType structAlignment <- fromIntegral <$> clang_Type_getAlignOf cursorType @@ -201,10 +197,10 @@ foldStructFields tracer _parent current = do -------------------------------------------------------------------------------} parseEnum :: CXTranslationUnit -> CXCursor -> IO ([EnumValue] -> Enu) -parseEnum unit current = do +parseEnum _unit current = do cursorType <- clang_getCursorType current enumTag <- fmap CName . getUserProvided <$> - getUserProvidedName unit current + getUserProvidedName current enumSizeof <- fromIntegral <$> clang_Type_getSizeOf cursorType enumAlignment <- fromIntegral <$> clang_Type_getAlignOf cursorType @@ -235,10 +231,6 @@ foldEnumValues tracer _parent current = do -------------------------------------------------------------------------------} -- | Parse type --- --- If we encounter an unrecognized type, we return 'Nothing' and issue a --- warning. The warning is ussed here, rather than at the call site, because --- 'parseType' is recursive. parseType :: Tracer IO ParseMsg -> CXType -> IO Typ parseType _tracer = go where @@ -309,6 +301,7 @@ primType (Right kind) = -- | An element in the @libclang@ AST data Element = Element { elementName :: !(UserProvided Text) + , elementLocation :: !(Range MultiLoc) , elementKind :: !Text , elementTypeKind :: !Text , elementRawComment :: !Text @@ -333,22 +326,24 @@ data Element = Element { -- -- to see the AST under the @struct@ parent node. foldClangAST :: Predicate -> CXTranslationUnit -> Fold (Tree Element) -foldClangAST p unit = checkPredicate nullTracer p go +foldClangAST p _unit = checkPredicate nullTracer p go where go :: Fold (Tree Element) go _parent current = do - elementName <- getUserProvidedName unit current + elementName <- getUserProvidedName current + elementLocation <- SourceLoc.clang_getCursorExtent current elementKind <- clang_getCursorKindSpelling =<< - clang_getCursorKind current + clang_getCursorKind current elementTypeKind <- clang_getTypeKindSpelling . cxtKind =<< - clang_getCursorType current - elementRawComment <- clang_Cursor_getRawCommentText current - elementIsAnonymous <- clang_Cursor_isAnonymous current - elementIsDefinition <- clang_isCursorDefinition current + clang_getCursorType current + elementRawComment <- clang_Cursor_getRawCommentText current + elementIsAnonymous <- clang_Cursor_isAnonymous current + elementIsDefinition <- clang_isCursorDefinition current let element :: Element element = Element { elementName + , elementLocation , elementKind , elementTypeKind , elementRawComment @@ -364,10 +359,10 @@ foldClangAST p unit = checkPredicate nullTracer p go foldComments :: Predicate -> CXTranslationUnit - -> Fold (Tree (SourceLoc, Text, Maybe Text)) + -> Fold (Tree (MultiLoc, Text, Maybe Text)) foldComments p _unit = checkPredicate nullTracer p go where - go :: Fold (Tree (SourceLoc, Text, Maybe Text)) + go :: Fold (Tree (MultiLoc, Text, Maybe Text)) go _parent current = do sourceLoc <- SourceLoc.clang_getCursorLocation current name <- clang_getCursorSpelling current @@ -390,7 +385,7 @@ data ParseMsg = -- -- We record the name and location of the element, as well as the reason we -- skipped it. - Skipped Text SourceLoc String + Skipped Text MultiLoc String -- | Skipped unrecognized cursor | UnrecognizedCursor CallStack (SimpleEnum CXCursorKind) diff --git a/hs-bindgen/src/HsBindgen/C/Parser/Macro.hs b/hs-bindgen/src/HsBindgen/C/Parser/Macro.hs index dba0c31..863fbe2 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser/Macro.hs +++ b/hs-bindgen/src/HsBindgen/C/Parser/Macro.hs @@ -27,7 +27,7 @@ import HsBindgen.C.AST.Macro import HsBindgen.C.AST.Name import HsBindgen.C.AST.Type import HsBindgen.Clang.Core -import HsBindgen.Clang.Util.SourceLoc +import HsBindgen.Clang.Util.SourceLoc.Type import HsBindgen.Clang.Util.Tokens import HsBindgen.Patterns import HsBindgen.Util.Tracer @@ -65,8 +65,10 @@ parse tokens = sourcePath = case tokens of [] -> error "parse: impossible" -- must have the macro name - t:_ -> Text.unpack . getSourcePath . sourceLocFile $ - sourceRangeStart (tokenExtent t) + t:_ -> Text.unpack . getSourcePath $ singleLocPath start + where + start :: SingleLoc + start = rangeStart $ multiLocExpansion <$> tokenExtent t unrecognized :: ParseError -> UnrecognizedMacro unrecognized err = UnrecognizedMacro{ @@ -99,18 +101,18 @@ parseMacro = do , objectLike macroLoc macroName ] where - functionLike, objectLike :: SourceLoc -> CName -> Parser Macro + functionLike, objectLike :: MultiLoc -> CName -> Parser Macro functionLike loc name = Macro loc name <$> parseFormalArgs <*> parseMExpr objectLike loc name = Macro loc name [] <$> parseMExpr -parseMacroName :: Parser (SourceLoc, CName) +parseMacroName :: Parser (MultiLoc, CName) parseMacroName = parseName -parseName :: Parser (SourceLoc, CName) +parseName :: Parser (MultiLoc, CName) parseName = token $ \t -> do guard $ fromSimpleEnum (tokenKind t) == Right CXToken_Identifier return ( - sourceRangeStart (tokenExtent t) + rangeStart $ tokenExtent t , CName $ getTokenSpelling (tokenSpelling t) ) @@ -400,13 +402,9 @@ tokenPretty Token{tokenKind, tokenSpelling} = concat [ tokenSourcePos :: Token a -> Parsec.SourcePos tokenSourcePos t = Parsec.newPos - (Text.unpack $ getSourcePath sourceLocFile) - sourceLocLine - sourceLocColumn + (Text.unpack . getSourcePath $ singleLocPath start) + (singleLocLine start) + (singleLocColumn start) where - SourceLoc{ - sourceLocFile - , sourceLocLine - , sourceLocColumn - } = sourceRangeStart (tokenExtent t) - + start :: SingleLoc + start = rangeStart $ multiLocExpansion <$> tokenExtent t diff --git a/hs-bindgen/src/HsBindgen/Lib.hs b/hs-bindgen/src/HsBindgen/Lib.hs index 31f02ea..8c63757 100644 --- a/hs-bindgen/src/HsBindgen/Lib.hs +++ b/hs-bindgen/src/HsBindgen/Lib.hs @@ -75,7 +75,7 @@ import HsBindgen.C.Parser qualified as C import HsBindgen.C.Predicate (Predicate(..)) import HsBindgen.Clang.Args import HsBindgen.Clang.Util.Diagnostics qualified as C (Diagnostic) -import HsBindgen.Clang.Util.SourceLoc +import HsBindgen.Clang.Util.SourceLoc.Type import HsBindgen.Hs.AST qualified as Hs import HsBindgen.Translation.LowLevel qualified as LowLevel import HsBindgen.Util.Tracer @@ -211,7 +211,7 @@ getComments :: -> Predicate -> ClangArgs -> FilePath - -> IO (Forest (SourceLoc, Text, Maybe Text)) + -> IO (Forest (MultiLoc, Text, Maybe Text)) getComments tracer predicate args fp = C.parseHeaderWith tracer args fp $ C.foldComments predicate diff --git a/hs-bindgen/tests/Orphans.hs b/hs-bindgen/tests/Orphans.hs index b891bdc..654384e 100644 --- a/hs-bindgen/tests/Orphans.hs +++ b/hs-bindgen/tests/Orphans.hs @@ -32,10 +32,10 @@ instance ToExpr C.Header instance ToExpr C.Macro instance ToExpr C.MExpr instance ToExpr C.MTerm +instance ToExpr C.MultiLoc instance ToExpr C.PrimSign instance ToExpr C.PrimType -instance ToExpr C.SourceLoc -instance ToExpr C.SourceRange +instance ToExpr C.SingleLoc instance ToExpr C.Struct instance ToExpr C.StructField instance ToExpr C.TokenSpelling @@ -43,8 +43,9 @@ instance ToExpr C.Typ instance ToExpr C.Typedef instance ToExpr C.UnrecognizedMacro -instance ToExpr a => ToExpr (C.Token a) instance ToExpr a => ToExpr (C.Literal a) +instance ToExpr a => ToExpr (C.Range a) +instance ToExpr a => ToExpr (C.Token a) -- Construct platform-independent expression instance ToExpr C.SourcePath where