From f082e73c0718a0c5572350323f4941552ba49a4c Mon Sep 17 00:00:00 2001 From: Dominik Schrempf Date: Tue, 18 Nov 2025 18:10:09 +0100 Subject: [PATCH] Sort select messages before emitting them --- .../Frontend/Analysis/IncludeGraph.hs | 7 +- .../Frontend/Analysis/UseDeclGraph.hs | 9 +-- .../HsBindgen/Frontend/Pass/Select.hs | 69 ++++++++++++++++++- 3 files changed, 75 insertions(+), 10 deletions(-) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/IncludeGraph.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/IncludeGraph.hs index 5b8c88924..25f6b357f 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/IncludeGraph.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/IncludeGraph.hs @@ -15,6 +15,7 @@ module HsBindgen.Frontend.Analysis.IncludeGraph ( -- * Query , reaches , toSortedList + , toOrderMap , getIncludes -- * Debugging , Predicate @@ -24,12 +25,13 @@ module HsBindgen.Frontend.Analysis.IncludeGraph ( import Data.DynGraph.Labelled (DynGraph) import Data.DynGraph.Labelled qualified as DynGraph import Data.List qualified as List -import Data.Set (Set) +import Data.Map.Strict qualified as Map import Clang.Paths import HsBindgen.Frontend.RootHeader (HashIncludeArg (getHashIncludeArg)) import HsBindgen.Frontend.RootHeader qualified as RootHeader +import HsBindgen.Imports {------------------------------------------------------------------------------- Definition @@ -91,6 +93,9 @@ toSortedList :: IncludeGraph -> [SourcePath] toSortedList (IncludeGraph graph) = List.delete RootHeader.name $ DynGraph.topSort graph +toOrderMap :: IncludeGraph -> Map SourcePath Int +toOrderMap graph = Map.fromList (zip (toSortedList graph) [0..]) + getIncludes :: IncludeGraph -> SourcePath diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs index b60cbcc59..9db25985f 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/UseDeclGraph.hs @@ -63,13 +63,10 @@ toDynGraph = unwrap fromDecls :: IncludeGraph -> [C.Decl Parse] -> UseDeclGraph fromDecls includeGraph decls = - fromSortedDecls $ List.sortOn (annSortKey sourceMap) decls + fromSortedDecls $ List.sortOn (annSortKey orderMap) decls where - sourcePaths :: [SourcePath] - sourcePaths = IncludeGraph.toSortedList includeGraph - - sourceMap :: Map SourcePath Int - sourceMap = Map.fromList $ zip sourcePaths [0..] + orderMap :: Map SourcePath Int + orderMap = IncludeGraph.toOrderMap includeGraph fromSortedDecls :: [C.Decl Parse] -> UseDeclGraph fromSortedDecls decls = Wrap $ diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs index 96448b0a3..53130953c 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs @@ -2,17 +2,22 @@ module HsBindgen.Frontend.Pass.Select ( selectDecls ) where +import Data.List (sortBy) import Data.Map.Strict qualified as Map +import Data.Ord (comparing) import Data.Set ((\\)) import Data.Set qualified as Set import Clang.HighLevel.Types +import Clang.Paths import HsBindgen.Errors (panicPure) import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex (..), Match, selectDeclIndex) 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 import HsBindgen.Frontend.Analysis.UseDeclGraph (UseDeclGraph) import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph import HsBindgen.Frontend.AST.Coerce (CoercePass (coercePass)) @@ -20,6 +25,7 @@ import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass +import HsBindgen.Frontend.Pass.HandleMacros.Error import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Frontend.Pass.Select.IsPass @@ -164,11 +170,15 @@ selectDecls , C.unitAnn = unitAnn } - in ( unitSelect - , selectMsgs + msgs :: [Msg Select] + msgs = + selectMsgs + ++ getDelayedMsgs selectedIndex -- If there were no predicate matches we issue a warning to the user. ++ [ SelectNoDeclarationsMatched | Set.null rootIds ] - ++ getDelayedMsgs selectedIndex + + in ( unitSelect + , sortSelectMsgs unitIncludeGraph msgs ) where notAttempted, failed, failedMacros :: Set DeclId @@ -320,3 +330,56 @@ getDelayedMsgs DeclIndex{..} = concat [ getMsgss :: (a -> [b]) -> Map k a -> [b] getMsgss f = concatMap f . Map.elems + +{------------------------------------------------------------------------------- + Sort messages +-------------------------------------------------------------------------------} + +compareByOrder :: Map SourcePath Int -> SourcePath -> SourcePath -> Ordering +compareByOrder xs x y = + let ix = lookupUnsafe x + iy = lookupUnsafe y + in compare ix iy + where + lookupUnsafe z = case Map.lookup z xs of + Nothing -> panicPure $ "unknown source path: " <> show z + Just v -> v + +compareSingleLocs :: Map SourcePath Int -> SingleLoc -> SingleLoc -> Ordering +compareSingleLocs xs x y = + case compareByOrder xs (singleLocPath x) (singleLocPath y) of + LT -> LT + EQ -> comparing getLineCol x y + GT -> GT + where + getLineCol :: SingleLoc -> (Int, Int) + getLineCol z = (singleLocLine z, singleLocColumn z) + +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 + where + fromD = Just . C.declLoc . C.declInfo + fromM = Just . loc + +compareMsgs :: Map SourcePath Int -> Msg Select -> Msg Select -> Ordering +compareMsgs orderMap x y = + case (getSingleLoc x, getSingleLoc y) of + (Just lx, Just ly) -> compareSingleLocs orderMap lx ly + -- Sort messages not attached to a declaration to the back. + (Nothing, _ ) -> GT + (_ , Nothing) -> LT + +sortSelectMsgs :: IncludeGraph -> [Msg Select] -> [Msg Select] +sortSelectMsgs includeGraph = sortBy (compareMsgs orderMap) + where + -- Compute the order map once. + orderMap :: Map SourcePath Int + orderMap = IncludeGraph.toOrderMap includeGraph