Skip to content

Commit 26dadde

Browse files
dschrempfdschrempf
committed
Rework selection
1 parent b320f3b commit 26dadde

File tree

7 files changed

+328
-302
lines changed

7 files changed

+328
-302
lines changed

‎hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs‎

Lines changed: 24 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -7,17 +7,14 @@
77
-- > import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex)
88
-- > import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex
99
module HsBindgen.Frontend.Analysis.DeclIndex (
10-
DeclIndex -- opaque
11-
, getParseOmissions
12-
, getParseFailures
10+
DeclIndex(..)
1311
-- * Construction
1412
, DeclIndexError(..)
1513
, fromParseResults
1614
-- * Query
1715
, lookup
1816
, (!)
19-
, lookupDelayedParseMsgs
20-
, lookupMissing
17+
, lookupAttachedParseMsgs
2118
, getDecls
2219
) where
2320

@@ -26,8 +23,8 @@ import Prelude hiding (lookup)
2623
import Control.Monad.State
2724
import Data.Function
2825
import Data.List.NonEmpty ((<|))
29-
import Data.List.NonEmpty qualified as NonEmpty
3026
import Data.Map.Strict qualified as Map
27+
import Data.Set qualified as Set
3128
import Optics.Core (over, set, (%))
3229
import Text.SimplePrettyPrint (hcat, showToCtxDoc)
3330

@@ -47,21 +44,14 @@ import HsBindgen.Util.Tracer
4744
-- | Index of all declarations
4845
data DeclIndex = DeclIndex {
4946
succeeded :: !(Map C.QualPrelimDeclId ParseSuccess)
50-
, omitted :: !(Map C.QualPrelimDeclId (NonEmpty ParseOmission))
47+
, omitted :: !(Map C.QualPrelimDeclId (NonEmpty ParseNotAttempted))
5148
, failed :: !(Map C.QualPrelimDeclId (NonEmpty ParseFailure))
5249
}
5350
deriving stock (Show, Generic)
5451

5552
emptyIndex :: DeclIndex
5653
emptyIndex = DeclIndex Map.empty Map.empty Map.empty
5754

58-
getParseOmissions ::
59-
DeclIndex -> Map C.QualPrelimDeclId (NonEmpty ParseOmission)
60-
getParseOmissions = omitted
61-
62-
getParseFailures :: DeclIndex -> Map C.QualPrelimDeclId (NonEmpty ParseFailure)
63-
getParseFailures = failed
64-
6555
{-------------------------------------------------------------------------------
6656
Construction
6757
-------------------------------------------------------------------------------}
@@ -80,16 +70,27 @@ fromParseResults results =
8070
$ mapM_ aux results
8171
where
8272
fromPartialIndex :: PartialIndex -> (DeclIndex, [DeclIndexError])
83-
fromPartialIndex p = (p.index , Map.elems p.errors
84-
)
73+
fromPartialIndex (PartialIndex i e) =
74+
-- We assert that no key is used twice. This assertion is not strictly
75+
-- necessary, and we may want to remove it in the future.
76+
let ss = Map.keysSet i.succeeded
77+
os = Map.keysSet i.omitted
78+
fs = Map.keysSet i.failed
79+
is = Set.intersection
80+
sharedKeys = Set.unions [is ss os, is ss fs, is os fs]
81+
in if sharedKeys == Set.empty then
82+
(i, Map.elems e)
83+
else
84+
panicPure $
85+
"DeclIndex.fromParseResults: shared keys: " <> show sharedKeys
8586

