diff --git a/dev/select-pass.excalidraw b/dev/select-pass.excalidraw index 7ed1917fc..9a88fb2de 100644 --- a/dev/select-pass.excalidraw +++ b/dev/select-pass.excalidraw @@ -457,13 +457,13 @@ "updated": 1763179304934, "link": null, "locked": false, - "text": "getTransitiveAvailability", + "text": "getTransitiveSelectability", "fontSize": 20, "fontFamily": 5, "textAlign": "center", "verticalAlign": "middle", "containerId": "2X3A6sCqYbvEBrGYPPdcT", - "originalText": "getTransitiveAvailability", + "originalText": "getTransitiveSelectability", "autoResize": true, "lineHeight": 1.25 }, @@ -1748,4 +1748,4 @@ "lockedMultiSelections": {} }, "files": {} -} \ No newline at end of file +} diff --git a/examples/libpcap/generate-and-run.sh b/examples/libpcap/generate-and-run.sh index 2fb39fba9..0c23b6f66 100755 --- a/examples/libpcap/generate-and-run.sh +++ b/examples/libpcap/generate-and-run.sh @@ -11,6 +11,7 @@ export PROJECT_ROOT echo "# Building libpcap" echo "# " + rm -rfv libpcap* wget https://www.tcpdump.org/release/libpcap-1.10.5.tar.xz tar -xf libpcap-1.10.5.tar.xz mv libpcap-1.10.5 libpcap diff --git a/examples/libpcap/generate.sh b/examples/libpcap/generate.sh index bbb977927..f3709dd4a 100755 --- a/examples/libpcap/generate.sh +++ b/examples/libpcap/generate.sh @@ -26,9 +26,15 @@ libclang_flags=( # the declarations into an `hs-bindgen`-internal abstract syntax tree. These # flags affect the parsing/reifying step. parse_flags=( - # TODO: We panic without `--parse-all`, see - # https://github.com/well-typed/hs-bindgen/issues/1155. - --parse-all + # The external binding specifications we provide for the C standard library + # do not cover all definitions. We instruct `hs-bindgen` to parse additional + # headers. + --parse-by-header-path "struct_timeval.h" + --parse-by-header-path "socket.h" + # By default `hs-bindgen` parses all headers in the main header directory, + # but we adjust the parse predicate above, and so need to provide this + # option. + --parse-from-main-header-dirs ) # We only generate bindings for a sub-set of all parsed/reified declarations. @@ -56,9 +62,8 @@ select_flags=( # For example, activate Info-level log messages to see which declarations are # selected/not selected, or which C macros we succeed or fail to parse. debug_flags=( - # # Run `hs-bindgen` with log level "Info". + # # Run `hs-bindgen` with log level "Info" or "Debug". # -v3 - # # Run `hs-bindgen` with log level "Debug". # -v4 ) diff --git a/hs-bindgen/examples/golden/declarations/select_scoping.h b/hs-bindgen/examples/golden/declarations/select_scoping.h index 4aa6a6e6b..53f8455dd 100644 --- a/hs-bindgen/examples/golden/declarations/select_scoping.h +++ b/hs-bindgen/examples/golden/declarations/select_scoping.h @@ -2,7 +2,6 @@ // select! #include "select_scoping_header.h" - // This declaration is parsed _and_ selected. typedef int ParsedAndSelected1; @@ -12,4 +11,4 @@ typedef ParsedAndNotSelected ParsedAndSelected2; // This declaration is parsed _and_ selected. The dependency is _not_ parsed nor // selected (custom parse predicate). -typedef struct PossiblyNotParsedDefinitelyNotSelected ParsedAndSelected3; +typedef struct ParseNotAttemptedNotSelected ParsedAndSelected3; diff --git a/hs-bindgen/examples/golden/declarations/select_scoping_header.h b/hs-bindgen/examples/golden/declarations/select_scoping_header.h index 7d316cd1d..ec724e105 100644 --- a/hs-bindgen/examples/golden/declarations/select_scoping_header.h +++ b/hs-bindgen/examples/golden/declarations/select_scoping_header.h @@ -4,6 +4,6 @@ typedef int ParsedAndNotSelected; // This declaration is _not_ parsed by the test, which uses a custom parse // predicate. -struct PossiblyNotParsedDefinitelyNotSelected { +struct ParseNotAttemptedNotSelected { int x; }; diff --git a/hs-bindgen/examples/golden/edge-cases/duplicate.h b/hs-bindgen/examples/golden/edge-cases/duplicate.h new file mode 100644 index 000000000..17fda7d6b --- /dev/null +++ b/hs-bindgen/examples/golden/edge-cases/duplicate.h @@ -0,0 +1,3 @@ +#include "duplicate_macro.h" + +void function(duplicate x); diff --git a/hs-bindgen/examples/golden/edge-cases/duplicate_macro.h b/hs-bindgen/examples/golden/edge-cases/duplicate_macro.h new file mode 100644 index 000000000..b774cf74a --- /dev/null +++ b/hs-bindgen/examples/golden/edge-cases/duplicate_macro.h @@ -0,0 +1,2 @@ +typedef int duplicate; +#define duplicate duplicate diff --git a/hs-bindgen/fixtures/declarations/select_scoping/Example.hs b/hs-bindgen/fixtures/declarations/select_scoping/Example.hs index 56c7ff4dc..d7ed8ca7a 100644 --- a/hs-bindgen/fixtures/declarations/select_scoping/Example.hs +++ b/hs-bindgen/fixtures/declarations/select_scoping/Example.hs @@ -26,7 +26,7 @@ import Prelude (Bounded, Enum, Eq, Integral, Num, Ord, Read, Real, Show) {-| __C declaration:__ @ParsedAndSelected1@ - __defined at:__ @declarations\/select_scoping.h:7:13@ + __defined at:__ @declarations\/select_scoping.h:6:13@ __exported by:__ @declarations\/select_scoping.h@ -} diff --git a/hs-bindgen/fixtures/declarations/select_scoping/th.txt b/hs-bindgen/fixtures/declarations/select_scoping/th.txt index 6bb02613b..e9283837f 100644 --- a/hs-bindgen/fixtures/declarations/select_scoping/th.txt +++ b/hs-bindgen/fixtures/declarations/select_scoping/th.txt @@ -2,7 +2,7 @@ -- addDependentFile examples/golden/declarations/select_scoping.h {-| __C declaration:__ @ParsedAndSelected1@ - __defined at:__ @declarations\/select_scoping.h:7:13@ + __defined at:__ @declarations\/select_scoping.h:6:13@ __exported by:__ @declarations\/select_scoping.h@ -} @@ -10,7 +10,7 @@ newtype ParsedAndSelected1 = ParsedAndSelected1 {un_ParsedAndSelected1 :: CInt} {- ^ __C declaration:__ @ParsedAndSelected1@ - __defined at:__ @declarations\/select_scoping.h:7:13@ + __defined at:__ @declarations\/select_scoping.h:6:13@ __exported by:__ @declarations\/select_scoping.h@ -} diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/Example.hs b/hs-bindgen/fixtures/edge-cases/duplicate/Example.hs new file mode 100644 index 000000000..e29e1faaf --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/Example.hs @@ -0,0 +1 @@ +module Example () where diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/Example/FunPtr.hs b/hs-bindgen/fixtures/edge-cases/duplicate/Example/FunPtr.hs new file mode 100644 index 000000000..039a9bd3c --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/Example/FunPtr.hs @@ -0,0 +1 @@ +module Example.FunPtr () where diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/Example/Global.hs b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Global.hs new file mode 100644 index 000000000..cc2c6676b --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Global.hs @@ -0,0 +1 @@ +module Example.Global () where diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/Example/Safe.hs b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Safe.hs new file mode 100644 index 000000000..2b033807a --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Safe.hs @@ -0,0 +1 @@ +module Example.Safe () where diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/Example/Unsafe.hs b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Unsafe.hs new file mode 100644 index 000000000..d7c28695f --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/Example/Unsafe.hs @@ -0,0 +1 @@ +module Example.Unsafe () where diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/bindingspec.yaml b/hs-bindgen/fixtures/edge-cases/duplicate/bindingspec.yaml new file mode 100644 index 000000000..aad9e713d --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/bindingspec.yaml @@ -0,0 +1,5 @@ +version: + hs_bindgen: 0.1.0 + binding_specification: '1.0' +target: x86_64-pc-linux-musl +hsmodule: Example diff --git a/hs-bindgen/fixtures/edge-cases/duplicate/th.txt b/hs-bindgen/fixtures/edge-cases/duplicate/th.txt new file mode 100644 index 000000000..bcf511b82 --- /dev/null +++ b/hs-bindgen/fixtures/edge-cases/duplicate/th.txt @@ -0,0 +1,2 @@ +-- addDependentFile examples/golden/edge-cases/duplicate_macro.h +-- addDependentFile examples/golden/edge-cases/duplicate.h diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 4674ae2db..a8fcf61f2 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/hs-bindgen/hs-bindgen.cabal @@ -137,6 +137,7 @@ library internal HsBindgen.Frontend.Naming HsBindgen.Frontend.Pass HsBindgen.Frontend.Pass.ConstructTranslationUnit + HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass HsBindgen.Frontend.Pass.HandleMacros HsBindgen.Frontend.Pass.HandleMacros.Error diff --git a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs b/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs index ee1d894f9..f84db6752 100644 --- a/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs +++ b/hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs @@ -29,7 +29,7 @@ import HsBindgen.Backend.UniqueSymbol import HsBindgen.BindingSpec qualified as BindingSpec import HsBindgen.Config.Internal import HsBindgen.Errors -import HsBindgen.Frontend.Analysis.DeclIndex +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.AST.External qualified as C import HsBindgen.Frontend.Naming qualified as C diff --git a/hs-bindgen/src-internal/HsBindgen/Config/Prelims.hs b/hs-bindgen/src-internal/HsBindgen/Config/Prelims.hs index bd9912da5..50052a00d 100644 --- a/hs-bindgen/src-internal/HsBindgen/Config/Prelims.hs +++ b/hs-bindgen/src-internal/HsBindgen/Config/Prelims.hs @@ -112,7 +112,7 @@ data UniqueIdMsg = instance PrettyForTrace UniqueIdMsg where prettyForTrace = \case UniqueIdEmpty -> PP.vcat [ - "empty unique identifier ('UniqueId'):" + "empty unique identifier ('UniqueId', '--unique-id'):" , " C uses a global namespace." , " We encourage using a unique identifier to avoid duplicate symbol names." , " For example, use and adapt 'com.example.package'." diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend.hs b/hs-bindgen/src-internal/HsBindgen/Frontend.hs index be8d3a17b..3990c55da 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend.hs @@ -213,7 +213,7 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do -- Omitted types frontendOmitTypes <- cache "frontendOmitTypes" $ - Map.elems . view ( #unitAnn % #declIndex % #omitted ) <$> + Map.elems . DeclIndex.getOmitted . view ( #unitAnn % #declIndex) <$> resolveBindingSpecsPass -- Declarations. diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs index 9291ed36d..f8f346116 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs @@ -7,45 +7,110 @@ -- > import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) -- > import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex module HsBindgen.Frontend.Analysis.DeclIndex ( - DeclIndex(..) + Usable(..) + , Unusable(..) + , Entry(..) + , DeclIndex -- opaque -- * Construction - , DeclIndexError(..) , fromParseResults - -- * Query + -- * Query parse successes , lookup , (!) - , lookupAttachedParseMsgs , getDecls + -- * Other queries + , lookupEntry + , toList + , lookupLoc + , lookupUnusableLoc , keysSet + , getOmitted + -- * Support for macro failures + , registerMacroFailures + -- * Support for binding specifications + , registerOmittedDeclarations + , registerExternalDeclarations -- * Support for selection , Match , selectDeclIndex + , getUnusables ) where import Prelude hiding (lookup) import Control.Monad.State +import Data.Foldable qualified as Foldable import Data.Function +import Data.List.NonEmpty ((<|)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Optics.Core (over, set, (%)) -import Text.SimplePrettyPrint (hcat, showToCtxDoc) import Clang.HighLevel.Types -import Clang.Paths (SourcePath) +import Clang.Paths import HsBindgen.Errors import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict import HsBindgen.Frontend.Pass.HandleMacros.Error import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Imports +import HsBindgen.Imports hiding (toList) import HsBindgen.Util.Tracer {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} +-- | Usable declaration +-- +-- A declaration is usable if we successfully reified the declaration or if it +-- is external. +-- +-- (We avoid the term available, because it is overloaded with Clang's +-- CXAvailabilityKind). +data Usable = + UsableSuccess ParseSuccess + -- TODO https://github.com/well-typed/hs-bindgen/issues/1273: Attach + -- information required to match the select predicate also to external + -- declarations. + | UsableExternal + deriving stock (Show, Generic) + +-- | Unusable declaration +-- +-- A declaration is unusable if we did not reify the declaration. We can not +-- generate bindings for unusable declarations. +-- +-- (We avoid the term available, because it is overloaded with Clang's +-- CXAvailabilityKind). +data Unusable = + UnusableParseNotAttempted (NonEmpty ParseNotAttempted) + | UnusableParseFailure ParseFailure + | UnusableConflict ConflictingDeclarations + | UnusableFailedMacro FailedMacro + -- TODO https://github.com/well-typed/hs-bindgen/issues/1273: Attach + -- information required to match the select predicate also to omitted + -- declarations. + -- | Omitted by prescriptive binding specifications + | UnusableOmitted (C.QualName, SourcePath) + deriving stock (Show, Generic) + +instance PrettyForTrace Unusable where + prettyForTrace = \case + UnusableParseNotAttempted{} -> + "parse not attempted: (!) adjust parse predicate" + UnusableParseFailure{} -> + "parse failed" + UnusableConflict{} -> + "conflicting declarations" + UnusableFailedMacro{} -> + "macro parsing or type-checking failed" + UnusableOmitted{} -> + "omitted by prescriptive binding specification" + +-- | Entry of declaration index +data Entry = UsableE Usable | UnusableE Unusable + deriving stock (Show, Generic) + -- | Index of all declarations -- -- The declaration index indexes C types (not Haskell types); as such, it @@ -54,9 +119,9 @@ import HsBindgen.Util.Tracer -- -- When we replace a declaration by an external one while resolving binding -- specifications, it is not deleted from the declaration index but reclassified --- as 'external'. In the "HsBindgen.Frontend.Analysis.UseDeclGraph", dependency --- edges from use sites to the replaced declaration are deleted, because the use --- sites now depend on the external Haskell type. +-- as 'UsableExternal'. In the "HsBindgen.Frontend.Analysis.UseDeclGraph", +-- dependency edges from use sites to the replaced declaration are deleted, +-- because the use sites now depend on the external Haskell type. -- -- For example, assume the C code -- @@ -84,217 +149,198 @@ import HsBindgen.Util.Tracer -- -- The edge from D3 to D2 was removed, since D3 now depends on a Haskell type -- R3, which is not part of the use-decl graph. --- --- The records --- - 'succeeded', 'notAttempted', and 'failed' store parse results; --- - 'failedMacros' stores failed macros; and --- - 'omitted' and 'external' store binding specifications. -data DeclIndex = DeclIndex { - succeeded :: !(Map C.QualPrelimDeclId ParseSuccess) - , notAttempted :: !(Map C.QualPrelimDeclId ParseNotAttempted) - , failed :: !(Map C.QualPrelimDeclId ParseFailure) - , failedMacros :: !(Map C.QualPrelimDeclId HandleMacrosParseMsg) - , omitted :: !(Map C.QualPrelimDeclId (C.QualName, SourcePath)) - -- TODO https://github.com/well-typed/hs-bindgen/issues/1273: Attach - -- information required to match the select predicate also to external - -- declarations. - , external :: !(Set C.QualPrelimDeclId) +newtype DeclIndex = DeclIndex { + unDeclIndex :: Map C.QualPrelimDeclId Entry } deriving stock (Show, Generic) emptyIndex :: DeclIndex -emptyIndex = - DeclIndex Map.empty Map.empty Map.empty Map.empty Map.empty Set.empty +emptyIndex = DeclIndex Map.empty {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} --- | Construction state (internal type) -data PartialIndex = PartialIndex{ - index :: DeclIndex - , errors :: !(Map C.QualPrelimDeclId DeclIndexError) - } - deriving (Generic) - -fromParseResults :: HasCallStack => [ParseResult] -> (DeclIndex, [DeclIndexError]) -fromParseResults results = - fromPartialIndex - . flip execState (PartialIndex emptyIndex Map.empty) - $ mapM_ aux results +fromParseResults :: [ParseResult] -> DeclIndex +fromParseResults results = flip execState emptyIndex $ mapM_ aux results where - fromPartialIndex :: PartialIndex -> (DeclIndex, [DeclIndexError]) - fromPartialIndex (PartialIndex i e) = - -- We assert that no key is used twice. This assertion is not strictly - -- necessary, and we may want to remove it in the future. - let ss = Map.keysSet i.succeeded - os = Map.keysSet i.notAttempted - fs = Map.keysSet i.failed - is = Set.intersection - sharedKeys = Set.unions [is ss os, is ss fs, is os fs] - in if sharedKeys == Set.empty then - (i, Map.elems e) - else - panicPure $ - "DeclIndex.fromParseResults: shared keys: " <> show sharedKeys - - aux :: ParseResult -> State PartialIndex () - aux parse = modify' $ \oldIndex@PartialIndex{..} -> - if Map.member qualPrelimDeclId errors then - -- Ignore further definitions of the same ID after an error - oldIndex - else case parse of - ParseResultSuccess x -> - let (succeeded', mErr) = flip runState Nothing $ - Map.alterF - (insert x) - qualPrelimDeclId - index.succeeded - in PartialIndex{ - index = set #succeeded succeeded' index - , errors = case mErr of - Nothing -> errors - Just err -> Map.insert qualPrelimDeclId err errors - } - ParseResultNotAttempted x -> - over - ( #index % #notAttempted ) - ( insertFailure qualPrelimDeclId x ) - oldIndex - ParseResultFailure x -> - over - ( #index % #failed ) - ( insertFailure qualPrelimDeclId x ) - oldIndex + aux :: ParseResult -> State DeclIndex () + aux new = modify' $ + DeclIndex . Map.alter (Just . handleParseResult declId new) declId . unDeclIndex where - qualPrelimDeclId :: C.QualPrelimDeclId - qualPrelimDeclId = getQualPrelimDeclId parse - - insert :: - ParseSuccess - -> Maybe ParseSuccess - -> State (Maybe DeclIndexError) (Maybe ParseSuccess) - insert new mOld = state $ \_ -> - case mOld of - Nothing -> - -- The normal case: no previous declaration exists - success new - - Just old - | sameDefinition new.psDecl.declKind old.psDecl.declKind -> - -- Redeclaration but with the same definition. This can happen, - -- for example for opaque structs. We stick with the first but - -- add the parse messages of the second. - success $ over #psAttachedMsgs (++ new.psAttachedMsgs) old - + declId :: C.QualPrelimDeclId + declId = getParseResultDeclId new + + handleParseResult :: + C.QualPrelimDeclId -> ParseResult -> Maybe Entry -> Entry + handleParseResult declId new = \case + Nothing -> parseResultToEntry new + -- We remove duplicates with /different/ values and store them as + -- 'ConflictingDeclarations'. We could detect and handle some but not all + -- of these duplicates; for now, we remove them all. + -- + -- Duplicates may arise, for example, if a declaration is redefined by a + -- macro; for other kinds of declarations, clang will have reported an + -- error already. + -- + -- There are cases where one declaration is an actual C construct like a + -- variable declaration, but the new declaration is a macro of the same + -- name that simply defers to the C construct. This is apparently a valid + -- pattern, which for example occurs in @stdio.h@: + -- + -- > typedef int FILE; + -- > extern FILE *const stdin; + -- > #define stdin (stdin) + -- + -- Note that in examples like this, we will always "succeed" in parsing + -- the macro, because proper macro handling does not happen until after + -- the @DeclIndex@ has been built (at this point the macro is merely a + -- list of tokens). So whether the macro is something we can handle or not + -- is irrelevant at this point. + Just old -> case old of + UsableE oldUsable -> case oldUsable of + UsableSuccess oldParseSuccess -> case new of + ParseResultSuccess newParseSuccess + -- Redeclaration but with the same definition. This can happen, for + -- example for opaque structs. We stick with the first declaration. + | sameDefinition oldParseSuccess.psDecl.declKind newParseSuccess.psDecl.declKind -> + old + | otherwise -> + newConflict oldParseSuccess.psDecl.declInfo.declLoc + ParseResultNotAttempted _ -> old + ParseResultFailure _ -> parseResultToEntry new + UsableExternal -> + panicPure "handleParseResult: usable external" + UnusableE oldUnusable -> case oldUnusable of + (UnusableParseNotAttempted nasOld) + | ParseResultNotAttempted naNew <- new -> + UnusableE $ UnusableParseNotAttempted $ naNew <| nasOld | otherwise -> - -- Redeclaration with a /different/ value. This is only legal - -- for macros; for other kinds of declarations, clang will have - -- reported an error already. - -- - -- TODO: there are cases where one declaration is an actual C - -- construct like a variable declaration, but the new - -- declaration is a macro of the same name that simply defers to - -- the C construct. This is apparently a valid pattern, which - -- for example occurs in @stdio.h@: - -- - -- > typedef int FILE; - -- > extern FILE *const stdin; - -- > #define stdin (stdin) - -- - -- See issue #1155. - failure $ Redeclaration{ - redeclarationId = C.declQualPrelimDeclId $ new.psDecl - , redeclarationOld = old.psDecl.declInfo.declLoc - , redeclarationNew = new.psDecl.declInfo.declLoc - } - where - -- No errors; set (or replace) value in the map - success :: a -> (Maybe a, Maybe DeclIndexError) - success x = (Just x, Nothing) - - -- In case of an error, /remove/ the value from the map - failure :: e -> (Maybe a, Maybe e) - failure err = (Nothing, Just err) - - -- For failures, we just stick with the first failure. - insertFailure :: Ord k => k -> a -> Map k a -> Map k a - insertFailure key x = - Map.alter ( \case - Nothing -> Just x - Just x' -> Just x' - ) key - -sameDefinition :: C.DeclKind Parse -> C.DeclKind Parse -> Bool -sameDefinition a b = - case (a, b) of - (C.DeclMacro macroA, C.DeclMacro macroB) -> - sameMacro macroA macroB - _otherwise -> - a == b - -sameMacro :: UnparsedMacro -> UnparsedMacro -> Bool -sameMacro = (==) `on` (map tokenSpelling . unparsedTokens) - -{------------------------------------------------------------------------------- - Construction errors --------------------------------------------------------------------------------} - -data DeclIndexError = - Redeclaration { - redeclarationId :: C.QualPrelimDeclId - , redeclarationOld :: SingleLoc - , redeclarationNew :: SingleLoc - } - deriving stock (Show, Eq) - -instance PrettyForTrace DeclIndexError where - prettyForTrace Redeclaration{..} = hcat [ - prettyForTrace redeclarationId - , " declared at " - , showToCtxDoc redeclarationOld - , " was redeclared at " - , showToCtxDoc redeclarationNew - , ". No binding generated." - ] - -instance IsTrace Level DeclIndexError where - getDefaultLogLevel = \case - -- Redeclarations can only happen for macros, so we issue a warning, - -- rather than an error. - Redeclaration{} -> Warning - getSource = const HsBindgen - getTraceId = const "decl-index-error" + parseResultToEntry new + UnusableParseFailure _ -> old + UnusableConflict c -> addConflicts c + UnusableFailedMacro x -> + panicPure $ "handleParseResult: unusable failed macro" <> show x + UnusableOmitted x -> + panicPure $ "handelParseResult: unusable omitted" <> show x + where + newLoc :: SingleLoc + newLoc = getParseResultLoc new + + addConflicts :: ConflictingDeclarations -> Entry + addConflicts c = + UnusableE $ UnusableConflict $ + addConflictingLoc c newLoc + + newConflict :: SingleLoc -> Entry + newConflict oldLoc = + UnusableE $ UnusableConflict $ + conflictingDeclarations declId oldLoc newLoc + + parseResultToEntry :: ParseResult -> Entry + parseResultToEntry = \case + ParseResultSuccess r -> UsableE $ UsableSuccess r + ParseResultNotAttempted r -> UnusableE $ UnusableParseNotAttempted $ r :| [] + ParseResultFailure r -> UnusableE $ UnusableParseFailure r + + sameDefinition :: C.DeclKind Parse -> C.DeclKind Parse -> Bool + sameDefinition a b = + case (a, b) of + (C.DeclMacro macroA, C.DeclMacro macroB) -> + sameMacro macroA macroB + _otherwise -> + a == b + + sameMacro :: UnparsedMacro -> UnparsedMacro -> Bool + sameMacro = (==) `on` (map tokenSpelling . unparsedTokens) {------------------------------------------------------------------------------- - Query + Query parse successes -------------------------------------------------------------------------------} +-- | Lookup parse success. lookup :: C.QualPrelimDeclId -> DeclIndex -> Maybe (C.Decl Parse) -lookup qualPrelimDeclId = - fmap psDecl . Map.lookup qualPrelimDeclId . succeeded +lookup qualPrelimDeclId (DeclIndex i) = case Map.lookup qualPrelimDeclId i of + Nothing -> Nothing + Just (UsableE (UsableSuccess x)) -> Just $ x.psDecl + _ -> Nothing +-- | Unsafe! Get parse success. (!) :: HasCallStack => DeclIndex -> C.QualPrelimDeclId -> C.Decl Parse (!) declIndex qualPrelimDeclId = fromMaybe (panicPure $ "Unknown key: " ++ show qualPrelimDeclId) $ lookup qualPrelimDeclId declIndex -lookupAttachedParseMsgs :: C.QualPrelimDeclId -> DeclIndex -> [AttachedParseMsg DelayedParseMsg] -lookupAttachedParseMsgs qualPrelimDeclId = - maybe [] psAttachedMsgs . Map.lookup qualPrelimDeclId . succeeded - +-- | Get all parse successes. getDecls :: DeclIndex -> [C.Decl Parse] -getDecls = map psDecl . Map.elems . succeeded +getDecls = mapMaybe toDecl . Map.elems . unDeclIndex + where + toDecl = \case + UsableE (UsableSuccess x) -> Just x.psDecl + _otherEntries -> Nothing + +{------------------------------------------------------------------------------- + Other queries +-------------------------------------------------------------------------------} +-- | Lookup an entry of a declaration index. +lookupEntry :: C.QualPrelimDeclId -> DeclIndex -> Maybe Entry +lookupEntry x = Map.lookup x . unDeclIndex + +-- | Get all entries of a declaration index. +toList :: DeclIndex -> [(C.QualPrelimDeclId, Entry)] +toList = Map.toList . unDeclIndex + +-- | Get the source locations of a declaration. +lookupLoc :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc] +lookupLoc d (DeclIndex i) = case Map.lookup d i of + Nothing -> [] + Just (UsableE e) -> case e of + UsableSuccess x -> [x.psDecl.declInfo.declLoc] + UsableExternal -> [] + Just (UnusableE e) -> unusableToLoc e + +-- | Get the source locations of an unusable declaration. +lookupUnusableLoc :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc] +lookupUnusableLoc d (DeclIndex i) = case Map.lookup d i of + Nothing -> [] + Just (UsableE _) -> [] + Just (UnusableE e) -> unusableToLoc e + +unusableToLoc :: Unusable -> [SingleLoc] +unusableToLoc = \case + UnusableParseNotAttempted xs -> + [x.loc | (ParseNotAttempted x) <- NonEmpty.toList xs] + UnusableParseFailure (ParseFailure x) -> [x.loc] + UnusableConflict x -> getLocs x + UnusableFailedMacro (FailedMacro x) -> [x.loc] + UnusableOmitted{} -> [] + +-- | Get the identifiers of all declarations in the index. keysSet :: DeclIndex -> Set C.QualPrelimDeclId -keysSet DeclIndex{..} = Set.unions [ - Map.keysSet succeeded - , Map.keysSet notAttempted - , Map.keysSet failed - , Map.keysSet failedMacros - -- TODO https://github.com/well-typed/hs-bindgen/issues/1301: Also add - -- 'omitted' here and deal with the 'omitted' case in selection. - ] +keysSet = Map.keysSet . unDeclIndex + +-- | Get omitted entries. +getOmitted :: DeclIndex -> Map C.QualPrelimDeclId (C.QualName, SourcePath) +getOmitted = Map.mapMaybe toOmitted . unDeclIndex + where + toOmitted :: Entry -> Maybe (C.QualName, SourcePath) + toOmitted = \case + UsableE _ -> Nothing + UnusableE e -> case e of + UnusableOmitted x -> Just x + _otherEntry -> Nothing + +{------------------------------------------------------------------------------- + Support for macro failures +-------------------------------------------------------------------------------} + +registerMacroFailures :: [FailedMacro] -> DeclIndex -> DeclIndex +registerMacroFailures xs index = Foldable.foldl' insert index xs + where + insert :: DeclIndex -> FailedMacro -> DeclIndex + insert (DeclIndex i) x = + DeclIndex $ Map.insert (unFailedMacro x).declId (UnusableE $ UnusableFailedMacro x) i {------------------------------------------------------------------------------- Support for selection @@ -303,28 +349,54 @@ keysSet DeclIndex{..} = Set.unions [ -- Match function to find selection roots. type Match = C.QualPrelimDeclId -> SingleLoc -> C.Availability -> Bool +-- | Limit the declaration index to those entries that match the select +-- predicate. Do not include anything external nor omitted. selectDeclIndex :: Match -> DeclIndex -> DeclIndex -selectDeclIndex p DeclIndex{..} = DeclIndex { - succeeded = Map.filter matchSuccess succeeded - , notAttempted = Map.filter matchNotAttempted notAttempted - , failed = Map.filter matchFailed failed - , failedMacros = Map.filter matchFailedMacros failedMacros - , omitted - , external - } +selectDeclIndex p = DeclIndex . Map.filter matchEntry . unDeclIndex where + matchEntry :: Entry -> Bool + matchEntry = \case + UsableE e -> case e of + UsableSuccess (ParseSuccess i d _) -> + p i d.declInfo.declLoc d.declInfo.declAvailability + UsableExternal -> + False + UnusableE e -> case e of + UnusableParseNotAttempted xs -> + any (matchMsg . unParseNotAttempted) xs + UnusableParseFailure (ParseFailure m) -> + matchMsg m + UnusableConflict x -> + or [p (getDeclId x) l C.Available | l <- getLocs x ] + UnusableFailedMacro (FailedMacro m) -> + matchMsg m + UnusableOmitted{} -> + False + matchMsg :: AttachedParseMsg a -> Bool matchMsg m = p m.declId m.loc m.availability - matchSuccess :: ParseSuccess -> Bool - matchSuccess (ParseSuccess i d _) = - p i d.declInfo.declLoc d.declInfo.declAvailability +-- | Restrict the declaration index to unusable declarations in a given set. +getUnusables :: DeclIndex -> Set C.QualPrelimDeclId -> Map C.QualPrelimDeclId Unusable +getUnusables (DeclIndex i) xs = Map.mapMaybe retainUnusable $ Map.restrictKeys i xs + where + retainUnusable :: Entry -> Maybe Unusable + retainUnusable = \case + UsableE _ -> Nothing + UnusableE x -> Just x - matchNotAttempted :: ParseNotAttempted -> Bool - matchNotAttempted (ParseNotAttempted m) = matchMsg m +{------------------------------------------------------------------------------- + Supprot for binding specifications +-------------------------------------------------------------------------------} - matchFailed :: ParseFailure -> Bool - matchFailed (ParseFailure m) = matchMsg m +registerOmittedDeclarations :: + Map C.QualPrelimDeclId (C.QualName, SourcePath) -> DeclIndex -> DeclIndex +registerOmittedDeclarations xs = + DeclIndex . Map.union (UnusableE . UnusableOmitted <$> xs) . unDeclIndex - matchFailedMacros :: HandleMacrosParseMsg -> Bool - matchFailedMacros (HandleMacrosParseMsg m) = matchMsg m +registerExternalDeclarations :: Set C.QualPrelimDeclId -> DeclIndex -> DeclIndex +registerExternalDeclarations xs index = Foldable.foldl' insert index xs + where + insert :: DeclIndex -> C.QualPrelimDeclId -> DeclIndex + insert (DeclIndex i) x = + DeclIndex $ Map.insert x (UsableE UsableExternal) i diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs index 9db25985f..887ec0742 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs @@ -16,6 +16,7 @@ module HsBindgen.Frontend.Analysis.UseDeclGraph ( -- * Query , toDecls , getTransitiveDeps + , getStrictTransitiveDeps -- * Deletion , deleteDeps -- * Debugging @@ -26,6 +27,7 @@ import Data.DynGraph.Labelled (DynGraph) import Data.DynGraph.Labelled qualified as DynGraph import Data.List qualified as List import Data.Map qualified as Map +import Data.Set qualified as Set import Clang.HighLevel.Types import Clang.Paths @@ -118,6 +120,9 @@ toDecls index (Wrap graph) = getTransitiveDeps :: UseDeclGraph -> [C.QualPrelimDeclId] -> Set C.QualPrelimDeclId getTransitiveDeps = DynGraph.reaches . unwrap +getStrictTransitiveDeps :: UseDeclGraph -> [C.QualPrelimDeclId] -> Set C.QualPrelimDeclId +getStrictTransitiveDeps graph xs = getTransitiveDeps graph xs Set.\\ (Set.fromList xs) + {------------------------------------------------------------------------------- Deletion -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs index 0febf00f8..8080d920d 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs @@ -39,10 +39,8 @@ mkDeclMeta :: -> IncludeGraph -> (DeclMeta, [Msg ConstructTranslationUnit]) mkDeclMeta parseResults includeGraph = - let (declIndex, declIndexErrors) = DeclIndex.fromParseResults parseResults + let declIndex = DeclIndex.fromParseResults parseResults declUseDecl = UseDeclGraph.fromDecls includeGraph $ DeclIndex.getDecls declIndex declDeclUse = DeclUseGraph.fromUseDecl declUseDecl - in ( DeclMeta{..} - , map ConstructTranslationUnitErrorDeclIndex declIndexErrors - ) + in (DeclMeta{..}, []) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/Conflict.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/Conflict.hs new file mode 100644 index 000000000..85cfb4c33 --- /dev/null +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/Conflict.hs @@ -0,0 +1,62 @@ +module HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict ( + ConflictingDeclarations -- opaque + , conflictingDeclarations + , addConflictingLoc + , getDeclId + , getLocs + , getMinimumLoc + ) where + +import Data.Set qualified as Set +import Text.SimplePrettyPrint qualified as PP + +import Clang.HighLevel.Types + +import HsBindgen.Frontend.Naming qualified as C +import HsBindgen.Imports +import HsBindgen.Util.Tracer + +-- | Multiple declarations for the same identifier +data ConflictingDeclarations = ConflictingDeclarations { + conflictId :: C.QualPrelimDeclId + , conflictLocs :: Set SingleLoc + } + deriving stock (Eq, Show) + +instance PrettyForTrace ConflictingDeclarations where + prettyForTrace = \case + ConflictingDeclarations{..} -> + let lead = PP.hcat [ + "Conflicting declarations for " + , prettyForTrace conflictId + , " declared at:" + ] + details = [ + PP.vcat [ PP.string $ "- " ++ show l | l <- Set.toList conflictLocs ] + , "No binding generated." + ] + in PP.hangs' lead 2 details + +instance IsTrace Level ConflictingDeclarations where + getDefaultLogLevel = \case + ConflictingDeclarations{} -> Warning + getSource = const HsBindgen + getTraceId = const "decl-index" + +-- | Create conflicting declarations. +conflictingDeclarations :: C.QualPrelimDeclId -> SingleLoc -> SingleLoc -> ConflictingDeclarations +conflictingDeclarations d l1 l2 = ConflictingDeclarations d $ Set.fromList [l1, l2] + +addConflictingLoc :: ConflictingDeclarations -> SingleLoc -> ConflictingDeclarations +addConflictingLoc (ConflictingDeclarations d xs) x = ConflictingDeclarations d $ Set.insert x xs + +getDeclId :: ConflictingDeclarations -> C.QualPrelimDeclId +getDeclId = conflictId + +getLocs :: ConflictingDeclarations -> [SingleLoc] +getLocs = Set.toList . conflictLocs + +getMinimumLoc :: ConflictingDeclarations -> SingleLoc +-- Use of 'minimum' is safe here, becuase we ensure that the location set is +-- non-empty. +getMinimumLoc = minimum . conflictLocs diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs index 1838ae1ef..0bb9db0a7 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs @@ -1,7 +1,7 @@ module HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass ( ConstructTranslationUnit , DeclMeta(..) - , ConstructTranslationUnitMsg(..) + , ConstructTranslationUnitMsg ) where import HsBindgen.Frontend.Analysis.DeclIndex @@ -57,10 +57,16 @@ data DeclMeta = DeclMeta { Trace messages -------------------------------------------------------------------------------} -data ConstructTranslationUnitMsg = - ConstructTranslationUnitErrorDeclIndex DeclIndexError +data ConstructTranslationUnitMsg deriving stock (Show, Generic) - deriving anyclass (PrettyForTrace, IsTrace Level) + +instance PrettyForTrace ConstructTranslationUnitMsg where + prettyForTrace = const "no message available" + +instance IsTrace Level ConstructTranslationUnitMsg where + getDefaultLogLevel = const Debug + getSource = const HsBindgen + getTraceId = const "construct-translation-unit" {------------------------------------------------------------------------------- CoercePass diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs index e84375799..afa0d16fc 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs @@ -17,7 +17,8 @@ import Clang.Args (CStandard) import Clang.HighLevel.Types import HsBindgen.Errors -import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex (..)) +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) +import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.LanguageC qualified as LanC @@ -43,27 +44,11 @@ handleMacros standard C.TranslationUnit{unitDecls, unitIncludeGraph, unitAnn} = fmap partitionEithers $ mapM processDecl unitDecls where reassemble :: - (([HandleMacrosParseMsg] , [C.Decl HandleMacros]) , [Msg HandleMacros]) + (([FailedMacro] , [C.Decl HandleMacros]) , [Msg HandleMacros]) -> (C.TranslationUnit HandleMacros, [Msg HandleMacros]) - reassemble ((failedMacroLst, decls'), msgs) = - let index :: DeclIndex - index = unitAnn.declIndex - - failedMacros :: Map C.QualPrelimDeclId HandleMacrosParseMsg - failedMacros = Map.fromList $ - map (\x -> (declId $ unHandleMacrosParseMsg x, x)) failedMacroLst - - failedMacroIds :: Set C.QualPrelimDeclId - failedMacroIds = Map.keysSet failedMacros - - index' = DeclIndex { - succeeded = Map.withoutKeys index.succeeded failedMacroIds - , notAttempted = index.notAttempted - , failed = index.failed - , failedMacros - , omitted = index.omitted - , external = index.external - } + reassemble ((failedMacros, decls'), msgs) = + let index' :: DeclIndex + index' = DeclIndex.registerMacroFailures failedMacros unitAnn.declIndex unit = C.TranslationUnit{ unitDecls = decls' @@ -76,7 +61,7 @@ handleMacros standard C.TranslationUnit{unitDecls, unitIncludeGraph, unitAnn} = processDecl :: C.Decl ConstructTranslationUnit - -> M (Either HandleMacrosParseMsg (C.Decl HandleMacros)) + -> M (Either FailedMacro (C.Decl HandleMacros)) processDecl C.Decl{declInfo, declKind} = case declKind of C.DeclMacro macro -> processMacro info' macro @@ -296,7 +281,7 @@ processTypedef info C.Typedef{typedefType, typedefAnn} = do processMacro :: C.DeclInfo HandleMacros - -> UnparsedMacro -> M (Either HandleMacrosParseMsg (C.Decl HandleMacros)) + -> UnparsedMacro -> M (Either FailedMacro (C.Decl HandleMacros)) processMacro info (UnparsedMacro tokens) = do -- Simply omit macros from the AST that we cannot parse bimap addInfo toDecl <$> parseMacro name tokens @@ -309,9 +294,9 @@ processMacro info (UnparsedMacro tokens) = do qualPrelimDeclId :: C.QualPrelimDeclId qualPrelimDeclId = C.QualPrelimDeclIdNamed name C.NameKindOrdinary - addInfo :: HandleMacrosError -> HandleMacrosParseMsg + addInfo :: HandleMacrosError -> FailedMacro addInfo = - HandleMacrosParseMsg . + FailedMacro . AttachedParseMsg qualPrelimDeclId info.declLoc C.Available toDecl :: C.CheckedMacro HandleMacros -> C.Decl HandleMacros diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/Error.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/Error.hs index f963d9e4d..e9277fd60 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/Error.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/Error.hs @@ -1,6 +1,6 @@ module HsBindgen.Frontend.Pass.HandleMacros.Error ( -- * Parse - HandleMacrosParseMsg(..) + FailedMacro(..) , HandleMacrosError(..) -- * Reparse , HandleMacrosReparseMsg(..) @@ -22,8 +22,8 @@ import HsBindgen.Util.Tracer -------------------------------------------------------------------------------} -- | Macro parse messages; see also 'HandleMacrosReparseMsg' -newtype HandleMacrosParseMsg = HandleMacrosParseMsg { - unHandleMacrosParseMsg :: AttachedParseMsg HandleMacrosError +newtype FailedMacro = FailedMacro { + unFailedMacro :: AttachedParseMsg HandleMacrosError } deriving stock (Show, Generic) deriving anyclass (PrettyForTrace, IsTrace Level) @@ -76,7 +76,7 @@ instance IsTrace Level HandleMacrosError where Reparse messages -------------------------------------------------------------------------------} --- | Macro reparse messages; see also 'HandleMacrosParseMsg' +-- | Macro reparse messages; see also 'FailedMacro' data HandleMacrosReparseMsg = -- | We could not reparse a fragment of C (to recover macro use sites) HandleMacrosErrorReparse LanC.Error diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs index cc2768198..dd47141d3 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs @@ -257,7 +257,7 @@ structDecl info = \curr -> do foldRecurseWith (declOrFieldDecl $ structFieldDecl info) $ \xs -> do let (otherRs, fields) = first concat $ partitionEithers xs - (fails, otherDecls) = partitionEithers $ map getDecl otherRs + (fails, otherDecls) = partitionEithers $ map getParseResultDecl otherRs mPartitioned <- partitionChildren otherDecls fields pure $ (fails ++) $ case mPartitioned of Just decls -> @@ -318,7 +318,7 @@ unionDecl info = \curr -> do foldRecurseWith (declOrFieldDecl $ unionFieldDecl info) $ \xs -> do let (otherRs, fields) = first concat $ partitionEithers xs - (fails, otherDecls) = partitionEithers $ map getDecl otherRs + (fails, otherDecls) = partitionEithers $ map getParseResultDecl otherRs mPartitioned <- partitionChildren otherDecls fields pure $ (fails ++) $ case mPartitioned of Just decls -> @@ -517,7 +517,7 @@ functionDecl info = \curr -> do _ -> foldRecurseWith nestedDecl $ \nestedDecls -> do let declsAndAttrs = concat nestedDecls (parseRs, attrs) = partitionEithers declsAndAttrs - (fails, decls) = partitionEithers $ map getDecl parseRs + (fails, decls) = partitionEithers $ map getParseResultDecl parseRs purity = C.decideFunctionPurity attrs (anonDecls, otherDecls) = partitionAnonDecls decls @@ -638,7 +638,7 @@ varDecl info = \curr -> do foldContinue _ -> foldRecurseWith nestedDecl $ \nestedRs -> do let - (fails, nestedDecls) = partitionEithers $ map getDecl $ concat nestedRs + (fails, nestedDecls) = partitionEithers $ map getParseResultDecl $ concat nestedRs (anonDecls, otherDecls) = partitionAnonDecls nestedDecls -- This declaration may act as a definition even if it has no diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs index cbf56950b..751d09c61 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs @@ -12,8 +12,9 @@ module HsBindgen.Frontend.Pass.Parse.IsPass ( , ParseNotAttempted(..) , ParseFailure(..) , ParseResult(..) - , getDecl - , getQualPrelimDeclId + , getParseResultDecl + , getParseResultLoc + , getParseResultDeclId , parseSucceed , parseSucceedWith , parseDoNotAttempt @@ -25,7 +26,7 @@ module HsBindgen.Frontend.Pass.Parse.IsPass ( , DelayedParseMsg(..) ) where -import Text.SimplePrettyPrint (CtxDoc, ($$), (<+>), (><)) +import Text.SimplePrettyPrint (CtxDoc, ($$), (><)) import Text.SimplePrettyPrint qualified as PP import Clang.Enum.Simple @@ -149,6 +150,17 @@ data ParseSuccess = ParseSuccess { } deriving stock (Show, Generic) +instance PrettyForTrace ParseSuccess where + prettyForTrace ParseSuccess{..} = + if null psAttachedMsgs then + PP.hang "Parse success:" 2 $ + prettyForTrace $ + C.Located psDecl.declInfo.declLoc psQualPrelimDeclId + else + PP.hang "Parse success with messages:" 2 $ + PP.vcat $ + map prettyForTrace psAttachedMsgs + -- | Why did we not attempt to parse a declaration? data ParseNotAttemptedReason = -- | We do not parse builtin declarations. @@ -176,7 +188,7 @@ data ParseNotAttemptedReason = deriving stock (Show, Eq, Ord) instance PrettyForTrace ParseNotAttemptedReason where - prettyForTrace x = "Parse not attempted:" <+> case x of + prettyForTrace x = case x of DeclarationBuiltin -> "Builtin declaration" DeclarationUnavailable -> "Declaration is 'unavailable' on this platform" ParsePredicateNotMatched -> "Parse predicate did not match" @@ -189,7 +201,10 @@ newtype ParseNotAttempted = ParseNotAttempted { unParseNotAttempted :: AttachedParseMsg ParseNotAttemptedReason } deriving stock (Eq, Show, Generic) - deriving anyclass (PrettyForTrace) + +instance PrettyForTrace ParseNotAttempted where + prettyForTrace (ParseNotAttempted x) = + PP.hang "Parse not attempted: " 2 $ prettyForTrace x -- | Declarations that match the parse predicate but that we fail to parse and -- reify @@ -200,24 +215,36 @@ newtype ParseFailure = ParseFailure { unParseFailure :: AttachedParseMsg DelayedParseMsg } deriving stock (Eq, Show, Generic) - deriving anyclass (PrettyForTrace, IsTrace Level) + deriving anyclass (IsTrace Level) + +instance PrettyForTrace ParseFailure where + prettyForTrace (ParseFailure x) = + PP.hang "Parse failure:" 2 $ + prettyForTrace x data ParseResult = ParseResultSuccess ParseSuccess | ParseResultNotAttempted ParseNotAttempted | ParseResultFailure ParseFailure deriving stock (Show, Generic) + deriving anyclass (PrettyForTrace) + +getParseResultDecl :: ParseResult -> Either ParseResult (C.Decl Parse) +getParseResultDecl = \case + ParseResultSuccess ParseSuccess{..} -> Right psDecl + other -> Left other -getDecl :: ParseResult -> Either ParseResult (C.Decl Parse) -getDecl = \case - ParseResultSuccess ParseSuccess{..} -> Right psDecl - other -> Left other +getParseResultLoc :: ParseResult -> SingleLoc +getParseResultLoc = \case + ParseResultSuccess ParseSuccess{psDecl} -> psDecl.declInfo.declLoc + ParseResultNotAttempted (ParseNotAttempted m) -> m.loc + ParseResultFailure (ParseFailure m) -> m.loc -getQualPrelimDeclId :: ParseResult -> QualPrelimDeclId -getQualPrelimDeclId = \case - ParseResultSuccess ParseSuccess{..} -> psQualPrelimDeclId - ParseResultNotAttempted (ParseNotAttempted x) -> x.declId - ParseResultFailure (ParseFailure x) -> x.declId +getParseResultDeclId :: ParseResult -> QualPrelimDeclId +getParseResultDeclId = \case + ParseResultSuccess ParseSuccess{..} -> psQualPrelimDeclId + ParseResultNotAttempted (ParseNotAttempted x) -> x.declId + ParseResultFailure (ParseFailure x) -> x.declId parseSucceed :: C.Decl Parse -> ParseResult parseSucceed = parseSucceedWith [] @@ -311,7 +338,7 @@ data AttachedParseMsg a = AttachedParseMsg { instance PrettyForTrace a => PrettyForTrace (AttachedParseMsg a) where prettyForTrace (AttachedParseMsg i l _ x) = - PP.hang (prettyForTrace (C.Located l i) >< ":") 2 (prettyForTrace x) + PP.hang (prettyForTrace (C.Located l i) >< ":") 2 $ prettyForTrace x instance IsTrace Level a => IsTrace Level (AttachedParseMsg a) where getDefaultLogLevel = getDefaultLogLevel . msg diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs index 40c2e7565..9f7a88ed4 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs @@ -18,7 +18,8 @@ import Clang.Paths import HsBindgen.BindingSpec (MergedBindingSpecs, PrescriptiveBindingSpec) import HsBindgen.BindingSpec qualified as BindingSpec import HsBindgen.Config.ClangArgs qualified as ClangArgs -import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex (..)) +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) +import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph @@ -80,32 +81,14 @@ resolveBindingSpecs -> MState -> C.TranslationUnit ResolveBindingSpecs reassemble decls' useDeclGraph MState{..} = - let index :: DeclIndex - index = unitAnn.declIndex - - omitted :: Map C.QualPrelimDeclId (C.QualName, SourcePath) - omitted = stateOmitTypes - - external :: Set C.QualPrelimDeclId - external = Map.keysSet stateExtTypes - - omittedIds, externalIds, handledIds :: Set C.QualPrelimDeclId - omittedIds = Map.keysSet omitted + let externalIds :: Set C.QualPrelimDeclId externalIds = Map.keysSet stateExtTypes - handledIds = omittedIds `Set.union` externalIds index' :: DeclIndex - index' = DeclIndex { - succeeded = Map.withoutKeys index.succeeded handledIds - , notAttempted = Map.withoutKeys index.notAttempted handledIds - , failed = Map.withoutKeys index.failed handledIds - -- TODO https://github.com/well-typed/hs-bindgen/issues/1280: We do - -- not support external binding specifications for macros yet, but - -- if we do, we need to handle those here. - , failedMacros = index.failedMacros - , omitted - , external - } + index' = + DeclIndex.registerExternalDeclarations externalIds $ + DeclIndex.registerOmittedDeclarations stateOmitTypes $ + unitAnn.declIndex unitAnn' :: DeclMeta unitAnn' = @@ -481,10 +464,9 @@ instance Resolve C.Type where insertTrace (ResolveBindingSpecsExtType ctx cQualName) return ty Nothing -> do - -- Check for external binding of type that we omitted or failed to - -- parse. - case lookupMissing cQualPrelimDeclId envDeclIndex of - [] -> return (mk qualDeclIdName) + -- Check for external binding of type that is unusable. + case DeclIndex.lookupUnusableLoc cQualPrelimDeclId envDeclIndex of + [] -> return (mk qualDeclIdName) locs -> do let declPaths = foldMap @@ -545,11 +527,3 @@ resolveExtBinding cQualName cQualPrelimDeclId declPaths = do return Nothing Nothing -> return Nothing - --- For a given declaration ID, look up the source locations of "not attempted" --- or "failed" parses. -lookupMissing :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc] -lookupMissing qualPrelimDeclId index = catMaybes $ [ - loc . unParseNotAttempted <$> Map.lookup qualPrelimDeclId index.notAttempted - , loc . unParseFailure <$> Map.lookup qualPrelimDeclId index.failed - ] diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs index 53130953c..98c9e4783 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs @@ -3,6 +3,7 @@ module HsBindgen.Frontend.Pass.Select ( ) where import Data.List (sortBy) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Ord (comparing) import Data.Set ((\\)) @@ -12,8 +13,8 @@ import Clang.HighLevel.Types import Clang.Paths import HsBindgen.Errors (panicPure) -import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex (..), Match, - selectDeclIndex) +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex, Entry (..), Match, + Unusable (..), Usable (..)) import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) @@ -24,6 +25,7 @@ import HsBindgen.Frontend.AST.Coerce (CoercePass (coercePass)) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleMacros.Error import HsBindgen.Frontend.Pass.Parse.IsPass @@ -42,32 +44,26 @@ type DeclId = C.QualPrelimDeclId -- Declaration itself. type Decl = C.Decl Select --- | We have to treat with two notions of availability here: +-- | We have to treat with two notions of usability here: -- --- 1. A declaration can be available because it is in the list of declarations +-- 1. A declaration can be usable because it is in the list of declarations -- attached to the translation unit. -- -- 2. A declaration is available if the declaration itself and all of its -- transitive dependencies are available. -- --- @TransitiveAvailability@ deals with the second type. -data TransitiveAvailability = - TransitivelyAvailable +-- @TransitiveSelectability@ deals with the second type. +-- +-- (We avoid the term available, because it is overloaded with Clang's +-- CXAvailabilityKind). +data TransitiveSelectability = + TransitivelySelectable -- | For each transitive dependency, we try to give the root cause of -- unavailability. -- -- We should use a "non-empty" map here. - | TransitivelyUnavailable (Map DeclId UnavailabilityReason) - deriving stock (Show, Eq, Ord) - -instance Semigroup TransitiveAvailability where - TransitivelyAvailable <> x = x - x <> TransitivelyAvailable = x - TransitivelyUnavailable x <> TransitivelyUnavailable y = - TransitivelyUnavailable $ Map.unionWith min x y - -instance Monoid TransitiveAvailability where - mempty = TransitivelyAvailable + | TransitivelyUnselectable (Map DeclId Unselectable) + deriving stock (Show) {------------------------------------------------------------------------------- Select @@ -88,7 +84,7 @@ selectDecls let -- Directly match the select predicate on the 'DeclIndex', obtaining -- information about succeeded _and failed_ selection roots. selectedIndex :: DeclIndex - selectedIndex = selectDeclIndex match index + selectedIndex = DeclIndex.selectDeclIndex match index -- Identifiers of selection roots. Some of them may be unavailable -- (i.e., not in the 'succeeded' map, and hence, not in the list of @@ -116,41 +112,52 @@ selectDecls DisableProgramSlicing -> (rootIds , Set.empty) EnableProgramSlicing -> (rootAndTransIds, strictTransIds) - getTransitiveAvailability :: DeclId -> TransitiveAvailability - getTransitiveAvailability x = mconcat [ - availabilityFromSet notAttemptedTransDeps UnavailableParseNotAttempted - , availabilityFromSet failedTransDeps UnavailableParseFailed - , availabilityFromSet failedMacrosTransDeps UnavailableHandleMacrosFailed - , availabilityFromSet nonselectedTransDeps UnavailableNotSelected - ] + getTransitiveSelectability :: DeclId -> TransitiveSelectability + getTransitiveSelectability x + | Map.null unusabilityReasons = TransitivelySelectable + | otherwise = TransitivelyUnselectable unusabilityReasons where - -- We only check the transitive availability of declarations in the - -- list of declarations attached to the translation unit. That is, - -- there is no need to process strict transitive dependencies only - -- (i.e., to remove 'x' from 'transDeps'). transDeps :: Set DeclId - transDeps = UseDeclGraph.getTransitiveDeps useDeclGraph [x] - - notAttemptedTransDeps, failedTransDeps :: Set DeclId - failedMacrosTransDeps, nonselectedTransDeps :: Set DeclId - notAttemptedTransDeps = Set.intersection transDeps notAttempted - failedTransDeps = Set.intersection transDeps failed - failedMacrosTransDeps = Set.intersection transDeps failedMacros - nonselectedTransDeps = transDeps \\ selectedIds - - availabilityFromSet :: - Set DeclId - -> UnavailabilityReason - -> TransitiveAvailability - availabilityFromSet xs r = - if Set.null xs then - TransitivelyAvailable - else - TransitivelyUnavailable $ Map.fromSet (const r) xs + transDeps = UseDeclGraph.getStrictTransitiveDeps useDeclGraph [x] + + unusables :: Map DeclId Unselectable + unusables = + UnselectableBecauseUnusable <$> DeclIndex.getUnusables index transDeps + + nonselected :: Map DeclId Unselectable + nonselected = + Map.fromSet (const TransitiveDependencyNotSelected) $ + transDeps \\ selectedIds + + unusabilityReasons :: Map DeclId Unselectable + unusabilityReasons = + Map.unionWith + getMostNaturalUnselectable + unusables + nonselected + + -- Get the reason that is most useful to the user about why a + -- declaration is unselectable. + getMostNaturalUnselectable :: + Unselectable -> Unselectable -> Unselectable + getMostNaturalUnselectable l r = case (l,r) of + (TransitiveDependencyNotSelected, UnselectableBecauseUnusable u ) -> + case u of + UnusableParseNotAttempted _ -> r + _otherReason -> l + (UnselectableBecauseUnusable u , TransitiveDependencyNotSelected) -> + case u of + UnusableParseNotAttempted _ -> l + _otherReason -> r + (_, _) -> l selectDecl :: Decl -> (Maybe Decl, [Msg Select]) selectDecl = - selectDeclWith getTransitiveAvailability rootIds additionalSelectedTransIds + selectDeclWith + getTransitiveSelectability + index + rootIds + additionalSelectedTransIds availableDecls :: [Decl] availableDecls = map coercePass unitDecls @@ -181,11 +188,6 @@ selectDecls , sortSelectMsgs unitIncludeGraph msgs ) where - notAttempted, failed, failedMacros :: Set DeclId - notAttempted = Map.keysSet index.notAttempted - failed = Map.keysSet index.failed - failedMacros = Map.keysSet index.failedMacros - index :: DeclIndex index = unitAnn.declIndex @@ -198,6 +200,7 @@ selectDecls -- We compare the use sites of anonymous declarations with the original -- @declId@, so we can detect cycles involving anonymous declarations in -- the use-decl graph. We believe these cycles can not exist. + go :: DeclId -> C.QualPrelimDeclId -> SingleLoc -> C.Availability -> Bool go origDeclId declId loc availability = case declId of C.QualPrelimDeclIdNamed name kind -> let -- We have parsed some declarations that are required for @@ -258,7 +261,8 @@ selectDecls -------------------------------------------------------------------------------} selectDeclWith :: - (DeclId -> TransitiveAvailability) + (DeclId -> TransitiveSelectability) + -> DeclIndex -- | Selection roots. -> Set DeclId -- | Additionally selected transitive dependencies (non-empty when program @@ -266,23 +270,28 @@ selectDeclWith :: -> Set DeclId -> Decl -> (Maybe Decl, [Msg Select]) -selectDeclWith getTransitiveAvailability rootIds additionalSelectedTransIds decl = +selectDeclWith + getTransitiveSelectability + declIndex + rootIds + additionalSelectedTransIds + decl = case ( isSelectedRoot , isAdditionalSelectedTransDep - , transitiveAvailability ) of + , transitiveSelectability ) of -- Declaration is a selection root. - (True, False, TransitivelyAvailable) -> + (True, False, TransitivelySelectable) -> (Just decl, getSelMsgs SelectionRoot) - (True, False, TransitivelyUnavailable rs) -> + (True, False, TransitivelyUnselectable rs) -> (Nothing, getUnavailMsgs SelectionRoot rs) -- Declaration is an additionally selected transitive dependency. - (False, True, TransitivelyAvailable) -> + (False, True, TransitivelySelectable) -> (Just decl, getSelMsgs TransitiveDependency) - (False, True, TransitivelyUnavailable rs) -> + (False, True, TransitivelyUnselectable rs) -> (Nothing, getUnavailMsgs TransitiveDependency rs) -- Declaration is not selected. (False, False, _) -> - (Nothing, [SelectStatusInfo NotSelected decl]) + (Nothing, [SelectStatusInfo decl NotSelected]) -- Declaration is a selection root and a transitive dependency. This -- should be impossible and we consider it a bug. (True, True, _) -> @@ -296,17 +305,18 @@ selectDeclWith getTransitiveAvailability rootIds additionalSelectedTransIds decl -- These are also always strict transitive dependencies. isAdditionalSelectedTransDep = Set.member declId additionalSelectedTransIds - transitiveAvailability = getTransitiveAvailability declId + transitiveSelectability = getTransitiveSelectability declId getSelMsgs :: SelectReason -> [Msg Select] getSelMsgs selectReason = let selectDepr = [ SelectDeprecated decl | isDeprecated decl.declInfo ] - in SelectStatusInfo (Selected selectReason) decl : selectDepr + in SelectStatusInfo decl (Selected selectReason) : selectDepr - getUnavailMsgs :: SelectReason -> Map DeclId UnavailabilityReason -> [Msg Select] + getUnavailMsgs :: SelectReason -> Map DeclId Unselectable -> [Msg Select] getUnavailMsgs selectReason unavailReason = - [ TransitiveDependencyOfDeclarationUnavailable selectReason r decl - | r <- Map.toList unavailReason ] + [ TransitiveDependencyOfDeclarationUnselectable + decl selectReason i r (DeclIndex.lookupLoc i declIndex) + | (i, r) <- Map.toList unavailReason ] isDeprecated :: C.DeclInfo Select -> Bool isDeprecated info = case C.declAvailability info of @@ -318,18 +328,19 @@ selectDeclWith getTransitiveAvailability rootIds additionalSelectedTransIds decl -------------------------------------------------------------------------------} getDelayedMsgs :: DeclIndex -> [Msg Select] -getDelayedMsgs DeclIndex{..} = concat [ - getMsgss (map SelectParseSuccess . psAttachedMsgs) succeeded - , getMsgs SelectParseNotAttempted notAttempted - , getMsgs SelectParseFailure failed - , getMsgs SelectMacroFailure failedMacros - ] +getDelayedMsgs = concatMap (getSelectMsg . snd) . DeclIndex.toList where - getMsgs :: (a -> b) -> Map k a -> [b] - getMsgs f = map f . Map.elems - - getMsgss :: (a -> [b]) -> Map k a -> [b] - getMsgss f = concatMap f . Map.elems + getSelectMsg :: DeclIndex.Entry -> [SelectMsg] + getSelectMsg = \case + UsableE e -> case e of + UsableSuccess s -> map SelectParseSuccess $ psAttachedMsgs s + UsableExternal -> [] + UnusableE e -> case e of + UnusableParseNotAttempted xs -> map SelectParseNotAttempted $ NonEmpty.toList xs + UnusableParseFailure x -> [SelectParseFailure x] + UnusableConflict x -> [SelectConflict x] + UnusableFailedMacro x -> [SelectMacroFailure x] + UnusableOmitted{} -> [] {------------------------------------------------------------------------------- Sort messages @@ -357,14 +368,15 @@ compareSingleLocs xs x y = getSingleLoc :: Msg Select -> Maybe SingleLoc getSingleLoc = \case - SelectStatusInfo _ d -> fromD d - TransitiveDependencyOfDeclarationUnavailable _ _ d -> fromD d - SelectDeprecated d -> fromD d - SelectParseSuccess m -> fromM m - SelectParseNotAttempted (ParseNotAttempted m) -> fromM m - SelectParseFailure (ParseFailure m) -> fromM m - SelectMacroFailure (HandleMacrosParseMsg m) -> fromM m - SelectNoDeclarationsMatched -> Nothing + SelectStatusInfo d _ -> fromD d + TransitiveDependencyOfDeclarationUnselectable d _ _ _ _ -> fromD d + SelectDeprecated d -> fromD d + SelectParseSuccess m -> fromM m + SelectParseNotAttempted (ParseNotAttempted m) -> fromM m + SelectParseFailure (ParseFailure m) -> fromM m + SelectConflict c -> Just $ getMinimumLoc c + SelectMacroFailure (FailedMacro m) -> fromM m + SelectNoDeclarationsMatched -> Nothing where fromD = Just . C.declLoc . C.declInfo fromM = Just . loc diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs index 8489fa029..aff4277fe 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs @@ -5,23 +5,27 @@ module HsBindgen.Frontend.Pass.Select.IsPass ( , SelectConfig(..) -- * Trace messages , SelectReason(..) - , UnavailabilityReason(..) + , Unselectable(..) , SelectStatus(..) , SelectMsg(..) ) where import Data.Default (Default (def)) -import Text.SimplePrettyPrint (CtxDoc, (><)) +import Text.SimplePrettyPrint (CtxDoc, (<+>), (><)) import Text.SimplePrettyPrint qualified as PP +import Clang.HighLevel.Types + import HsBindgen.BindingSpec qualified as BindingSpec +import HsBindgen.Frontend.Analysis.DeclIndex (Unusable (..)) import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal (CheckedMacro, ValidPass) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass -import HsBindgen.Frontend.Pass.HandleMacros.Error (HandleMacrosParseMsg) +import HsBindgen.Frontend.Pass.HandleMacros.Error (FailedMacro) import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Frontend.Predicate @@ -97,41 +101,33 @@ data SelectStatus = | Selected SelectReason deriving stock (Show) --- | The order is important, the most "natural" cause of unavailability comes --- first. --- --- For example, if something fails to parse, but was not selected, we should say --- that it was not selected, rather than it failed to parse (why would we parse --- it, if it was not selected). -data UnavailabilityReason = - UnavailableParseNotAttempted - | UnavailableNotSelected - | UnavailableParseFailed - | UnavailableHandleMacrosFailed - deriving stock (Show, Eq, Ord) - -instance PrettyForTrace UnavailabilityReason where +data Unselectable = + -- | A declaration can not be selected because it or one of its dependencies + -- is unusable. + UnselectableBecauseUnusable Unusable + -- | A declaration can not be selected because one of its dependencies has + -- not been selected. + | TransitiveDependencyNotSelected + deriving stock (Show) + +instance PrettyForTrace Unselectable where prettyForTrace r = case r of - UnavailableParseNotAttempted -> - "parse of transitive dependency not attempted: (!) adjust parse predicate" - UnavailableParseFailed -> - "parse of transitive dependency failed" - UnavailableHandleMacrosFailed -> - "macro parsing or type-checking of transitive dependency failed" - UnavailableNotSelected -> - "transitive dependency not selected" + UnselectableBecauseUnusable x -> prettyForTrace x + TransitiveDependencyNotSelected -> "transitive dependency not selected" -- | Select trace messages data SelectMsg = -- | Information about selection status; issued for all available --declarations. - SelectStatusInfo SelectStatus (C.Decl Select) + SelectStatusInfo (C.Decl Select) SelectStatus -- | The user has selected a declaration that is available but at least one -- of its transitive dependencies is _unavailable_. - | TransitiveDependencyOfDeclarationUnavailable - SelectReason - (C.QualPrelimDeclId, UnavailabilityReason) + | TransitiveDependencyOfDeclarationUnselectable (C.Decl Select) + SelectReason + C.QualPrelimDeclId + Unselectable + [SingleLoc] -- | The user has selected a deprecated declaration. Maybe they want to -- de-select deprecated declaration? | SelectDeprecated (C.Decl Select) @@ -143,27 +139,33 @@ data SelectMsg = -- | Delayed parse message for declarations the user wants to select -- directly, but we have failed to parse. | SelectParseFailure ParseFailure + -- | Delayed construct translation unit message for conflicting declarations + -- the user wants to select directly. + | SelectConflict ConflictingDeclarations -- | Delayed handle macros message for macros the user wants to select - -- | directly, but we have failed to parse. - | SelectMacroFailure HandleMacrosParseMsg + -- directly, but we have failed to parse. + | SelectMacroFailure FailedMacro -- | Inform the user that no declarations matched the select predicate. | SelectNoDeclarationsMatched deriving stock (Show) instance PrettyForTrace SelectMsg where prettyForTrace = \case - SelectStatusInfo NotSelected x -> - prettyForTrace x >< "not selected" - SelectStatusInfo (Selected r) x -> + SelectStatusInfo x NotSelected -> + prettyForTrace x >< " not selected" + SelectStatusInfo x (Selected r) -> prettyForTrace x >< " selected (" >< prettyForTrace r >< ")" - TransitiveDependencyOfDeclarationUnavailable s (i, u) x -> PP.hcat [ + TransitiveDependencyOfDeclarationUnselectable x s i r ml -> PP.hcat [ prettyForTrace x , " selected (" , prettyForTrace s , ") but depends on " - , prettyForTrace i + , case ml of + [] -> prettyForTrace i >< " (no source location available)" + [l] -> prettyForTrace (C.Located l i) + ls -> prettyForTrace i <+> PP.hlist '(' ')' (map PP.showToCtxDoc ls) , ", which is unavailable: " - , prettyForTrace u + , prettyForTrace r ] SelectDeprecated x -> PP.hang "Selected a deprecated declaration: " 2 $ PP.vcat [ @@ -171,42 +173,39 @@ instance PrettyForTrace SelectMsg where , "You may want to de-select it" ] SelectParseSuccess x -> PP.hang "During parse:" 2 (prettyForTrace x) - SelectParseNotAttempted x -> hangReason "parse not attempted" [ + SelectParseNotAttempted x -> hangWith $ PP.vcat [ prettyForTrace x , "Consider changing the parse predicate" ] - SelectParseFailure x -> hangReason "parse failure" [ - prettyForTrace x - ] - SelectMacroFailure x -> hangReason "macro parse failure" [ - prettyForTrace x - ] + SelectParseFailure x -> hangWith $ prettyForTrace x + SelectConflict x -> hangWith $ prettyForTrace x + SelectMacroFailure x -> hangWith $ prettyForTrace x SelectNoDeclarationsMatched -> "No declarations matched the select predicate" where - hangReason :: CtxDoc -> [CtxDoc] -> CtxDoc - hangReason x xs = - let header = "Could not select declaration (" >< x >< "):" - in PP.hang header 2 $ PP.vcat xs + hangWith :: CtxDoc -> CtxDoc + hangWith x = PP.hang "Could not select declaration:" 2 x instance IsTrace Level SelectMsg where getDefaultLogLevel = \case SelectStatusInfo{} -> Info - TransitiveDependencyOfDeclarationUnavailable{} -> Warning + TransitiveDependencyOfDeclarationUnselectable{} -> Warning SelectDeprecated{} -> Notice SelectParseSuccess x -> getDefaultLogLevel x SelectParseNotAttempted{} -> Warning SelectParseFailure x -> getDefaultLogLevel x + SelectConflict{} -> Warning SelectMacroFailure x -> getDefaultLogLevel x SelectNoDeclarationsMatched -> Warning getSource = const HsBindgen getTraceId = \case SelectStatusInfo{} -> "select" - TransitiveDependencyOfDeclarationUnavailable{} -> "select" + TransitiveDependencyOfDeclarationUnselectable{} -> "select" SelectDeprecated{} -> "select" SelectParseSuccess x -> "select-" <> getTraceId x SelectParseNotAttempted{} -> "select-parse" SelectParseFailure x -> "select-" <> getTraceId x + SelectConflict{} -> "select" SelectMacroFailure x -> "select-" <> getTraceId x SelectNoDeclarationsMatched -> "select" diff --git a/hs-bindgen/src-internal/HsBindgen/TH/Internal.hs b/hs-bindgen/src-internal/HsBindgen/TH/Internal.hs index 23de58959..b96252fdc 100644 --- a/hs-bindgen/src-internal/HsBindgen/TH/Internal.hs +++ b/hs-bindgen/src-internal/HsBindgen/TH/Internal.hs @@ -46,10 +46,6 @@ import HsBindgen.Util.Tracer -- 'IncludeDir' data constructor 'Pkg'). type Config = Config_ IncludeDir --- TODO_PR: We use this now also for binding specifications; so, technically --- speaking this is not an include directory anymore, but a file path possibly --- relative to the package root. - -- | C include directory added to the C include search path data IncludeDir = Dir FilePath diff --git a/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs b/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs index 9b0e4e5fc..ecb188953 100644 --- a/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs +++ b/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs @@ -7,7 +7,6 @@ module HsBindgen.TraceMsg ( , BindingSpecMsg(..) , BootMsg(..) , ClangMsg(..) - , DeclIndexError(..) , Diagnostic(..) , FrontendMsg(..) , HandleMacrosReparseMsg(..) @@ -22,7 +21,6 @@ module HsBindgen.TraceMsg ( , ResolveBindingSpecsMsg(..) , ResolveHeaderMsg(..) , SelectMsg(..) - , ConstructTranslationUnitMsg(..) , CExpr.DSL.MacroTcError(..) -- * Log level customization , CustomLogLevelSetting (..) @@ -39,8 +37,6 @@ import HsBindgen.Boot import HsBindgen.Clang (ClangMsg (..)) import HsBindgen.Clang.BuiltinIncDir (BuiltinIncDirMsg (..)) import HsBindgen.Frontend (FrontendMsg (..)) -import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndexError (..)) -import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass (ConstructTranslationUnitMsg (..)) import HsBindgen.Frontend.Pass.HandleMacros.IsPass (HandleMacrosReparseMsg (..)) import HsBindgen.Frontend.Pass.HandleTypedefs.IsPass (HandleTypedefsMsg (..)) import HsBindgen.Frontend.Pass.MangleNames.IsPass (MangleNamesMsg (..)) diff --git a/hs-bindgen/test/common/Test/Common/HsBindgen/TracePredicate.hs b/hs-bindgen/test/common/Test/Common/HsBindgen/TracePredicate.hs index 21946370d..85d3192b0 100644 --- a/hs-bindgen/test/common/Test/Common/HsBindgen/TracePredicate.hs +++ b/hs-bindgen/test/common/Test/Common/HsBindgen/TracePredicate.hs @@ -162,13 +162,13 @@ instance (IsTrace l a, Show a) => Show (TraceExpectationException a) where then [] else "Unexpected traces:" : map reportTrace unexpectedTraces - ++ [""] + ++ ["\n"] ) ++ ( if null expectedTracesWithWrongCounts then [] else "Expected traces with wrong counts:" : expectedTracesWithWrongCounts - ++ [""] + ++ ["\n"] ) diff --git a/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs b/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs index 63ebd16c3..626632f5f 100644 --- a/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs +++ b/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs @@ -23,8 +23,10 @@ import Clang.Version import HsBindgen.BindingSpec qualified as BindingSpec import HsBindgen.Config.ClangArgs import HsBindgen.Config.Internal +import HsBindgen.Frontend.Analysis.DeclIndex (Unusable (..)) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.Conflict import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Pass.Select.IsPass import HsBindgen.Frontend.Predicate @@ -159,9 +161,11 @@ test_attributes_visibility_attributes = (AttachedParseMsg i _ _ ParseNonPublicVisibility))) -> Just $ expectFromQualPrelimDeclId i TraceFrontend (FrontendSelect (SelectParseFailure - (ParseFailure (AttachedParseMsg i _ _ (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))))) -> + (ParseFailure (AttachedParseMsg i _ _ + (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))))) -> Just $ expectFromQualPrelimDeclId i - TraceFrontend (FrontendClang (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-extern-initializer"})) -> + TraceFrontend (FrontendClang + (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-extern-initializer"})) -> Just Tolerated _otherwise -> Nothing @@ -260,6 +264,29 @@ test_documentation_data_kind_pragma = test_edge_cases_adios :: TestCase test_edge_cases_adios = defaultTest "edge-cases/adios" +test_edge_cases_duplicate :: TestCase +test_edge_cases_duplicate = (defaultTest "edge-cases/duplicate") { + testOnFrontendConfig = \cfg -> cfg{ + frontendParsePredicate = BTrue + , frontendSelectPredicate = BOr + (BIf (SelectDecl (DeclNameMatches "function"))) + (BIf (SelectDecl (DeclNameMatches "duplicate"))) + } + , testTracePredicate = customTracePredicate [ + "duplicate-conflict" + , "duplicate-transitive-fail" + ] $ \case + TraceFrontend (FrontendSelect (SelectConflict _)) -> + Just $ Expected "duplicate-conflict" + TraceFrontend (FrontendSelect + (TransitiveDependencyOfDeclarationUnselectable _ _ _ + (UnselectableBecauseUnusable (UnusableConflict _)) _)) -> + Just $ Expected "duplicate-transitive-fail" + _otherwise -> + Nothing + + } + test_edge_cases_distilled_lib_1 :: TestCase test_edge_cases_distilled_lib_1 = defaultTest "edge-cases/distilled_lib_1" @@ -452,8 +479,8 @@ test_macros_macro_redefines_global = , C.QualPrelimDeclIdNamed "stderr" C.NameKindOrdinary ] in testTraceCustom "macros/macro_redefines_global" declsWithMsgs $ \case - TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> - Just $ Expected x + TraceFrontend (FrontendSelect (SelectConflict x)) -> + Just $ Expected $ getDeclId x _otherwise -> Nothing @@ -468,7 +495,7 @@ test_types_special_parse_failure_long_double = test_declarations_tentative_definitions :: TestCase test_declarations_tentative_definitions = - testTraceCustom "declarations/tentative_definitions" ["i1", "i2", "i3", "i3"] $ \case + testTraceCustom "declarations/tentative_definitions" ["i1", "i2", "i3"] $ \case TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i _ _ ParsePotentialDuplicateSymbol{}))) -> Just $ expectFromQualPrelimDeclId i @@ -561,7 +588,7 @@ test_types_failing_implicit_fields_union = test_declarations_failing_declaration_unselected_b :: TestCase test_declarations_failing_declaration_unselected_b = failingTestCustom "declarations/failing/declaration_unselected_b" ["select" :: String] $ \case - (TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnavailable _ (_, UnavailableNotSelected) _))) -> + (TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnselectable _ _ _ TransitiveDependencyNotSelected _))) -> Just $ Expected "select" _otherwise -> Nothing @@ -569,7 +596,7 @@ test_declarations_failing_declaration_unselected_b = test_declarations_failing_redeclaration_different :: TestCase test_declarations_failing_redeclaration_different = failingTestSimple "declarations/failing/redeclaration_different" $ \case - TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {}))) -> + TraceFrontend (FrontendSelect (SelectConflict _)) -> Just (Expected ()) TraceFrontend (FrontendClang (ClangDiagnostic x)) -> if "macro redefined" `Text.isInfixOf` diagnosticSpelling x @@ -778,9 +805,9 @@ test_functions_fun_attributes = Just $ expectFromQualPrelimDeclId i TraceFrontend (FrontendSelect (SelectDeprecated x)) -> Just $ expectFromDeclSelect x - TraceFrontend (FrontendSelect (SelectParseNotAttempted (ParseNotAttempted - (AttachedParseMsg n _ _ DeclarationUnavailable)))) -> - Just $ expectFromQualPrelimDeclId n + TraceFrontend (FrontendSelect (SelectParseNotAttempted + (ParseNotAttempted (AttachedParseMsg n _ _ DeclarationUnavailable)))) -> + Just $ expectFromQualPrelimDeclId n _otherwise -> Nothing } @@ -871,9 +898,9 @@ test_program_analysis_program_slicing_simple = "selected foo" , "selected uint32_t" ] $ \case - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect (SelectStatusInfo decl (Selected SelectionRoot))) -> expectSelected decl.declInfo $ Set.singleton "foo" - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected TransitiveDependency) decl)) -> + TraceFrontend (FrontendSelect (SelectStatusInfo decl (Selected TransitiveDependency))) -> expectSelected decl.declInfo $ Set.singleton "uint32_t" _otherwise -> Nothing @@ -889,9 +916,12 @@ test_program_analysis_selection_fail = ] $ \case TraceFrontend (FrontendSelect (SelectParseFailure _)) -> Just $ Expected "Fail" - TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnavailable _ (_, UnavailableParseFailed) decl)) -> + TraceFrontend (FrontendSelect + (TransitiveDependencyOfDeclarationUnselectable decl _ _ + (UnselectableBecauseUnusable (UnusableParseFailure _)) _)) -> Just $ expectFromDeclSelect decl - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect + (SelectStatusInfo decl (Selected SelectionRoot))) -> Just $ expectFromDeclSelect decl _otherwise -> Nothing @@ -908,9 +938,11 @@ test_program_analysis_selection_fail_variant_1 = , "DependOnFailByReference" , "OkBefore", "OkAfter" ] $ \case - TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnavailable _ (_, UnavailableNotSelected) decl)) -> + TraceFrontend (FrontendSelect + (TransitiveDependencyOfDeclarationUnselectable decl _ _ TransitiveDependencyNotSelected _)) -> Just $ expectFromDeclSelect decl - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect + (SelectStatusInfo decl (Selected SelectionRoot))) -> Just $ expectFromDeclSelect decl _otherwise -> Nothing } @@ -929,9 +961,12 @@ test_program_analysis_selection_fail_variant_2 = , "DependOnFailByReference" , "OkBefore", "OkAfter" ] $ \case - TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnavailable _ (_, UnavailableParseFailed) decl)) -> + TraceFrontend (FrontendSelect + (TransitiveDependencyOfDeclarationUnselectable decl _ _ + (UnselectableBecauseUnusable (UnusableParseFailure _)) _)) -> Just $ expectFromDeclSelect decl - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect + (SelectStatusInfo decl (Selected SelectionRoot))) -> Just $ expectFromDeclSelect decl _otherwise -> Nothing , testHasOutput = False @@ -947,7 +982,7 @@ test_program_analysis_selection_fail_variant_3 = , frontendProgramSlicing = EnableProgramSlicing } , testTracePredicate = customTracePredicate' ["OkBefore"] $ \case - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect (SelectStatusInfo decl (Selected SelectionRoot))) -> Just $ expectFromDeclSelect decl _otherwise -> Nothing } @@ -956,7 +991,8 @@ test_program_analysis_failing_selection_bad :: TestCase test_program_analysis_failing_selection_bad = (defaultFailingTest "program-analysis/failing/selection_bad"){ testTracePredicate = customTracePredicate ["size_t_select"] $ \case - (TraceFrontend (FrontendSelect (TransitiveDependencyOfDeclarationUnavailable SelectionRoot (_, UnavailableNotSelected) _))) -> + (TraceFrontend (FrontendSelect + (TransitiveDependencyOfDeclarationUnselectable _ SelectionRoot _ TransitiveDependencyNotSelected _))) -> Just $ Expected "size_t_select" _other -> Nothing } @@ -984,20 +1020,14 @@ test_program_analysis_program_slicing_selection = "selected FileOperationRecord" , "selected FileOperationStatus" , "selected read_file_chunk" - -- Macro redefines a global variable - , "QualPrelimDeclIdNamed \"stdin\" NameKindOrdinary" - , "QualPrelimDeclIdNamed \"stdout\" NameKindOrdinary" - , "QualPrelimDeclIdNamed \"stderr\" NameKindOrdinary" ] $ \case - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected SelectionRoot) decl)) -> + TraceFrontend (FrontendSelect (SelectStatusInfo decl (Selected SelectionRoot))) -> expectSelected decl.declInfo $ Set.fromList [ "FileOperationRecord" , "read_file_chunk" ] - TraceFrontend (FrontendSelect (SelectStatusInfo (Selected TransitiveDependency) decl)) -> + TraceFrontend (FrontendSelect (SelectStatusInfo decl (Selected TransitiveDependency))) -> expectSelected decl.declInfo $ Set.singleton "FileOperationStatus" - TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> - Just $ Expected (show x) _otherwise -> Nothing } @@ -1023,12 +1053,12 @@ test_declarations_select_scoping = , "ParsedAndSelected3" ] $ \case (TraceFrontend (FrontendSelect - (TransitiveDependencyOfDeclarationUnavailable _ - (_, UnavailableNotSelected) _))) -> + (TransitiveDependencyOfDeclarationUnselectable _ _ + _ TransitiveDependencyNotSelected _))) -> Just $ Expected "ParsedAndSelected2" (TraceFrontend (FrontendSelect - (TransitiveDependencyOfDeclarationUnavailable _ - (_, UnavailableParseNotAttempted) _))) -> + (TransitiveDependencyOfDeclarationUnselectable _ _ + _ (UnselectableBecauseUnusable (UnusableParseNotAttempted _)) _))) -> Just $ Expected "ParsedAndSelected3" _otherwise -> Nothing } @@ -1049,7 +1079,8 @@ test_edge_cases_failing_select_no_match :: TestCase test_edge_cases_failing_select_no_match = (defaultFailingTest "edge-cases/failing/select_no_match") { testOnFrontendConfig = \cfg -> cfg { - frontendSelectPredicate = BIf (SelectDecl (DeclNameMatches "this_pattern_will_never_match")) + frontendSelectPredicate = BIf $ + SelectDecl (DeclNameMatches "this_pattern_will_never_match") } , testTracePredicate = singleTracePredicate $ \case TraceFrontend (FrontendSelect SelectNoDeclarationsMatched) -> @@ -1096,6 +1127,7 @@ testCases = manualTestCases ++ [ , test_documentation_data_kind_pragma , test_documentation_doxygen_docs , test_edge_cases_adios + , test_edge_cases_duplicate , test_edge_cases_distilled_lib_1 , test_edge_cases_failing_select_no_match , test_edge_cases_failing_thread_local diff --git a/scripts/ci/compile-fixtures.sh b/scripts/ci/compile-fixtures.sh index d0c703bad..b4fb41361 100755 --- a/scripts/ci/compile-fixtures.sh +++ b/scripts/ci/compile-fixtures.sh @@ -31,7 +31,7 @@ KNOWN_FAILURES=( # # This number is used for sanity checks. Make sure to update this number when # new fixtures are added or old ones are removed. -KNOWN_FIXTURES_COUNT=82 +KNOWN_FIXTURES_COUNT=83 # Default options JOBS=4