Skip to content

Commit 7b5e1d7

Browse files
dschrempfdschrempf
committed
[WIP] rework selection
1 parent 954ebc3 commit 7b5e1d7

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: 37 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,21 +103,23 @@ 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"
109110
ParsePredicateNotMatched -> "Parse predicate did not match"
110111

112+
-- TODO_PR: Rename to NotAttempted.
113+
111114
-- | Declarations we did not attempt to parse
112115
--
113116
-- We need this information when selecting declarations: Does the user want to
114117
-- 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
118+
data ParseNotAttempted = ParseNotAttempted {
119+
poQualPrelimDeclId :: QualPrelimDeclId
120+
, poSingleLoc :: SingleLoc
121+
, poAvailability :: C.Availability
122+
, poParseNotAttemptedReason :: ParseNotAttemptedReason
120123
}
121124
deriving stock (Show, Generic)
122125

@@ -129,38 +132,43 @@ data ParseFailure = ParseFailure {
129132
pfQualPrelimDeclId :: QualPrelimDeclId
130133
, pfSingleLoc :: SingleLoc
131134
, pfAvailability :: C.Availability
132-
, pfDelayedParseMsgs :: NonEmpty DelayedParseMsg
135+
, pfDelayedParseMsgs :: NonEmpty AttachedParseMsg
133136
}
134137
deriving stock (Show, Generic)
135138

136139
data ParseResult =
137-
ParseSucceeded ParseSuccess
138-
| ParseOmitted ParseOmission
139-
| ParseFailed ParseFailure
140+
ParseResultSuccess ParseSuccess
141+
| ParseResultNotAttempted ParseNotAttempted
142+
| ParseResultFailure ParseFailure
140143
deriving stock (Show, Generic)
141144

142145
getDecl :: ParseResult -> Either ParseResult (C.Decl Parse)
143146
getDecl = \case
144-
ParseSucceeded ParseSuccess{..} -> Right psDecl
145-
other -> Left other
147+
ParseResultSuccess ParseSuccess{..} -> Right psDecl
148+
other -> Left other
146149

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

153156
parseSucceed :: C.Decl Parse -> ParseResult
154-
parseSucceed decl = ParseSucceeded $ ParseSuccess decl []
157+
parseSucceed = parseSucceedWith []
158+
159+
parseSucceedWith :: [DelayedParseMsg] -> C.Decl Parse -> ParseResult
160+
parseSucceedWith msgs decl =
161+
ParseResultSuccess $ ParseSuccess decl $
162+
map (AttachedParseMsg decl.declInfo) msgs
155163

156164
parseDoNotAttempt ::
157165
HasCallStack
158166
=> C.DeclInfo Parse
159167
-> C.NameKind
160-
-> ParseOmissionReason
168+
-> ParseNotAttemptedReason
161169
-> ParseResult
162170
parseDoNotAttempt C.DeclInfo{..} kind reason =
163-
ParseOmitted $ ParseOmission
171+
ParseResultNotAttempted $ ParseNotAttempted
164172
(C.qualPrelimDeclId declId kind)
165173
declLoc
166174
declAvailability
@@ -176,12 +184,12 @@ parseFailWith ::
176184
-> C.NameKind
177185
-> NonEmpty DelayedParseMsg
178186
-> ParseResult
179-
parseFailWith C.DeclInfo{..} kind msgs =
180-
ParseFailed $ ParseFailure
187+
parseFailWith info@C.DeclInfo{..} kind msgs =
188+
ParseResultFailure $ ParseFailure
181189
(C.qualPrelimDeclId declId kind)
182190
declLoc
183191
declAvailability
184-
msgs
192+
(NonEmpty.map (AttachedParseMsg info) msgs)
185193

186194
{-------------------------------------------------------------------------------
187195
Typedefs
@@ -298,15 +306,15 @@ instance IsTrace Level UnattachedParseMsg where
298306
getTraceId = const "parse-unattached"
299307

300308
data AttachedParseMsg = AttachedParseMsg (C.DeclInfo Parse) DelayedParseMsg
301-
deriving stock (Generic)
309+
deriving stock (Show, Generic)
302310

303311
instance PrettyForTrace AttachedParseMsg where
304312
prettyForTrace (AttachedParseMsg i x) = prettyForTrace i <+> prettyForTrace x
305313

306314
instance IsTrace Level AttachedParseMsg where
307315
getDefaultLogLevel (AttachedParseMsg _ x) = getDefaultLogLevel x
308-
getSource (AttachedParseMsg _ x) = getSource x
309-
getTraceId (AttachedParseMsg _ x) = getTraceId x
316+
getSource (AttachedParseMsg _ x) = getSource x
317+
getTraceId (AttachedParseMsg _ x) = getTraceId x
310318

311319
-- | Delayed parse messages
312320
--

‎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)