8687
aux :: ParseResult -> State PartialIndex ()
8788
aux parse = modify' $ \oldIndex@PartialIndex{..} ->
8889
if Map.member qualPrelimDeclId errors then
8990
-- Ignore further definitions of the same ID after an error
9091
oldIndex
9192
else case parse of
92-
ParseSucceeded x ->
93+
ParseResultSuccess x ->
9394
let (succeeded', mErr) = flip runState Nothing $
9495
Map.alterF
9596
(insert x)
@@ -101,12 +102,12 @@ fromParseResults results =
101102
Nothing -> errors
102103
Just err -> Map.insert qualPrelimDeclId err errors
103104
}
104-
ParseOmitted x ->
105+
ParseResultNotAttempted x ->
105106
over
106107
( #index % #omitted )
107108
( alter qualPrelimDeclId x )
108109
oldIndex
109-
ParseFailed x ->
110+
ParseResultFailure x ->
110111
over
111112
( #index % #failed )
112113
( alter qualPrelimDeclId x )
@@ -136,7 +137,7 @@ fromParseResults results =
136137
-- Redeclaration but with the same definition. This can happen,
137138
-- for example for opaque structs. We stick with the first but
138139
-- add the parse messages of the second.
139-
success $ over #psDelayedMsgs (++ new.psDelayedMsgs) old
140+
success $ over #psAttachedMsgs (++ new.psAttachedMsgs) old
140141

141142
| otherwise ->
142143
-- Redeclaration with a /different/ value. This is only legal
@@ -222,19 +223,9 @@ lookup qualPrelimDeclId =
222223
fromMaybe (panicPure $ "Unknown key: " ++ show qualPrelimDeclId) $
223224
lookup qualPrelimDeclId declIndex
224225

225-
lookupDelayedParseMsgs :: C.QualPrelimDeclId -> DeclIndex -> [DelayedParseMsg]
226-
lookupDelayedParseMsgs qualPrelimDeclId =
227-
maybe [] psDelayedMsgs . Map.lookup qualPrelimDeclId . succeeded
228-
229-
-- | For a given declaration ID, look up the source locations of omitted or
230-
-- failed parses.
231-
lookupMissing :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc]
232-
lookupMissing qualPrelimDeclId index =
233-
(maybe [] (map poSingleLoc . NonEmpty.toList) $
234-
Map.lookup qualPrelimDeclId $ index.omitted)
235-
++
236-
(maybe [] (map pfSingleLoc . NonEmpty.toList) $
237-
Map.lookup qualPrelimDeclId $ index.failed)
226+
lookupAttachedParseMsgs :: C.QualPrelimDeclId -> DeclIndex -> [AttachedParseMsg]
227+
lookupAttachedParseMsgs qualPrelimDeclId =
228+
maybe [] psAttachedMsgs . Map.lookup qualPrelimDeclId . succeeded
238229

239230
getDecls :: DeclIndex -> [C.Decl Parse]
240231
getDecls = map psDecl . Map.elems . succeeded

‎hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs‎

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -201,7 +201,7 @@ macroDefinition info = \curr -> do
201201
, declAnn = NoAnn
202202
}
203203
decl <- mkDecl <$> getUnparsedMacro unit curr
204-
foldContinueWith [ParseSucceeded $ ParseSuccess decl []]
204+
foldContinueWith [ParseResultSuccess $ ParseSuccess decl []]
205205

206206
structDecl :: C.DeclInfo Parse -> Parser
207207
structDecl info = \curr -> do
@@ -260,7 +260,7 @@ structDecl info = \curr -> do
260260
, declKind = C.DeclOpaque (C.NameKindTagged C.TagKindStruct)
261261
, declAnn = NoAnn
262262
}
263-
in foldContinueWith [ParseSucceeded $ ParseSuccess decl []]
263+
in foldContinueWith [ParseResultSuccess $ ParseSuccess decl []]
264264
DefinitionElsewhere _ ->
265265
foldContinue
266266

@@ -505,11 +505,10 @@ functionDecl info = \curr -> do
505505
ParsePotentialDuplicateSymbol (visibility == PublicVisibility)
506506
| isDefn && linkage == ExternalLinkage
507507
]
508-
funDecl = mkDecl purity
509-
in map parseSucceed otherDecls ++
510-
[ ParseSucceeded $ ParseSuccess funDecl $
511-
nonPublicVisibility ++ potentialDuplicate
512-
]
508+
funDeclResult =
509+
parseSucceedWith
510+
(nonPublicVisibility ++ potentialDuplicate) $ mkDecl purity
511+
in map parseSucceed otherDecls ++ [funDeclResult]
513512
where
514513
guardTypeFunction ::
515514
CXCursor
@@ -631,11 +630,11 @@ varDecl info = \curr -> do
631630

632631
in case cls of
633632
VarGlobal ->
634-
singleton $ ParseSucceeded $
635-
ParseSuccess (mkDecl $ C.DeclGlobal typ) msgs
633+
singleton $
634+
parseSucceedWith msgs (mkDecl $ C.DeclGlobal typ)
636635
VarConst ->
637-
singleton $ ParseSucceeded $
638-
ParseSuccess (mkDecl $ C.DeclGlobal typ) msgs
636+
singleton $
637+
parseSucceedWith msgs (mkDecl $ C.DeclGlobal typ)
639638
VarThreadLocal ->
640639
singleton $
641640
parseFailWith' $ ParseUnsupportedTLS :| msgs

‎hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs‎

