Skip to content

Commit ca65500

Browse files
dschrempfdschrempf
committed
Simplifications, HasCallStack constraints, error messages, imports
1 parent 930e873 commit ca65500

File tree

7 files changed

+62
-44
lines changed

7 files changed

+62
-44
lines changed

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

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,6 @@ import HsBindgen.Frontend.AST.Internal hiding (Type)
2323
import HsBindgen.Frontend.Pass hiding (Config)
2424
import HsBindgen.Frontend.Pass.ConstructTranslationUnit
2525
import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass
26-
import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass qualified as ConstructTranslationUnit
2726
import HsBindgen.Frontend.Pass.HandleMacros
2827
import HsBindgen.Frontend.Pass.HandleMacros.IsPass
2928
import HsBindgen.Frontend.Pass.HandleTypedefs
@@ -197,11 +196,11 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do
197196
(_, _, _, _, getMainHeaders) <- parsePass
198197
pure getMainHeaders
199198
frontendIndex <- cache "frontendIndex" $
200-
ConstructTranslationUnit.declIndex . unitAnn <$> sortPass
199+
declIndex . unitAnn <$> sortPass
201200
frontendUseDeclGraph <- cache "frontendUseDeclGraph" $
202-
ConstructTranslationUnit.declUseDecl . unitAnn <$> sortPass
201+
declUseDecl . unitAnn <$> sortPass
203202
frontendDeclUseGraph <- cache "frontendDeclUseGraph" $
204-
ConstructTranslationUnit.declDeclUse . unitAnn <$> sortPass
203+
declDeclUse . unitAnn <$> sortPass
205204

206205
-- Omitted types
207206
frontendOmitTypes <- cache "frontendOmitTypes" $

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

Lines changed: 19 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -45,18 +45,22 @@ import HsBindgen.Util.Tracer
4545
-- | Index of all declarations
4646
data DeclIndex = DeclIndex {
4747
succeeded ::
48-
!(Map C.QualPrelimDeclId (C.Decl Parse, [DelayedParseMsg]))
48+
!(Map C.QualPrelimDeclId
49+
(C.Decl Parse, [DelayedParseMsg]))
4950
, notAttempted ::
50-
!(Map C.QualPrelimDeclId (SingleLoc, C.Availability, ParseOmissionReason))
51+
!(Map C.QualPrelimDeclId
52+
(SingleLoc, C.Availability, ParseOmissionReason))
5153
, failed ::
52-
!(Map C.QualPrelimDeclId (SingleLoc, C.Availability, NonEmpty DelayedParseMsg))
54+
!(Map C.QualPrelimDeclId
55+
(SingleLoc, C.Availability, NonEmpty DelayedParseMsg))
5356
}
5457
deriving stock (Show, Generic)
5558

5659
emptyIndex :: DeclIndex
5760
emptyIndex = DeclIndex Map.empty Map.empty Map.empty
5861

59-
getNotAttempted :: DeclIndex -> Map C.QualPrelimDeclId (SingleLoc, C.Availability, ParseOmissionReason)
62+
getNotAttempted ::
63+
DeclIndex -> Map C.QualPrelimDeclId (SingleLoc, C.Availability, ParseOmissionReason)
6064
getNotAttempted = notAttempted
6165

