diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,86 @@ # Revision history for libclang-bindings +## ?.?.?.? -- YYYY-mm-dd + +### Breaking changes + +### New features + +### Minor changes + +### Bug fixes + +## 0.2.0.0 -- 2026-10-06 + +### Breaking changes + +* Add `CXType_PredefinedSugar` to `CXTypeKind`. LLVM/Clang 23 reports this kind + for the predefined types `__size_t`, `__signed_size_t` and `__ptrdiff_t`; + see [predefined-sugar-unexposed (llvm/llvm-project#202209)][llvm-202209]. +* `SingleLoc`, `MultiLoc`, and `Token` are parameterized by path type + (`SingleLoc path`, `MultiLoc path`, `Token path a`). +* High-level location functions such as `clang_getCursorLocation` return + `RealPath` locations. They throw `ClangRealPathException` if the expansion + location is in a virtual file, where 0.1.0.0 returned a location, and set a + spelling or file location in a virtual file to `Nothing`. Use + `toMultiSourcePath`/`toRangeSourcePath` for virtual files. See + [location-wrappers-throw (#84)][issue-84]. +* `RealPath` locations compare canonical paths: `Eq`, `Ord`, + `compareSingleLoc` and `rangeContainsLoc` treat a file reached under two + spellings as one file. See + [binding-specs-path-spelling (well-typed/hs-bindgen#2236)][hs-bindgen-2236]. +* Diagnostics use `SourcePath` locations: `Diagnostic`, `FixIt`, + `clang_getDiagnosticLocation`, `clang_getDiagnosticRange` and + `clang_getDiagnosticFixIt` do not throw for virtual files. +* `toMulti`/`toRange` renamed to `toMultiRealPath`/`toRangeRealPath`; + new `toMultiSourcePath`/`toRangeSourcePath` for virtual files. +* `prettySingleLoc`, `prettyMultiLoc`, `prettyRangeSingleLoc` and + `prettyRangeMultiLoc` take a `path -> String` argument. `SingleLoc`, + `MultiLoc` and their ranges have `Show` instances only for `RealPath` and + `SourcePath`. +* `clang_tokenize` takes a `CXSourceRange` instead of a `Range SingleLoc`, and + returns `[Token SourcePath TokenSpelling]`. It passes the range to `libclang` + unchanged, so a range that starts inside a macro expansion is tokenized from + the macro definition; see the documentation of `clang_tokenize`. +* Remove `fromSingle` and `fromRange`. They looked up the `CXFile` by path, + which fails for locations in buffers without one. Use `clang_getLocation` + and `clang_getRange` from `Clang.LowLevel.Core` instead. +* Remove `nullSourcePath`. Use `Data.Text.null . getSourcePathText` instead. + +### New features + +* Bind `clang_File_tryGetRealPathName` and `clang_File_isEqual`. +* Add the `RealPath` newtype with `getRealPath`, `getRealPathText` and + `realPathToSourcePath`. Add `getSourcePathText`. +* Add `clang_getRealPath`, which throws `ClangRealPathException` for a virtual + file, and `clang_tryGetRealPath`, which returns `Nothing` for one. +* Add `toMultiCXFile`: builds `MultiLoc CXFile`. +* `SingleLoc` and `MultiLoc` derive `Functor`, `Foldable` and `Traversable`. +* Bind `clang_hashCursor`. See [hash-cursor (PR #81)][pr-81]. + +### Minor changes + +* `Clang.HighLevel.Types` re-exports `RealPath` and `SourcePath`. + +### Bug fixes + +* `MultiLoc` no longer drops a presumed, spelling or file location that differs + from the expansion location in only some of file, line and column. It used + to drop, for example, the spelling location of a macro defined in the same + file, and every presumed location set by a `#line` directive. See + [macro-spelling-dropped (#85)][issue-85]. +* `clang_tokenize` no longer throws for a range in a buffer without a file on + disk, such as the predefines buffer holding macros defined with `-D`. See + [header-redefines-D-macro (well-typed/hs-bindgen#2280)][hs-bindgen-2280]. +* `clang_tokenize` returns `[]` for a range without tokens instead of failing. + +[pr-81]: https://github.com/well-typed/libclang-bindings/pull/81 +[issue-84]: https://github.com/well-typed/libclang-bindings/issues/84 +[issue-85]: https://github.com/well-typed/libclang-bindings/issues/85 +[llvm-202209]: https://github.com/llvm/llvm-project/pull/202209 +[hs-bindgen-2236]: https://github.com/well-typed/hs-bindgen/issues/2236 +[hs-bindgen-2280]: https://github.com/well-typed/hs-bindgen/issues/2280 + ## 0.1.0.0 -- 2026-07-14 ### Breaking changes @@ -10,15 +91,15 @@ ### New features * Add a binding for `clang_isBeforeInTranslationUnit`. This function is only - available for Clang versions 20.1 and newer; see [PR-53][pr-53]. + available for Clang versions 20.1 and newer; see [PR #53][pr-53]. * Add a binding for the `clang_Type_getOffsetOf` function. See [PR #37][pr-37]. * Add a new `clang_disposeToken` function to free a single `CXToken`. This is a helper function alongside the existing `clang_disposeTokens` functions, which - frees arrays of `CXToken`s. See [PR#42][pr-42]. -* Add a new `foldTry` function that behaves like `foldWitHandler`, but it + frees arrays of `CXToken`s. See [PR #42][pr-42]. +* Add a new `foldTry` function that behaves like `foldWithHandler`, but it returns the caught exception as a value like `Control.Exception.try` would. The caught exception is represented using a new type called `FoldException`. - See [PR #47][pr-47] + See [PR #47][pr-47]. * Add a compile-time check of the `CLANG_VERSION` macro. See the `Clang.Version.checkUserClangVersion` documentation for details. * Add `--with-so` option to the `configure` script, used to work around Cabal @@ -35,11 +116,11 @@ warnings for libclang APIs we actually call remain visible. See [issue #58][issue-58]. -[pr-37]: https://github.com/well-typed/libclang/pull/37 -[pr-42]: https://github.com/well-typed/libclang/pull/42 -[pr-47]: https://github.com/well-typed/libclang/pull/47 -[pr-53]: https://github.com/well-typed/libclang/pull/53 -[issue-58]: https://github.com/well-typed/libclang/issues/58 +[pr-37]: https://github.com/well-typed/libclang-bindings/pull/37 +[pr-42]: https://github.com/well-typed/libclang-bindings/pull/42 +[pr-47]: https://github.com/well-typed/libclang-bindings/pull/47 +[pr-53]: https://github.com/well-typed/libclang-bindings/pull/53 +[issue-58]: https://github.com/well-typed/libclang-bindings/issues/58 ## 0.1.0-alpha -- 2026-02-06 diff --git a/cbits/clang_wrappers_ffi.h b/cbits/clang_wrappers_ffi.h --- a/cbits/clang_wrappers_ffi.h +++ b/cbits/clang_wrappers_ffi.h @@ -74,9 +74,9 @@ /* OMITTED: int clang_getFileUniqueID (CXFile file, CXFileUniqueID * outID); */ -/* OMITTED: int clang_File_isEqual (CXFile file1, CXFile file2); */ - -/* OMITTED: CXString clang_File_tryGetRealPathName (CXFile file); */ +static inline void wrap_File_tryGetRealPathName(CXFile file, CXString * result) { + *result = clang_File_tryGetRealPathName(file); +} /* *** Physical source locations *** */ diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.73 for libclang-bindings 0.1.0.0. +# Generated by GNU Autoconf 2.73 for libclang-bindings 0.2.0.0. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2026 Free Software Foundation, @@ -584,8 +584,8 @@ # Identity of this package. PACKAGE_NAME='libclang-bindings' PACKAGE_TARNAME='libclang-bindings' -PACKAGE_VERSION='0.1.0.0' -PACKAGE_STRING='libclang-bindings 0.1.0.0' +PACKAGE_VERSION='0.2.0.0' +PACKAGE_STRING='libclang-bindings 0.2.0.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1241,7 +1241,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures libclang-bindings 0.1.0.0 to adapt to many kinds of systems. +'configure' configures libclang-bindings 0.2.0.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1304,7 +1304,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of libclang-bindings 0.1.0.0:";; + short | recursive ) echo "Configuration of libclang-bindings 0.2.0.0:";; esac cat <<\_ACEOF @@ -1392,7 +1392,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -libclang-bindings configure 0.1.0.0 +libclang-bindings configure 0.2.0.0 generated by GNU Autoconf 2.73 Copyright (C) 2026 Free Software Foundation, Inc. @@ -1616,7 +1616,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by libclang-bindings $as_me 0.1.0.0, which was +It was created by libclang-bindings $as_me 0.2.0.0, which was generated by GNU Autoconf 2.73. Invocation command line was $ $0$ac_configure_args_raw @@ -4502,7 +4502,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by libclang-bindings $as_me 0.1.0.0, which was +This file was extended by libclang-bindings $as_me 0.2.0.0, which was generated by GNU Autoconf 2.73. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4566,7 +4566,7 @@ cat >>"$CONFIG_STATUS" <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -libclang-bindings config.status 0.1.0.0 +libclang-bindings config.status 0.2.0.0 configured by $0, generated by GNU Autoconf 2.73, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_PREREQ([2.71]) -AC_INIT([libclang-bindings],[0.1.0.0]) +AC_INIT([libclang-bindings],[0.2.0.0]) dnl --with-compiler argument: This argument is passed by Cabal, so we have to dnl handle it. We do not use it, so we ignore the passed value. diff --git a/libclang-bindings.cabal b/libclang-bindings.cabal --- a/libclang-bindings.cabal +++ b/libclang-bindings.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: libclang-bindings -version: 0.1.0.0 +version: 0.2.0.0 license: BSD-3-Clause license-file: LICENSE author: Well-Typed LLP @@ -46,7 +46,7 @@ type: git location: https://github.com/well-typed/libclang-bindings subdir: libclang-bindings - tag: release-0.1.0.0 + tag: release-0.2.0.0 -------------------------------------------------------------------------------- -- Configuration @@ -180,6 +180,7 @@ Test.Discover Test.Meta.IsConcrete Test.Test.Exceptions + Test.Test.Tokens Test.Util.AST Test.Util.Clang Test.Util.FoldException diff --git a/src/Clang/CStandard.hs b/src/Clang/CStandard.hs --- a/src/Clang/CStandard.hs +++ b/src/Clang/CStandard.hs @@ -20,7 +20,6 @@ import Clang.HighLevel.Types import Clang.Internal.Results import Clang.LowLevel.Core -import Clang.Paths {------------------------------------------------------------------------------- C standard diff --git a/src/Clang/HighLevel.hs b/src/Clang/HighLevel.hs --- a/src/Clang/HighLevel.hs +++ b/src/Clang/HighLevel.hs @@ -23,12 +23,18 @@ , prettyMultiLoc , prettyRangeSingleLoc , prettyRangeMultiLoc + -- ** Conversion (CXFile) + , toMultiCXFile -- ** Convenience wrappers -- *** for @CXSourceLocation@ , clang_getDiagnosticLocation , clang_getCursorLocation , clang_getCursorLocation' , clang_getTokenLocation + -- *** for @CXFile@ + , ClangRealPathException(..) + , clang_getRealPath + , clang_tryGetRealPath -- *** for @CXSourceRange@ , clang_getDiagnosticRange , clang_getDiagnosticFixIt diff --git a/src/Clang/HighLevel/Diagnostics.hs b/src/Clang/HighLevel/Diagnostics.hs --- a/src/Clang/HighLevel/Diagnostics.hs +++ b/src/Clang/HighLevel/Diagnostics.hs @@ -16,6 +16,7 @@ import Clang.HighLevel.SourceLoc (MultiLoc, Range) import Clang.HighLevel.SourceLoc qualified as SourceLoc import Clang.LowLevel.Core +import Clang.Paths (SourcePath) {------------------------------------------------------------------------------- Definition @@ -29,7 +30,10 @@ , diagnosticSeverity :: SimpleEnum CXDiagnosticSeverity -- | Source location (where Clang would print the caret @^@) - , diagnosticLocation :: MultiLoc + -- + -- Uses 'SourcePath' rather than 'RealPath' because diagnostics may + -- refer to root headers whose real path is not available. + , diagnosticLocation :: MultiLoc SourcePath -- | Text of the diagnostic , diagnosticSpelling :: Text @@ -51,7 +55,7 @@ -- 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 :: [Range MultiLoc] + , diagnosticRanges :: [Range (MultiLoc SourcePath)] -- | Fix-it hints , diagnosticFixIts :: [FixIt] @@ -78,7 +82,7 @@ -- 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 :: Range MultiLoc + fixItRange :: Range (MultiLoc SourcePath) -- | Text that should replace the source code , fixItReplacement :: Text diff --git a/src/Clang/HighLevel/SourceLoc.hs b/src/Clang/HighLevel/SourceLoc.hs --- a/src/Clang/HighLevel/SourceLoc.hs +++ b/src/Clang/HighLevel/SourceLoc.hs @@ -7,11 +7,14 @@ -- * Comparisons , compareSingleLoc , rangeContainsLoc - -- * Conversion - , toMulti - , toRange - , fromSingle - , fromRange + -- * Conversion (CXFile) + , toMultiCXFile + -- * Conversion (RealPath) + , toMultiRealPath + , toRangeRealPath + -- * Conversion (SourcePath) + , toMultiSourcePath + , toRangeSourcePath -- * Get single location , clang_getExpansionLocation , clang_getPresumedLocation @@ -26,6 +29,10 @@ , prettyMultiLoc , prettyRangeSingleLoc , prettyRangeMultiLoc + -- * File to RealPath + , ClangRealPathException(..) + , clang_getRealPath + , clang_tryGetRealPath -- * Convenience wrappers -- * for @CXSourceLocation@ , clang_getDiagnosticLocation @@ -40,31 +47,33 @@ , clang_getTokenExtent ) where +import Control.Exception (Exception, throwIO) import Control.Monad import Control.Monad.IO.Class import Data.List (intercalate) import Data.Text (Text) +import Data.Text qualified as Text import Foreign.C import GHC.Generics (Generic) import GHC.Stack import Clang.LowLevel.Core qualified as Core +import Clang.LowLevel.Core.Pointers (CXFile) import Clang.Paths {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} --- | A /single/ location in a file +-- | A single location in a file -- --- See 'MultiLoc' for additional discussion. -data SingleLoc = SingleLoc { - singleLocPath :: !SourcePath +data SingleLoc path = SingleLoc { + singleLocPath :: !path , singleLocLine :: !Int , singleLocColumn :: !Int , singleLocOffset :: !Int } - deriving stock (Eq, Ord, Generic) + deriving stock (Eq, Ord, Generic, Functor, Foldable, Traversable) -- | Presumed location -- @@ -95,19 +104,23 @@ -- which is the position at the caret, and a \"spelling location\", which -- corresponds to the location of the @int@ token in the macro definition. -- +-- The presumed, spelling and file locations are 'Nothing' when they coincide +-- with the expansion location, that is, when they agree with it on file, line +-- and column. +-- -- References: -- -- * -- * -- (@getExpansionLoc@, @getSpellingLoc@, @getDecomposedSpellingLoc@) -data MultiLoc = MultiLoc { +data MultiLoc path = MultiLoc { -- | Expansion location -- -- If the location refers into a macro expansion, this corresponds to the -- location of the macro expansion. -- -- See - multiLocExpansion :: !SingleLoc + multiLocExpansion :: !(SingleLoc path) -- | Presumed location -- @@ -126,7 +139,7 @@ -- See . -- -- See - , multiLocSpelling :: !(Maybe SingleLoc) + , multiLocSpelling :: !(Maybe (SingleLoc path)) -- | File location -- @@ -136,9 +149,9 @@ -- location of the use of the argument. -- -- See - , multiLocFile :: !(Maybe SingleLoc) + , multiLocFile :: !(Maybe (SingleLoc path)) } - deriving stock (Eq, Ord, Generic) + deriving stock (Eq, Ord, Generic, Functor, Foldable, Traversable) -- | Range -- @@ -159,7 +172,7 @@ -- | Compare locations -- -- Returns 'Nothing' if the locations aren't in the same file. -compareSingleLoc :: SingleLoc -> SingleLoc -> Maybe Ordering +compareSingleLoc :: Eq path => SingleLoc path -> SingleLoc path -> Maybe Ordering compareSingleLoc a b = do guard $ singleLocPath a == singleLocPath b return $ @@ -173,7 +186,7 @@ -- upper bound (following 'Core.CXSourceRange'). -- -- Returns 'Nothing' if the three locations are not all in the same file. -rangeContainsLoc :: Range SingleLoc -> SingleLoc -> Maybe Bool +rangeContainsLoc :: Eq path => Range (SingleLoc path) -> SingleLoc path -> Maybe Bool rangeContainsLoc Range{rangeStart, rangeEnd} loc = do afterStart <- (/= LT) <$> compareSingleLoc loc rangeStart beforeEnd <- (== LT) <$> compareSingleLoc loc rangeEnd @@ -186,11 +199,16 @@ instances which we do not (yet?) define. -------------------------------------------------------------------------------} -instance Show SingleLoc where show = show . prettySingleLoc ShowFile -instance Show MultiLoc where show = show . prettyMultiLoc ShowFile -instance Show (Range SingleLoc) where show = show . prettyRangeSingleLoc -instance Show (Range MultiLoc) where show = show . prettyRangeMultiLoc +instance Show (SingleLoc RealPath) where show = show . prettySingleLoc getRealPath ShowFile +instance Show (MultiLoc RealPath) where show = show . prettyMultiLoc getRealPath ShowFile +instance Show (Range (SingleLoc RealPath)) where show = show . prettyRangeSingleLoc getRealPath +instance Show (Range (MultiLoc RealPath)) where show = show . prettyRangeMultiLoc getRealPath +instance Show (SingleLoc SourcePath) where show = show . prettySingleLoc getSourcePath ShowFile +instance Show (MultiLoc SourcePath) where show = show . prettyMultiLoc getSourcePath ShowFile +instance Show (Range (SingleLoc SourcePath)) where show = show . prettyRangeSingleLoc getSourcePath +instance Show (Range (MultiLoc SourcePath)) where show = show . prettyRangeMultiLoc getSourcePath + deriving stock instance {-# OVERLAPPABLE #-} Show a => Show (Range a) {------------------------------------------------------------------------------- @@ -202,22 +220,22 @@ data ShowFile = ShowFile | HideFile -prettySingleLoc :: ShowFile -> SingleLoc -> String -prettySingleLoc showFile loc = case showFile of +prettySingleLoc :: (path -> String) -> ShowFile -> SingleLoc path -> String +prettySingleLoc getPath showFile loc = case showFile of -- Use space instead of first colon to avoid GHC literate preprocessor mangling - ShowFile -> getSourcePath singleLocPath ++ " " + ShowFile -> getPath singleLocPath ++ " " ++ show singleLocLine ++ ":" ++ show singleLocColumn HideFile -> show singleLocLine ++ ":" ++ show singleLocColumn where SingleLoc{singleLocPath, singleLocLine, singleLocColumn} = loc -prettyMultiLoc :: ShowFile -> MultiLoc -> String -prettyMultiLoc showFile multiLoc = +prettyMultiLoc :: forall path. (path -> String) -> ShowFile -> MultiLoc path -> String +prettyMultiLoc getPath showFile multiLoc = intercalate " " . concat $ [ - [ prettySingleLoc showFile multiLocExpansion ] - , [ "" | Just loc <- [multiLocPresumed] ] - , [ "" | Just loc <- [multiLocSpelling] ] - , [ "" | Just loc <- [multiLocFile] ] + [ prettySingleLoc getPath showFile multiLocExpansion ] + , [ "" | Just loc <- [multiLocPresumed] ] + , [ "" | Just loc <- [multiLocSpelling] ] + , [ "" | Just loc <- [multiLocFile] ] ] where MultiLoc{ @@ -226,35 +244,38 @@ , multiLocSpelling , multiLocFile} = multiLoc - presumed :: PresumedLoc -> [Char] - presumed loc = single $ SingleLoc{ + expansionFilePath :: FilePath + expansionFilePath = getPath (singleLocPath multiLocExpansion) + + presumed :: PresumedLoc -> String + presumed loc = single getSourcePath SingleLoc{ singleLocPath = presumedLocPath loc , singleLocLine = presumedLocLine loc , singleLocColumn = presumedLocColumn loc , singleLocOffset = 0 -- not used for pretty-printing } - single :: SingleLoc -> [Char] - single loc = - prettySingleLoc - (if singleLocPath loc == singleLocPath multiLocExpansion - then HideFile - else ShowFile) + single :: (p -> String) -> SingleLoc p -> String + single get loc = + prettySingleLoc get + (if get (singleLocPath loc) == expansionFilePath + then HideFile else ShowFile) loc -prettyRangeSingleLoc :: Range SingleLoc -> String -prettyRangeSingleLoc = prettySourceRangeWith +prettyRangeSingleLoc :: Eq path => (path -> String) -> Range (SingleLoc path) -> String +prettyRangeSingleLoc getPath = prettySourceRangeWith singleLocPath - prettySingleLoc + (prettySingleLoc getPath) -prettyRangeMultiLoc :: Range MultiLoc -> String -prettyRangeMultiLoc = +prettyRangeMultiLoc :: Eq path => (path -> String) -> Range (MultiLoc path) -> String +prettyRangeMultiLoc getPath = prettySourceRangeWith (singleLocPath . multiLocExpansion) - prettyMultiLoc + (prettyMultiLoc getPath) prettySourceRangeWith :: - (a -> SourcePath) + Eq p + => (a -> p) -> (ShowFile -> a -> String) -> Range a -> String prettySourceRangeWith path pretty Range{rangeStart, rangeEnd} = concat [ @@ -271,100 +292,147 @@ Conversion -------------------------------------------------------------------------------} -toMulti :: MonadIO m => Core.CXSourceLocation -> m MultiLoc -toMulti location = do - expansion <- clang_getExpansionLocation location +-- | Build a 'MultiLoc' holding raw 'CXFile' handles. +-- +toMultiCXFile :: MonadIO m => Core.CXSourceLocation -> m (MultiLoc CXFile) +toMultiCXFile location = do + expansion <- toSingleCXFile =<< Core.clang_getExpansionLocation location + presumed <- clang_getPresumedLocation location + spelling <- toSingleCXFile =<< Core.clang_getSpellingLocation location + file <- toSingleCXFile =<< Core.clang_getFileLocation location - let differentSingle :: SingleLoc -> Maybe SingleLoc - differentSingle loc = do - guard $ singleLocPath loc /= singleLocPath expansion - guard $ singleLocLine loc /= singleLocLine expansion - guard $ singleLocColumn loc /= singleLocColumn expansion - -- We don't compare the file offset - return loc + expansionName <- Core.clang_getFileName (singleLocPath expansion) - differentPresumed :: PresumedLoc -> Maybe PresumedLoc + let differentSingle loc = do + sameFile <- + Core.clang_File_isEqual (singleLocPath loc) (singleLocPath expansion) + + return $ do + guard $ + not sameFile + || singleLocLine loc /= singleLocLine expansion + || singleLocColumn loc /= singleLocColumn expansion + pure loc + differentPresumed loc = do - guard $ presumedLocPath loc /= singleLocPath expansion - guard $ presumedLocLine loc /= singleLocLine expansion - guard $ presumedLocColumn loc /= singleLocColumn expansion + guard $ + getSourcePathText (presumedLocPath loc) /= expansionName + || presumedLocLine loc /= singleLocLine expansion + || presumedLocColumn loc /= singleLocColumn expansion return loc - MultiLoc expansion - <$> (differentPresumed <$> clang_getPresumedLocation location) - <*> (differentSingle <$> clang_getSpellingLocation location) - <*> (differentSingle <$> clang_getFileLocation location) + spelling' <- differentSingle spelling + file' <- differentSingle file + return MultiLoc{ + multiLocExpansion = expansion + , multiLocPresumed = differentPresumed presumed + , multiLocSpelling = spelling' + , multiLocFile = file' + } + where + toSingleCXFile (f, line, column, offset) = return SingleLoc{ + singleLocPath = f + , singleLocLine = fromIntegral line + , singleLocColumn = fromIntegral column + , singleLocOffset = fromIntegral offset + } -toRange :: MonadIO m => Core.CXSourceRange -> m (Range MultiLoc) -toRange = toRangeWith toMulti +-- | Convert to 'MultiLoc RealPath' +-- +-- The expansion location must be in a file on disk: it is resolved with +-- 'clang_getRealPath', which throws 'ClangRealPathException' otherwise (for +-- example, for a built-in macro definition or a directive in an unsaved file). +-- +-- The spelling and file locations can be virtual even when the expansion +-- location is not, so they are resolved with 'clang_tryGetRealPath' and set to +-- 'Nothing' on failure. For example, any header that includes @stdio.h@ also +-- pulls in this field from glibc: +-- +-- > // bits/types/__mbstate_t.h +-- > __WINT_TYPE__ __wch; +-- +-- Since @clang@ predefines @\_\_WINT_TYPE\_\_@, the expansion location of the +-- field is in the glibc header, but its spelling location is in @clang@'s +-- @\@ buffer, whose 'CXFile' is @NULL@. +-- +-- Consequently, 'Nothing' in 'multiLocSpelling' or 'multiLocFile' may also mean +-- that the location has no real path. +toMultiRealPath :: (MonadIO m, HasCallStack) => Core.CXSourceLocation -> m (MultiLoc RealPath) +toMultiRealPath location = do + multi <- toMultiCXFile location + expansion <- traverse clang_getRealPath (multiLocExpansion multi) + spelling <- trySingleRealPath (multiLocSpelling multi) + file <- trySingleRealPath (multiLocFile multi) + return MultiLoc{ + multiLocExpansion = expansion + , multiLocPresumed = multiLocPresumed multi + , multiLocSpelling = spelling + , multiLocFile = file + } + where + trySingleRealPath :: MonadIO m => Maybe (SingleLoc CXFile) -> m (Maybe (SingleLoc RealPath)) + trySingleRealPath = \case + Nothing -> return Nothing + Just loc -> fmap (\rp -> loc{ singleLocPath = rp }) <$> + clang_tryGetRealPath (singleLocPath loc) -fromSingle :: - (MonadIO m, HasCallStack) - => Core.CXTranslationUnit -> SingleLoc -> m Core.CXSourceLocation -fromSingle unit SingleLoc{singleLocPath, singleLocLine, singleLocColumn} = do - let SourcePath path = singleLocPath - file <- Core.clang_getFile unit path - Core.clang_getLocation - unit - file - (fromIntegral singleLocLine) - (fromIntegral singleLocColumn) +toMultiSourcePath :: MonadIO m => Core.CXSourceLocation -> m (MultiLoc SourcePath) +toMultiSourcePath location = + traverse (fmap SourcePath . Core.clang_getFileName) =<< toMultiCXFile location -fromRange :: - (MonadIO m, HasCallStack) - => Core.CXTranslationUnit -> Range SingleLoc -> m Core.CXSourceRange -fromRange unit Range{rangeStart, rangeEnd} = do - rangeStart' <- fromSingle unit rangeStart - rangeEnd' <- fromSingle unit rangeEnd - Core.clang_getRange rangeStart' rangeEnd' +toRangeRealPath :: (MonadIO m, HasCallStack) => Core.CXSourceRange -> m (Range (MultiLoc RealPath)) +toRangeRealPath = toRangeWith toMultiRealPath +toRangeSourcePath :: MonadIO m => Core.CXSourceRange -> m (Range (MultiLoc SourcePath)) +toRangeSourcePath = toRangeWith toMultiSourcePath + {------------------------------------------------------------------------------- Get single location -------------------------------------------------------------------------------} -clang_getExpansionLocation :: MonadIO m => Core.CXSourceLocation -> m SingleLoc +clang_getExpansionLocation :: (MonadIO m, HasCallStack) => Core.CXSourceLocation -> m (SingleLoc RealPath) clang_getExpansionLocation location = - toSingle =<< Core.clang_getExpansionLocation location + toSingleRealPath =<< Core.clang_getExpansionLocation location clang_getPresumedLocation :: MonadIO m => Core.CXSourceLocation -> m PresumedLoc clang_getPresumedLocation location = toPresumed <$> Core.clang_getPresumedLocation location -clang_getSpellingLocation :: MonadIO m => Core.CXSourceLocation -> m SingleLoc +clang_getSpellingLocation :: (MonadIO m, HasCallStack) => Core.CXSourceLocation -> m (SingleLoc RealPath) clang_getSpellingLocation location = - toSingle =<< Core.clang_getSpellingLocation location + toSingleRealPath =<< Core.clang_getSpellingLocation location -clang_getFileLocation :: MonadIO m => Core.CXSourceLocation -> m SingleLoc +clang_getFileLocation :: (MonadIO m, HasCallStack) => Core.CXSourceLocation -> m (SingleLoc RealPath) clang_getFileLocation location = - toSingle =<< Core.clang_getFileLocation location + toSingleRealPath =<< Core.clang_getFileLocation location {------------------------------------------------------------------------------- Convenience wrappers for @CXSourceLocation@ -------------------------------------------------------------------------------} -- | Retrieve the source location of the given diagnostic. -clang_getDiagnosticLocation :: MonadIO m => Core.CXDiagnostic -> m MultiLoc +clang_getDiagnosticLocation :: MonadIO m => Core.CXDiagnostic -> m (MultiLoc SourcePath) clang_getDiagnosticLocation diagnostic = - toMulti =<< Core.clang_getDiagnosticLocation diagnostic + toMultiSourcePath =<< Core.clang_getDiagnosticLocation diagnostic --- | Retrieve the physical location of the source constructor referenced by the +-- | Retrieve the physical location of the source construct referenced by the -- given cursor. -clang_getCursorLocation :: MonadIO m => Core.CXCursor -> m MultiLoc +clang_getCursorLocation :: (MonadIO m, HasCallStack) => Core.CXCursor -> m (MultiLoc RealPath) clang_getCursorLocation cursor = - toMulti =<< Core.clang_getCursorLocation cursor + toMultiRealPath =<< Core.clang_getCursorLocation cursor -- | Like 'clang_getCursorLocation', but only retrieve the expansion location -clang_getCursorLocation' :: MonadIO m => Core.CXCursor -> m SingleLoc +clang_getCursorLocation' :: (MonadIO m, HasCallStack) => Core.CXCursor -> m (SingleLoc RealPath) clang_getCursorLocation' cursor = clang_getExpansionLocation =<< Core.clang_getCursorLocation cursor -- | Retrieve the source location of the given token. clang_getTokenLocation :: - MonadIO m - => Core.CXTranslationUnit -> Core.CXToken -> m MultiLoc + (MonadIO m, HasCallStack) + => Core.CXTranslationUnit -> Core.CXToken -> m (MultiLoc RealPath) clang_getTokenLocation unit token = - toMulti =<< Core.clang_getTokenLocation unit token + toMultiRealPath =<< Core.clang_getTokenLocation unit token {------------------------------------------------------------------------------- Convenience wrappers for @CXSourceRange@ @@ -373,57 +441,92 @@ -- | Retrieve a source range associated with the diagnostic. clang_getDiagnosticRange :: MonadIO m - => Core.CXDiagnostic -> CUInt -> m (Range MultiLoc) + => Core.CXDiagnostic -> CUInt -> m (Range (MultiLoc SourcePath)) clang_getDiagnosticRange diagnostic range = - toRange =<< Core.clang_getDiagnosticRange diagnostic range + toRangeSourcePath =<< Core.clang_getDiagnosticRange diagnostic range -- | Retrieve the replacement information for a given fix-it. clang_getDiagnosticFixIt :: MonadIO m => Core.CXDiagnostic -> CUInt - -> m (Range MultiLoc, Text) + -> m (Range (MultiLoc SourcePath), Text) clang_getDiagnosticFixIt diagnostic fixit = do (range, replacement) <- Core.clang_getDiagnosticFixIt diagnostic fixit - (, replacement) <$> toRange range + (, replacement) <$> toRangeSourcePath range -- | Retrieve a range for a piece that forms the cursors spelling name. clang_Cursor_getSpellingNameRange :: - MonadIO m + (MonadIO m, HasCallStack) => Core.CXCursor -> CUInt -> CUInt - -> m (Maybe (Range MultiLoc)) + -> m (Maybe (Range (MultiLoc RealPath))) clang_Cursor_getSpellingNameRange cursor pieceIndex options = do mRange <- Core.clang_Cursor_getSpellingNameRange cursor pieceIndex options case mRange of Nothing -> return Nothing - Just range -> Just <$> toRangeWith toMulti range + Just range -> Just <$> toRangeWith toMultiRealPath range -- | Retrieve the physical extent of the source construct referenced by the -- given cursor. -clang_getCursorExtent :: MonadIO m => Core.CXCursor -> m (Range MultiLoc) +clang_getCursorExtent :: (MonadIO m, HasCallStack) => Core.CXCursor -> m (Range (MultiLoc RealPath)) clang_getCursorExtent cursor = - toRange =<< Core.clang_getCursorExtent cursor + toRangeRealPath =<< Core.clang_getCursorExtent cursor -- | Retrieve a source range that covers the given token. clang_getTokenExtent :: - MonadIO m + (MonadIO m, HasCallStack) => Core.CXTranslationUnit -> Core.CXToken - -> m (Range MultiLoc) + -> m (Range (MultiLoc RealPath)) clang_getTokenExtent unit token = - toRange =<< Core.clang_getTokenExtent unit token + toRangeRealPath =<< Core.clang_getTokenExtent unit token {------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Thrown by 'clang_getRealPath' when the file has no backing file on disk +data ClangRealPathException = + ClangRealPathException SourcePath CallStack + deriving stock (Show) + deriving anyclass (Exception) + +{------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -toSingle :: MonadIO m => (Core.CXFile, CUInt, CUInt, CUInt) -> m SingleLoc -toSingle (file, line, column, offset) = do - path <- Core.clang_getFileName file +-- | Get the 'RealPath' for a 'Core.CXFile' +-- +-- Precondition: the file must be on disk. Throws 'ClangRealPathException' +-- for virtual files. +clang_getRealPath :: (MonadIO m, HasCallStack) => Core.CXFile -> m RealPath +clang_getRealPath file = do + path <- Core.clang_File_tryGetRealPathName file + if Text.null path + then do + name <- SourcePath <$> Core.clang_getFileName file + liftIO . throwIO $ ClangRealPathException name callStack + else return (RealPath path) + +-- | Try to get the 'RealPath' for a 'Core.CXFile' +-- +-- Returns 'Nothing' for virtual/in-memory files. +clang_tryGetRealPath :: MonadIO m => Core.CXFile -> m (Maybe RealPath) +clang_tryGetRealPath file = do + path <- Core.clang_File_tryGetRealPathName file + return $ if Text.null path then Nothing else Just (RealPath path) + +-- | Build a @SingleLoc RealPath@. Throws 'ClangRealPathException' for virtual +-- files. +toSingleRealPath :: + (MonadIO m, HasCallStack) + => (Core.CXFile, CUInt, CUInt, CUInt) -> m (SingleLoc RealPath) +toSingleRealPath (file, line, column, offset) = do + realPath <- clang_getRealPath file return SingleLoc{ - singleLocPath = SourcePath path + singleLocPath = realPath , singleLocLine = fromIntegral line , singleLocColumn = fromIntegral column , singleLocOffset = fromIntegral offset @@ -431,7 +534,7 @@ toPresumed :: (Text, CUInt, CUInt) -> PresumedLoc toPresumed (path, line, column) = PresumedLoc{ - presumedLocPath = SourcePath path + presumedLocPath = SourcePath path , presumedLocLine = fromIntegral line , presumedLocColumn = fromIntegral column } diff --git a/src/Clang/HighLevel/Tokens.hs b/src/Clang/HighLevel/Tokens.hs --- a/src/Clang/HighLevel/Tokens.hs +++ b/src/Clang/HighLevel/Tokens.hs @@ -9,26 +9,28 @@ import Control.Monad.IO.Class import Data.Text (Text) import GHC.Generics (Generic) -import GHC.Stack import Clang.Enum.Simple -import Clang.HighLevel.SourceLoc (MultiLoc, Range, SingleLoc) +import Clang.HighLevel.SourceLoc (MultiLoc, Range) import Clang.HighLevel.SourceLoc qualified as SourceLoc import Clang.LowLevel.Core hiding (clang_tokenize) import Clang.LowLevel.Core qualified as Core +import Clang.Paths (SourcePath) {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} -data Token a = Token { +data Token path a = Token { tokenKind :: !(SimpleEnum CXTokenKind) , tokenSpelling :: !a - , tokenExtent :: !(Range MultiLoc) + , tokenExtent :: !(Range (MultiLoc path)) , tokenCursorKind :: !(SimpleEnum CXCursorKind) } - deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving stock (Eq, Ord, Functor, Foldable, Traversable, Generic) +deriving stock instance (Show a, Show (Range (MultiLoc path))) => Show (Token path a) + newtype TokenSpelling = TokenSpelling { getTokenSpelling :: Text } @@ -39,32 +41,43 @@ -------------------------------------------------------------------------------} -- | Get all tokens in the specified range +-- +-- @libclang@ lexes the source text between the spelling locations of the start +-- and end of the range. +-- +-- Consequently, a range that starts inside a macro expansion starts in the +-- macro definition. For example, given +-- +-- > #define T int +-- > T x; +-- +-- the extent of @x@ starts at the @int@ produced by expanding @T@, and yields +-- the tokens @int T x@: the text from the @int@ in the definition to @x@. clang_tokenize :: - (MonadIO m, HasCallStack) + MonadIO m => CXTranslationUnit - -> Range SingleLoc - -- ^ Range - -- - -- We use 'Range' 'SingleLoc' here instead of 'CXSourceRange' in order to - -- avoid ambiguity; see 'Clang.HighLevel.SourceLoc.MultiLoc' for discussion. - -> m [Token TokenSpelling] -clang_tokenize unit range = liftIO $ do - range' <- SourceLoc.fromRange unit range - bracket - (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 - cursor <- index_CXCursorArray cursors i - toToken unit (index_CXTokenArray tokens i) cursor + -> CXSourceRange + -> m [Token SourcePath TokenSpelling] +clang_tokenize unit range = + liftIO $ + bracket + (Core.clang_tokenize unit range) + (uncurry $ Core.clang_disposeTokens unit) $ \(tokens, numTokens) -> do + if numTokens == 0 + then return [] + else do + cursors <- clang_annotateTokens unit tokens numTokens + forM [0 .. pred numTokens] $ \i -> do + cursor <- index_CXCursorArray cursors i + toToken unit (index_CXTokenArray tokens i) cursor toToken :: MonadIO m - => CXTranslationUnit -> CXToken -> CXCursor -> m (Token TokenSpelling) + => CXTranslationUnit -> CXToken -> CXCursor -> m (Token SourcePath TokenSpelling) toToken unit token cursor = do tokenKind <- clang_getTokenKind token tokenSpelling <- TokenSpelling <$> clang_getTokenSpelling unit token - tokenExtent <- SourceLoc.clang_getTokenExtent unit token + tokenExtent <- SourceLoc.toRangeSourcePath =<< Core.clang_getTokenExtent unit token tokenCursorKind <- clang_getCursorKind cursor return Token{ tokenKind diff --git a/src/Clang/HighLevel/Types.hs b/src/Clang/HighLevel/Types.hs --- a/src/Clang/HighLevel/Types.hs +++ b/src/Clang/HighLevel/Types.hs @@ -3,18 +3,24 @@ -- Intended for unqualified import; see "Clang.HighLevel" for more detailed -- discussion. module Clang.HighLevel.Types ( + -- * Paths + RealPath(..) + , SourcePath(..) -- * Source locations - SingleLoc(..) + , SingleLoc(..) , MultiLoc(..) , Range(..) -- ** Comparisons , compareSingleLoc , rangeContainsLoc - -- ** Conversion - , toMulti - , toRange - , fromSingle - , fromRange + -- ** Conversion (CXFile) + , toMultiCXFile + -- ** Conversion (RealPath) + , toMultiRealPath + , toRangeRealPath + -- ** Conversion (SourcePath) + , toMultiSourcePath + , toRangeSourcePath -- * Tokens , Token(..) , TokenSpelling(..) @@ -55,3 +61,4 @@ import Clang.HighLevel.Fold import Clang.HighLevel.SourceLoc import Clang.HighLevel.Tokens +import Clang.Paths diff --git a/src/Clang/LowLevel/Core.hs b/src/Clang/LowLevel/Core.hs --- a/src/Clang/LowLevel/Core.hs +++ b/src/Clang/LowLevel/Core.hs @@ -99,6 +99,7 @@ , CXAvailabilityKind(..) , clang_getTranslationUnitCursor , clang_equalCursors + , clang_hashCursor , clang_getCursorSemanticParent , clang_getCursorLexicalParent , clang_getCursorTLSKind @@ -216,6 +217,8 @@ , clang_Location_isFromMainFile -- * File manipulation routines , clang_getFileName + , clang_File_isEqual + , clang_File_tryGetRealPathName -- * Debugging , clang_breakpoint -- * Exceptions @@ -697,6 +700,13 @@ onHaskellHeap b $ \b' -> cToBool <$> wrap_equalCursors a' b' +-- | Compute a hash value for the given cursor. +-- +-- +clang_hashCursor :: MonadIO m => CXCursor -> m CUInt +clang_hashCursor cursor = liftIO $ + onHaskellHeap cursor wrap_hashCursor + -- | Determine the semantic parent of the given cursor. -- -- The semantic parent of a cursor is the cursor that semantically contains the @@ -2000,6 +2010,23 @@ -- clang_getFileName :: MonadIO m => CXFile -> m Text clang_getFileName file = liftIO $ preallocate_$ wrap_getFileName file + +-- | Check whether two files refer to the same underlying file. +-- +-- +clang_File_isEqual :: MonadIO m => CXFile -> CXFile -> m Bool +clang_File_isEqual f1 f2 = liftIO $ + cToBool <$> nowrapper_File_isEqual f1 f2 + +-- | Get the real, canonical path name of the given file. +-- +-- Returns the empty string for virtual files (files that are not saved to +-- disk, such as unsaved files passed to @clang_parseTranslationUnit@). +-- +-- +clang_File_tryGetRealPathName :: MonadIO m => CXFile -> m Text +clang_File_tryGetRealPathName file = + liftIO $ preallocate_$ wrap_File_tryGetRealPathName file -- | Retrieve the contents of the given file that is loaded in the given -- translation unit. diff --git a/src/Clang/LowLevel/Core/Enums.hs b/src/Clang/LowLevel/Core/Enums.hs --- a/src/Clang/LowLevel/Core/Enums.hs +++ b/src/Clang/LowLevel/Core/Enums.hs @@ -183,6 +183,12 @@ -- We don't need them, and by omitting them we are compatible with a larger -- range of @libclang@ versions. -- +-- NOTE: 'CXType_PredefinedSugar' only exists in @libclang@ 23 and later. We +-- include it anyway, because @libclang@ 23 reports it for types as common as +-- the argument of @malloc@. Older versions never report it, and the +-- 'Clang.Enum.Simple.IsSimpleEnum' instance does not rely on the header +-- declaring it. +-- -- NOTE: We omit @CXType_FirstBuiltin@ and @CXType_LastBuiltin@, which are -- aliases for the first and last builtin type in the list, respectively. If -- we need them, we should define them as separate constants. @@ -269,6 +275,18 @@ | CXType_ExtVector | CXType_Atomic + + -- | Sugar for the predefined types @__size_t@, @__signed_size_t@ and + -- @__ptrdiff_t@ (LLVM/Clang 23 and later). + -- + -- Clang uses these for the type of @sizeof@ and of pointer subtraction, + -- and in the signatures of library builtins such as @malloc@ and + -- @strlen@. LLVM/Clang 22 reports the same types as 'CXType_Unexposed'; + -- earlier versions report the underlying integer type directly. That + -- integer type is the canonical type. + -- + -- See . + | CXType_PredefinedSugar deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) {------------------------------------------------------------------------------- diff --git a/src/Clang/LowLevel/Core/Instances.hsc b/src/Clang/LowLevel/Core/Instances.hsc --- a/src/Clang/LowLevel/Core/Instances.hsc +++ b/src/Clang/LowLevel/Core/Instances.hsc @@ -149,6 +149,10 @@ simpleToC CXType_Attributed = #const CXType_Attributed simpleToC CXType_ExtVector = #const CXType_ExtVector simpleToC CXType_Atomic = #const CXType_Atomic + -- Headers before LLVM/Clang 23 do not declare CXType_PredefinedSugar, so we + -- cannot take its value from the header. The value is fixed by the + -- libclang ABI, and older versions never report it. + simpleToC CXType_PredefinedSugar = 182 simpleFromC (#const CXType_Invalid) = Just CXType_Invalid simpleFromC (#const CXType_Unexposed) = Just CXType_Unexposed @@ -216,6 +220,7 @@ simpleFromC (#const CXType_Attributed) = Just CXType_Attributed simpleFromC (#const CXType_ExtVector) = Just CXType_ExtVector simpleFromC (#const CXType_Atomic) = Just CXType_Atomic + simpleFromC 182 = Just CXType_PredefinedSugar simpleFromC _otherwise = Nothing diff --git a/src/Clang/LowLevel/FFI.hs b/src/Clang/LowLevel/FFI.hs --- a/src/Clang/LowLevel/FFI.hs +++ b/src/Clang/LowLevel/FFI.hs @@ -4,14 +4,15 @@ #include "clang_config.h" +import Foreign.C.Types +import Foreign.Ptr + import Clang.Enum.Simple import Clang.Internal.ByValue import Clang.Internal.ConstPtr import Clang.LowLevel.Core.Enums import Clang.LowLevel.Core.Pointers import Clang.LowLevel.Core.Structs -import Foreign.C.Types -import Foreign.Ptr -- *** Top-level *** @@ -124,9 +125,11 @@ -- OMITTED: int clang_getFileUniqueID (CXFile file, CXFileUniqueID * outID); --- OMITTED: int clang_File_isEqual (CXFile file1, CXFile file2); +foreign import capi unsafe "clang_wrappers.h clang_File_isEqual" + nowrapper_File_isEqual :: CXFile -> CXFile -> IO CInt --- OMITTED: CXString clang_File_tryGetRealPathName (CXFile file); +foreign import capi unsafe "clang_wrappers.h" + wrap_File_tryGetRealPathName :: CXFile -> W CXString_ -> IO () -- *** Physical source locations *** diff --git a/src/Clang/Paths.hs b/src/Clang/Paths.hs --- a/src/Clang/Paths.hs +++ b/src/Clang/Paths.hs @@ -2,8 +2,14 @@ -- * Source paths SourcePath(..) , getSourcePath - , nullSourcePath + , getSourcePathText + -- * Real paths + , RealPath(..) + , getRealPath + , getRealPathText + , realPathToSourcePath + -- * C include directories , CIncludeDir(..) ) where @@ -16,24 +22,52 @@ Source paths -------------------------------------------------------------------------------} --- | Filesystem path of a source file, typically a C header --- --- The 'Text' type is used because Clang uses UTF-8 internally for everything, --- including paths. +-- | Path of a source file as reported by @clang_getFileName@ -- --- The format of the path is platform-dependent. For example, different --- directory separators are used on different platforms. +-- For on-disk files this is typically the path used in the @#include@ +-- directive. For virtual files (unsaved buffers, @#line@ directives) +-- it is the clang-assigned name. Platform-dependent format. newtype SourcePath = SourcePath Text - -- 'Show' instance valid due to 'IsString' instance deriving newtype (Eq, IsString, Ord, Show) -- | Get the 'FilePath' representation of a 'SourcePath' getSourcePath :: SourcePath -> FilePath -getSourcePath (SourcePath path) = Text.unpack path +getSourcePath = Text.unpack . getSourcePathText --- | Determine if a 'SourcePath' is empty -nullSourcePath :: SourcePath -> Bool -nullSourcePath (SourcePath path) = Text.null path +-- | Get the 'Text' representation of a 'SourcePath' +getSourcePathText :: SourcePath -> Text +getSourcePathText (SourcePath path) = path + +{------------------------------------------------------------------------------- + Real paths +-------------------------------------------------------------------------------} + +-- | Canonical absolute path of an on-disk file +-- +-- Obtained via @clang_File_tryGetRealPathName@. Two 'RealPath' values +-- for the same physical file compare equal regardless of include spelling. +-- Platform-dependent format. +-- +-- Virtual files (unsaved buffers, the @\@ buffer) have no real path, +-- so functions that must return a 'RealPath' for one throw +-- 'Clang.HighLevel.ClangRealPathException'. That includes the location +-- functions in "Clang.HighLevel". For virtual files, use +-- 'Clang.HighLevel.clang_tryGetRealPath' or a 'SourcePath' conversion such as +-- 'Clang.HighLevel.Types.toMultiSourcePath'. +newtype RealPath = RealPath Text + deriving stock (Eq, Ord, Show) + +-- | Get the 'FilePath' representation of a 'RealPath' +getRealPath :: RealPath -> FilePath +getRealPath = Text.unpack . getRealPathText + +-- | Get the 'Text' representation of a 'RealPath' +getRealPathText :: RealPath -> Text +getRealPathText (RealPath path) = path + +-- | Embed a 'RealPath' as a 'SourcePath' +realPathToSourcePath :: RealPath -> SourcePath +realPathToSourcePath (RealPath t) = SourcePath t {------------------------------------------------------------------------------- C include directories diff --git a/test/Test/Test/Tokens.hs b/test/Test/Test/Tokens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Test/Tokens.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Test tokenization of cursor extents +module Test.Test.Tokens (tests) where + +import Data.Default (def) +import Data.Text (Text) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Util.Clang qualified as Clang +import Test.Util.Input (TestInput) +import Test.Util.Input qualified as Input + +import Clang.Args +import Clang.Enum.Bitfield +import Clang.Enum.Simple +import Clang.HighLevel qualified as HighLevel +import Clang.HighLevel.Types +import Clang.LowLevel.Core + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Test.Tokens" [ + testCase "macroDefinition" tokenize_macroDefinition + , testCase "commandLineMacro" tokenize_commandLineMacro + , testCase "declStartsInExpansion" tokenize_declStartsInExpansion + ] + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tokenize_macroDefinition :: Assertion +tokenize_macroDefinition = do + tokens <- tokenizeCursor def input CXCursor_MacroDefinition "FOO" + assertEqual "" ["FOO", "(", "x", ")", "x", "+", "1"] tokens + where + input :: TestInput + input = "#define FOO(x) x + 1\n" + +-- | A @-D@ macro lives in Clang's predefines buffer, which has no 'CXFile' +tokenize_commandLineMacro :: Assertion +tokenize_commandLineMacro = do + tokens <- tokenizeCursor args "" CXCursor_MacroDefinition "FOO" + assertEqual "" ["FOO", "(", "x", ")", "x", "+", "1"] tokens + where + args :: ClangArgs + args = ClangArgs ["-DFOO(x)=x + 1"] + +-- | The range is tokenized as is, from the spelling location of its start +tokenize_declStartsInExpansion :: Assertion +tokenize_declStartsInExpansion = do + tokens <- tokenizeCursor def input CXCursor_VarDecl "x" + assertEqual "" ["int", "T", "x"] tokens + where + input :: TestInput + input = Input.unlines [ + "#define T int" + , "T x;" + ] + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Tokenize the extent of the top-level cursor with the given kind and name +tokenizeCursor :: + ClangArgs + -> TestInput + -> CXCursorKind + -> Text + -> IO [Text] +tokenizeCursor args input kind name = + Clang.withInputUsing args flags input $ \unit -> do + root <- clang_getTranslationUnitCursor unit + extents <- HighLevel.clang_visitChildren root $ simpleFold $ \curr -> do + currKind <- fromSimpleEnum <$> clang_getCursorKind curr + currName <- clang_getCursorSpelling curr + if currKind == Right kind && currName == name + then foldContinueWith =<< clang_getCursorExtent curr + else foldContinue + case extents of + [extent] -> + map (getTokenSpelling . tokenSpelling) + <$> HighLevel.clang_tokenize unit extent + _otherwise -> + assertFailure $ "expected one cursor, found " ++ show (length extents) + where + flags :: BitfieldEnum CXTranslationUnit_Flags + flags = bitfieldEnum [CXTranslationUnit_DetailedPreprocessingRecord] diff --git a/test/Test/Util/Clang.hs b/test/Test/Util/Clang.hs --- a/test/Test/Util/Clang.hs +++ b/test/Test/Util/Clang.hs @@ -6,6 +6,7 @@ module Test.Util.Clang ( -- * Top-level call into clang withInput + , withInputUsing , parseUsing ) where @@ -13,6 +14,8 @@ import Data.Default import Test.Util.Input (TestInput (..)) +import Clang.Args +import Clang.Enum.Bitfield import Clang.Enum.Simple import Clang.HighLevel qualified as HighLevel import Clang.HighLevel.Types @@ -23,15 +26,23 @@ -------------------------------------------------------------------------------} withInput :: TestInput -> (CXTranslationUnit -> IO a) -> IO a -withInput (TestInput input) onSuccess = +withInput = withInputUsing def mempty + +withInputUsing :: + ClangArgs + -> BitfieldEnum CXTranslationUnit_Flags + -> TestInput + -> (CXTranslationUnit -> IO a) + -> IO a +withInputUsing args flags (TestInput input) onSuccess = HighLevel.withUnsavedFile "test.h" input $ \file -> HighLevel.withIndex DisplayDiagnostics $ \ix -> HighLevel.withTranslationUnit2 ix (Just "test.h") - def + args [file] - mempty + flags onFailure onSuccess where diff --git a/test/Test/Version.hs b/test/Test/Version.hs --- a/test/Test/Version.hs +++ b/test/Test/Version.hs @@ -78,7 +78,7 @@ version `elem` historicReleases -- For the current versions we don't know which minor/patch to expect - , major `elem` [21, 22] + , major `elem` [21, 22, 23] ] -- | Historic @llvm@ releases diff --git a/test/test-clang-bindings.hs b/test/test-clang-bindings.hs --- a/test/test-clang-bindings.hs +++ b/test/test-clang-bindings.hs @@ -4,6 +4,7 @@ import Test.Meta.IsConcrete qualified as IsConcrete import Test.Tasty import Test.Test.Exceptions qualified as Exceptions +import Test.Test.Tokens qualified as Tokens import Test.Version qualified as Version {------------------------------------------------------------------------------- @@ -19,5 +20,6 @@ ] , testGroup "Tests" [ Exceptions.tests + , Tokens.tests ] ]