Lines changed: 35 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -8,13 +8,14 @@ module HsBindgen.Frontend.Pass.Parse.IsPass (
88
, getUnparsedMacro
99
-- * Trace messages
1010
, ParseSuccess(..)
11-
, ParseOmissionReason(..)
12-
, ParseOmission(..)
11+
, ParseNotAttemptedReason(..)
12+
, ParseNotAttempted(..)
1313
, ParseFailure(..)
1414
, ParseResult(..)
1515
, getDecl
1616
, getQualPrelimDeclId
1717
, parseSucceed
18+
, parseSucceedWith
1819
, parseDoNotAttempt
1920
, parseFail
2021
, parseFailWith
@@ -71,13 +72,13 @@ instance IsPass Parse where
7172
-------------------------------------------------------------------------------}
7273

7374
data ParseSuccess = ParseSuccess {
74-
psDecl :: C.Decl Parse
75-
, psDelayedMsgs :: [DelayedParseMsg]
75+
psDecl :: C.Decl Parse
76+
, psAttachedMsgs :: [AttachedParseMsg]
7677
}
7778
deriving stock (Show, Generic)
7879

7980
-- | Why did we not attempt to parse a declaration?
80-
data ParseOmissionReason =
81+
data ParseNotAttemptedReason =
8182
-- | We do not parse builtin declarations.
8283
OmittedBuiltin
8384

@@ -102,7 +103,7 @@ data ParseOmissionReason =
102103
| ParsePredicateNotMatched
103104
deriving stock (Show, Eq, Ord)
104105