6266
getFailed :: DeclIndex -> Map C.QualPrelimDeclId (SingleLoc, C.Availability, NonEmpty DelayedParseMsg)
@@ -101,22 +105,31 @@ fromParseResults results =
101105
Nothing -> errors
102106
Just err -> Map.insert qualPrelimDeclId err errors
103107
}
108+
-- TODO_PR: On failures, we simply insert the value into the
109+
-- respective index maps, preferring existing, previously inserted
110+
-- key-value pairs.
104111
ParseNotAttempted{..} ->
105112
let val = (pnaSingleLoc, pnaAvailability, pnaParseOmissionReason)
106113
in over
107114
( #index % #notAttempted )
108-
( Map.insert qualPrelimDeclId val )
115+
( insertPreferOld qualPrelimDeclId val )
109116
oldIndex
110117
ParseFailed{..} ->
111118
let val = (pfSingleLoc, pfAvailability, pfDelayedParseMsgs)
112119
in over
113120
( #index % #failed )
114-
( Map.insert qualPrelimDeclId val )
121+
( insertPreferOld qualPrelimDeclId val )
115122
oldIndex
116123
where
117124
qualPrelimDeclId :: C.QualPrelimDeclId
118125
qualPrelimDeclId = getQualPrelimDeclId parse
119126

127+
insertPreferOld :: Ord k => k -> a -> Map k a -> Map k a
128+
insertPreferOld key new =
129+
Map.alter (\case
130+
Nothing -> Just new
131+
Just old -> Just old) key
132+
120133
insert ::
121134
C.Decl Parse
122135
-> [DelayedParseMsg]

‎hs-bindgen/src-internal/HsBindgen/Frontend/Naming.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -315,12 +315,13 @@ instance PrettyForTrace QualPrelimDeclId where
315315
PP.textToCtxDoc (tagKindPrefix kind) <+> PP.parens (prettyForTrace anonId)
316316
QualPrelimDeclIdBuiltin name -> prettyForTrace name
317317

318-
qualPrelimDeclId :: PrelimDeclId -> NameKind -> QualPrelimDeclId
318+
qualPrelimDeclId :: HasCallStack => PrelimDeclId -> NameKind -> QualPrelimDeclId
319319
qualPrelimDeclId prelimDeclId kind = case prelimDeclId of
320320
PrelimDeclIdNamed name -> QualPrelimDeclIdNamed name kind
321321
PrelimDeclIdAnon anonId -> case kind of
322322
NameKindTagged tagKind -> QualPrelimDeclIdAnon anonId tagKind
323-
NameKindOrdinary -> panicPure "qualPrelimDeclId ordinary anonymous"
323+
NameKindOrdinary -> panicPure $
324+
"qualPrelimDeclId: ordinary anonymous: " ++ show anonId
324325
PrelimDeclIdBuiltin name -> QualPrelimDeclIdBuiltin name
325326

326327
{-------------------------------------------------------------------------------

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -131,7 +131,7 @@ getReparseInfo = \curr -> do
131131
type Parser = CXCursor -> ParseDecl (Next ParseDecl [ParseResult])
132132

133133
-- | Declarations
134-
parseDecl :: Parser
134+
parseDecl :: HasCallStack => Parser
135135
parseDecl = \curr -> do
136136
info <- getDeclInfo curr
137137
let isBuiltin = case C.declId info of

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

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,11 @@ parseSucceed :: C.Decl Parse -> ParseResult
141141
parseSucceed decl = ParseSucceeded decl []
142142

143143
parseDoNotAttempt ::
144-
C.DeclInfo Parse -> C.NameKind -> ParseOmissionReason -> ParseResult
144+
HasCallStack
145+
=> C.DeclInfo Parse
146+
-> C.NameKind
147+
-> ParseOmissionReason
148+
-> ParseResult
145149
parseDoNotAttempt C.DeclInfo{..} kind reason =
146150
ParseNotAttempted
147151
(C.qualPrelimDeclId declId kind)
@@ -154,7 +158,11 @@ parseFail ::
154158
parseFail info kind msg = parseFailWith info kind (NonEmpty.singleton msg)
155159

156160
parseFailWith ::
157-
C.DeclInfo Parse -> C.NameKind -> NonEmpty DelayedParseMsg -> ParseResult
161+
HasCallStack
162+
=> C.DeclInfo Parse
163+
-> C.NameKind
164+
-> NonEmpty DelayedParseMsg
165+
-> ParseResult
158166
parseFailWith C.DeclInfo{..} kind msgs =
159167
ParseFailed
160168
(C.qualPrelimDeclId declId kind)

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

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -443,6 +443,13 @@ instance Resolve C.Type where
443443
Just ty -> return (Set.singleton qualPrelimDeclId, ty)
444444
Nothing -> do
445445
-- Check for external binding of type that we did not attempt to parse
446+
--
447+
-- TODO_PR: Here we only have a look at "not attempted" parses.
448+
-- Should we also analyze "failed" parses?
449+
--
450+
-- TODO_PR: Also, even if we replace a "not attempted" parse with
451+
-- a binding specification, we will emit an @Error@ (?) trace in
452+
-- the @Select@ pass.
446453
case DeclIndex.lookupNotAttempted qualPrelimDeclId envDeclIndex of
447454
Nothing -> return (Set.empty, mk qualDeclIdName)
448455
Just loc -> do

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

Lines changed: 19 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@ import HsBindgen.Frontend.Predicate
2727
import HsBindgen.Imports
2828
import HsBindgen.Util.Tracer
2929

30-
type MatchFun = C.QualPrelimDeclId -> SingleLoc -> C.Availability -> SelectStatus
30+
type MatchFun = C.QualPrelimDeclId -> SingleLoc -> C.Availability -> Bool
3131

3232
selectDecls ::
3333
IsMainHeader
@@ -71,11 +71,11 @@ selectDecls isMainHeader isInMainHeaderDir SelectConfig{..} unit =
7171

7272
in if Set.null unavailableTransitiveDeps
7373
then ( unitSelectWith selectedDecls
74-
, getSelectMsgs selectedRoots selectedDecls
75-
++ getExcludeMsgs transitiveDeps unmatchedDecls
76-
++ getDelayedParseMsgs selectedDecls index
74+
, getSelectMsgs selectedRoots selectedDecls
75+
++ getExcludeMsgs transitiveDeps unmatchedDecls
76+
++ getDelayedParseMsgs selectedDecls index
7777
++ getParseNotAttemptedMsgs match index
78-
++ getParseFailedMsgs match index
78+
++ getParseFailedMsgs match index
7979
)
8080
else panicPure $ errorMsgWith unavailableTransitiveDeps
8181
where
@@ -102,7 +102,7 @@ selectDecls isMainHeader isInMainHeaderDir SelectConfig{..} unit =
102102
}
103103

104104
matchDecl :: Id p ~ C.DeclId => C.Decl p -> Bool
105-
matchDecl decl = isSelected $
105+
matchDecl decl =
106106
match
107107
(C.declOrigQualPrelimDeclId decl)
108108
(C.declLoc $ C.declInfo decl)
@@ -116,21 +116,19 @@ selectDecls isMainHeader isInMainHeaderDir SelectConfig{..} unit =
116116
-- the use-decl graph. We believe these cycles can not exist.
117117
go originalDeclId declId loc availability = case declId of
118118
C.QualPrelimDeclIdNamed name kind ->
119-
if matchSelect
120-
isMainHeader
121-
isInMainHeaderDir
122-
(singleLocPath loc)
123-
(C.QualName name kind)
124-
availability
125-
selectConfigPredicate
126-
then Selected SelectionRoot
127-
else NotSelected
119+
matchSelect
120+
isMainHeader
121+
isInMainHeaderDir
122+
(singleLocPath loc)
123+
(C.QualName name kind)
124+
availability
125+
selectConfigPredicate
128126
-- Apply the select predicate to the use site.
129127
anon@(C.QualPrelimDeclIdAnon{}) -> matchAnon anon
130128
-- Never select builtins.
131-
C.QualPrelimDeclIdBuiltin _ -> NotSelected
129+
C.QualPrelimDeclIdBuiltin _ -> False
132130
where
133-
matchAnon :: C.QualPrelimDeclId -> SelectStatus
131+
matchAnon :: C.QualPrelimDeclId -> Bool
134132
matchAnon anon =
135133
case DeclUseGraph.getUseSites unit.unitAnn.declDeclUse anon of
136134
[x] ->
@@ -140,13 +138,13 @@ selectDecls isMainHeader isInMainHeaderDir SelectConfig{..} unit =
140138
-- anonymous declaration without use site: QualPrelimDeclIdAnon (AnonId "/nix/store/0zv32kh0zb4s1v4ld6mc99vmzydj9nm9-glibc-2.40-66-dev/include/stdlib.h:77:23") TagKindStruct
141139
-- panicPure $
142140
-- "anonymous declaration without use site: " ++ show anon
143-
NotSelected
141+
False
144142
xs ->
145143
panicPure $
146144
"anonymous declaration with multiple use sites: "
147145
++ show anon ++ " used by " ++ show xs
148146

149-
matchUseSite :: C.QualPrelimDeclId -> SelectStatus
147+
matchUseSite :: C.QualPrelimDeclId -> Bool
150148
matchUseSite declIdUseSite
151149
| declIdUseSite == originalDeclId =
152150
panicPure $
@@ -227,9 +225,7 @@ getParseNotAttemptedMsgs match = Map.foldlWithKey addMsg [] . DeclIndex.getNotAt
227225
-> [SelectMsg]
228226
addMsg xs qualPrelimDeclId (loc, availability, reason) =
229227
[ SelectParseNotAttempted qualPrelimDeclId loc reason
230-
| case match qualPrelimDeclId loc availability of
231-
NotSelected -> False
232-
Selected _ -> True
228+
| match qualPrelimDeclId loc availability
233229
] ++ xs
234230

235231
getParseFailedMsgs :: MatchFun -> DeclIndex -> [Msg Select]
@@ -242,12 +238,6 @@ getParseFailedMsgs match = Map.foldlWithKey addMsg [] . DeclIndex.getFailed
242238
-> [SelectMsg]
243239
addMsg xs qualPrelimDeclId (loc, availability, msgs) =
244240
[ SelectParseFailed qualPrelimDeclId loc msg
245-
| case match qualPrelimDeclId loc availability of
246-
NotSelected -> False
247-
Selected _ -> True
241+
| match qualPrelimDeclId loc availability
248242
, msg <- NonEmpty.toList msgs
249243
] ++ xs
250-
251-
isSelected :: SelectStatus -> Bool
252-
isSelected NotSelected = False
253-
isSelected (Selected _reason) = True

0 commit comments

Comments
 (0)