105-
instance PrettyForTrace ParseOmissionReason where
106+
instance PrettyForTrace ParseNotAttemptedReason where
106107
prettyForTrace = \case
107108
OmittedBuiltin -> "Builtin declaration"
108109
DeclarationUnavailable -> "Declaration is 'unavailable' on this platform"
@@ -112,11 +113,11 @@ instance PrettyForTrace ParseOmissionReason where
112113
--
113114
-- We need this information when selecting declarations: Does the user want to
114115
-- select declarations we did not attempt to parse?
115-
data ParseOmission = ParseOmission {
116-
poQualPrelimDeclId :: QualPrelimDeclId
117-
, poSingleLoc :: SingleLoc
118-
, poAvailability :: C.Availability
119-
, poParseOmissionReason :: ParseOmissionReason
116+
data ParseNotAttempted = ParseNotAttempted {
117+
poQualPrelimDeclId :: QualPrelimDeclId
118+
, poSingleLoc :: SingleLoc
119+
, poAvailability :: C.Availability
120+
, poParseNotAttemptedReason :: ParseNotAttemptedReason
120121
}
121122
deriving stock (Show, Generic)
122123

@@ -129,38 +130,43 @@ data ParseFailure = ParseFailure {
129130
pfQualPrelimDeclId :: QualPrelimDeclId
130131
, pfSingleLoc :: SingleLoc
131132
, pfAvailability :: C.Availability
132-
, pfDelayedParseMsgs :: NonEmpty DelayedParseMsg
133+
, pfDelayedParseMsgs :: NonEmpty AttachedParseMsg
133134
}
134135
deriving stock (Show, Generic)
135136

136137
data ParseResult =
137-
ParseSucceeded ParseSuccess
138-
| ParseOmitted ParseOmission
139-
| ParseFailed ParseFailure
138+
ParseResultSuccess ParseSuccess
139+
| ParseResultNotAttempted ParseNotAttempted
140+
| ParseResultFailure ParseFailure
140141
deriving stock (Show, Generic)
141142

142143
getDecl :: ParseResult -> Either ParseResult (C.Decl Parse)
143144
getDecl = \case
144-
ParseSucceeded ParseSuccess{..} -> Right psDecl
145-
other -> Left other
145+
ParseResultSuccess ParseSuccess{..} -> Right psDecl
146+
other -> Left other
146147

147148
getQualPrelimDeclId :: ParseResult -> QualPrelimDeclId
148149
getQualPrelimDeclId = \case
149-
ParseSucceeded ParseSuccess{..} -> C.declQualPrelimDeclId psDecl
150-
ParseOmitted ParseOmission{..} -> poQualPrelimDeclId
151-
ParseFailed ParseFailure{..} -> pfQualPrelimDeclId
150+
ParseResultSuccess ParseSuccess{..} -> C.declQualPrelimDeclId psDecl
151+
ParseResultNotAttempted ParseNotAttempted{..} -> poQualPrelimDeclId
152+
ParseResultFailure ParseFailure{..} -> pfQualPrelimDeclId
152153

153154
parseSucceed :: C.Decl Parse -> ParseResult
154-
parseSucceed decl = ParseSucceeded $ ParseSuccess decl []
155+
parseSucceed = parseSucceedWith []
156+
157+
parseSucceedWith :: [DelayedParseMsg] -> C.Decl Parse -> ParseResult
158+
parseSucceedWith msgs decl =
159+
ParseResultSuccess $ ParseSuccess decl $
160+
map (AttachedParseMsg decl.declInfo) msgs
155161

156162
parseDoNotAttempt ::
157163
HasCallStack
158164
=> C.DeclInfo Parse
159165
-> C.NameKind
160-
-> ParseOmissionReason
166+
-> ParseNotAttemptedReason
161167
-> ParseResult
162168
parseDoNotAttempt C.DeclInfo{..} kind reason =
163-
ParseOmitted $ ParseOmission
169+
ParseResultNotAttempted $ ParseNotAttempted
164170
(C.qualPrelimDeclId declId kind)
165171
declLoc
166172
declAvailability
@@ -176,12 +182,12 @@ parseFailWith ::
176182
-> C.NameKind
177183
-> NonEmpty DelayedParseMsg
178184
-> ParseResult
179-
parseFailWith C.DeclInfo{..} kind msgs =
180-
ParseFailed $ ParseFailure
185+
parseFailWith info@C.DeclInfo{..} kind msgs =
186+
ParseResultFailure $ ParseFailure
181187
(C.qualPrelimDeclId declId kind)
182188
declLoc
183189
declAvailability
184-
msgs
190+
(NonEmpty.map (AttachedParseMsg info) msgs)
185191

186192
{-------------------------------------------------------------------------------
187193
Typedefs
@@ -298,15 +304,15 @@ instance IsTrace Level UnattachedParseMsg where
298304
getTraceId = const "parse-unattached"
299305

300306
data AttachedParseMsg = AttachedParseMsg (C.DeclInfo Parse) DelayedParseMsg
301-
deriving stock (Generic)
307+
deriving stock (Show, Generic)
302308

303309
instance PrettyForTrace AttachedParseMsg where
304310
prettyForTrace (AttachedParseMsg i x) = prettyForTrace i <+> prettyForTrace x
305311

306312
instance IsTrace Level AttachedParseMsg where
307313
getDefaultLogLevel (AttachedParseMsg _ x) = getDefaultLogLevel x
308-
getSource (AttachedParseMsg _ x) = getSource x
309-
getTraceId (AttachedParseMsg _ x) = getTraceId x
314+
getSource (AttachedParseMsg _ x) = getSource x
315+
getTraceId (AttachedParseMsg _ x) = getTraceId x
310316

311317
-- | Delayed parse messages
312318
--

‎hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs‎

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module HsBindgen.Frontend.Pass.ResolveBindingSpecs (
77
import Control.Monad ((<=<))
88
import Control.Monad.RWS (MonadReader, MonadState, RWS)
99
import Control.Monad.RWS qualified as RWS
10+
import Data.List.NonEmpty qualified as NonEmpty
1011
import Data.Map.Strict qualified as Map
1112
import Data.Set qualified as Set
1213
import Optics.Core ((&), (.~))
@@ -28,7 +29,7 @@ import HsBindgen.Frontend.Naming qualified as C
2829
import HsBindgen.Frontend.Pass
2930
import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass
3031
import HsBindgen.Frontend.Pass.NameAnon.IsPass
31-
import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..))
32+
import HsBindgen.Frontend.Pass.Parse.IsPass
3233
import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass
3334
import HsBindgen.Imports
3435
import HsBindgen.Language.Haskell qualified as Hs
@@ -449,7 +450,7 @@ instance Resolve C.Type where
449450
Nothing -> do
450451
-- Check for external binding of type that we omitted or failed to
451452
-- parse.
452-
case DeclIndex.lookupMissing qualPrelimDeclId envDeclIndex of
453+
case lookupMissing qualPrelimDeclId envDeclIndex of
453454
[] -> return (Set.empty, mk qualDeclIdName)
454455
locs -> do
455456
let declPaths =
@@ -512,3 +513,13 @@ getHsExtRef cQualName cTypeSpec = do
512513
maybe (Left (ResolveBindingSpecsExtHsRefNoIdentifier cQualName)) Right $
513514
BindingSpec.cTypeSpecIdentifier cTypeSpec
514515
return Hs.ExtRef{extRefModule, extRefIdentifier}
516+
517+
-- For a given declaration ID, look up the source locations of "not attempted"
518+
-- or "failed" parses.
519+
lookupMissing :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc]
520+
lookupMissing qualPrelimDeclId index =
521+
(maybe [] (map poSingleLoc . NonEmpty.toList) $
522+
Map.lookup qualPrelimDeclId $ index.omitted)
523+
++
524+
(maybe [] (map pfSingleLoc . NonEmpty.toList) $
525+
Map.lookup qualPrelimDeclId $ index.failed)

0 commit comments

Comments
 (0)