Review comments

Author: dschrempf

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

@@ -4,6 +4,8 @@ module HsBindgen.Frontend
   , FrontendMsg(..)
   ) where
 
+import Optics.Core (_2, view)
+
 import Clang.Enum.Bitfield
 import Clang.LowLevel.Core
 import Clang.Paths
@@ -143,21 +145,27 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do
       afterNameAnon <- nameAnonPass
       extlSpec <- bootExternalBindingSpec
       presSpec <- bootPrescriptiveBindingSpec
-      let (afterResolveBindingSpecs, omitTypes, msgsResolveBindingSpecs) =
+      let (   afterResolveBindingSpecs
+            , omitTypes
+            , declsWithExternalBindingSpecs
+            , msgsResolveBindingSpecs
+            ) =
             resolveBindingSpecs
               extlSpec
               presSpec
               afterNameAnon
       forM_ msgsResolveBindingSpecs $ traceWith tracer . FrontendResolveBindingSpecs
-      pure (afterResolveBindingSpecs, omitTypes)
+      pure (afterResolveBindingSpecs, omitTypes, declsWithExternalBindingSpecs)
 
     selectPass <- cache "select" $ do
       (_, _, isMainHeader, isInMainHeaderDir, _) <- parsePass
-      (afterResolveBindingSpecs, _)           <- resolveBindingSpecsPass
+      (afterResolveBindingSpecs, _, declsWithExternalBindingSpecs) <-
+        resolveBindingSpecsPass
       let (afterSelect, msgsSelect) =
             selectDecls
               isMainHeader
               isInMainHeaderDir
+              declsWithExternalBindingSpecs
               selectConfig
               afterResolveBindingSpecs
       forM_ msgsSelect $ traceWith tracer . FrontendSelect
@@ -204,7 +212,7 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do
 
     -- Omitted types
     frontendOmitTypes <- cache "frontendOmitTypes" $
-      snd <$> resolveBindingSpecsPass
+      view _2 <$> resolveBindingSpecsPass
 
     -- Declarations.
     frontendCDecls <- cache "frontendDecls" $

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

@@ -8,25 +8,27 @@
 -- > import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex
 module HsBindgen.Frontend.Analysis.DeclIndex (
     DeclIndex -- opaque
-  , getNotAttempted
-  , getFailed
+  , getParseOmissions
+  , getParseFailures
     -- * Construction
   , DeclIndexError(..)
   , fromParseResults
     -- * Query
   , lookup
   , (!)
   , lookupDelayedParseMsgs
-  , lookupNotAttempted
+  , lookupMissing
   , getDecls
   ) where
 
 import Prelude hiding (lookup)
 
 import Control.Monad.State
 import Data.Function
+import Data.List.NonEmpty ((<|))
+import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map.Strict qualified as Map
-import Optics.Core (_1, over, set, view, (%))
+import Optics.Core (over, set, (%))
 import Text.SimplePrettyPrint (hcat, showToCtxDoc)
 
 import Clang.HighLevel.Types
@@ -44,27 +46,21 @@ import HsBindgen.Util.Tracer
 
 -- | Index of all declarations
 data DeclIndex = DeclIndex {
-      succeeded ::
-        !(Map C.QualPrelimDeclId
-            (C.Decl Parse, [DelayedParseMsg]))
-    , notAttempted ::
-        !(Map C.QualPrelimDeclId
-            (SingleLoc, C.Availability, ParseOmissionReason))
-    , failed  ::
-        !(Map C.QualPrelimDeclId
-            (SingleLoc, C.Availability, NonEmpty DelayedParseMsg))
+      succeeded    :: !(Map C.QualPrelimDeclId ParseSuccess)
+    , omitted      :: !(Map C.QualPrelimDeclId (NonEmpty ParseOmission))
+    , failed       :: !(Map C.QualPrelimDeclId (NonEmpty ParseFailure))
     }
   deriving stock (Show, Generic)
 
 emptyIndex :: DeclIndex
 emptyIndex = DeclIndex Map.empty Map.empty Map.empty
 
-getNotAttempted ::
-  DeclIndex -> Map C.QualPrelimDeclId (SingleLoc, C.Availability, ParseOmissionReason)
-getNotAttempted = notAttempted
+getParseOmissions ::
+  DeclIndex -> Map C.QualPrelimDeclId (NonEmpty ParseOmission)
+getParseOmissions = omitted
 
-getFailed :: DeclIndex -> Map C.QualPrelimDeclId (SingleLoc, C.Availability, NonEmpty DelayedParseMsg)
-getFailed = failed
+getParseFailures :: DeclIndex -> Map C.QualPrelimDeclId (NonEmpty ParseFailure)
+getParseFailures = failed
 
 {-------------------------------------------------------------------------------
   Construction
@@ -93,10 +89,10 @@ fromParseResults results =
           -- Ignore further definitions of the same ID after an error
           oldIndex
         else case parse of
-          ParseSucceeded{..} ->
+          ParseSucceeded x ->
               let (succeeded', mErr) = flip runState Nothing $
                      Map.alterF
-                       (insert psDecl psDelayedMsgs)
+                       (insert x)
                        qualPrelimDeclId
                        index.succeeded
               in PartialIndex{
@@ -105,48 +101,42 @@ fromParseResults results =
                     Nothing  -> errors
                     Just err -> Map.insert qualPrelimDeclId err errors
                 }
-          -- TODO_PR: On failures, we simply insert the value into the
-          -- respective index maps, preferring existing, previously inserted
-          -- key-value pairs.
-          ParseNotAttempted{..} ->
-            let val = (pnaSingleLoc, pnaAvailability, pnaParseOmissionReason)
-            in  over
-                  ( #index % #notAttempted )
-                  ( insertPreferOld qualPrelimDeclId val )
-                  oldIndex
-          ParseFailed{..} ->
-            let val = (pfSingleLoc, pfAvailability, pfDelayedParseMsgs)
-            in  over
-                  ( #index % #failed )
-                  ( insertPreferOld qualPrelimDeclId val )
-                  oldIndex
+          ParseOmitted x ->
+            over
+              ( #index % #omitted )
+              ( alter qualPrelimDeclId x )
+              oldIndex
+          ParseFailed x ->
+            over
+              ( #index % #failed )
+              ( alter qualPrelimDeclId x )
+              oldIndex
       where
         qualPrelimDeclId :: C.QualPrelimDeclId
         qualPrelimDeclId = getQualPrelimDeclId parse
 
-    insertPreferOld :: Ord k => k -> a -> Map k a -> Map k a
-    insertPreferOld key new =
+    alter :: Ord k => k -> a -> Map k (NonEmpty a) -> Map k (NonEmpty a)
+    alter key x =
       Map.alter (\case
-        Nothing  -> Just new
-        Just old -> Just old) key
+        Nothing -> Just $ x :| []
+        Just xs -> Just $ x <| xs) key
 
     insert ::
-         C.Decl Parse
-      -> [DelayedParseMsg]
-      -> Maybe (C.Decl Parse, [DelayedParseMsg])
-      -> State (Maybe DeclIndexError) (Maybe (C.Decl Parse, [DelayedParseMsg]))
-    insert new newMsgs mOld = state $ \_ ->
+         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, newMsgs)
+              success new
 
-          Just (old, oldMsgs)
-            | sameDefinition (C.declKind new) (C.declKind old) ->
+          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 (old, oldMsgs ++ newMsgs)
+                success $ over #psDelayedMsgs (++ new.psDelayedMsgs) old
 
             | otherwise ->
                 -- Redeclaration with a /different/ value. This is only legal
@@ -165,9 +155,9 @@ fromParseResults results =
                 --
                 -- See issue #1155.
                 failure $ Redeclaration{
-                    redeclarationId  = C.declQualPrelimDeclId new
-                  , redeclarationOld = C.declLoc $ C.declInfo old
-                  , redeclarationNew = C.declLoc $ C.declInfo new
+                    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
@@ -225,8 +215,7 @@ instance IsTrace Level DeclIndexError where
 
 lookup :: C.QualPrelimDeclId -> DeclIndex -> Maybe (C.Decl Parse)
 lookup qualPrelimDeclId =
-  fmap fst . Map.lookup qualPrelimDeclId . succeeded
-
+  fmap psDecl . Map.lookup qualPrelimDeclId . succeeded
 
 (!) :: HasCallStack => DeclIndex -> C.QualPrelimDeclId -> C.Decl Parse
 (!) declIndex qualPrelimDeclId =
@@ -235,11 +224,17 @@ lookup qualPrelimDeclId =
 
 lookupDelayedParseMsgs :: C.QualPrelimDeclId -> DeclIndex -> [DelayedParseMsg]
 lookupDelayedParseMsgs qualPrelimDeclId =
-  maybe [] snd . Map.lookup qualPrelimDeclId . succeeded
-
-lookupNotAttempted :: C.QualPrelimDeclId -> DeclIndex -> Maybe SingleLoc
-lookupNotAttempted qualPrelimDeclId =
-  fmap (view _1) . Map.lookup qualPrelimDeclId . notAttempted
+  maybe [] psDelayedMsgs . Map.lookup qualPrelimDeclId . succeeded
+
+-- | For a given declaration ID, look up the source locations of omitted or
+-- failed parses.
+lookupMissing :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc]
+lookupMissing qualPrelimDeclId index =
+  (maybe [] (map poSingleLoc . NonEmpty.toList) $
+    Map.lookup qualPrelimDeclId $ index.omitted)
+  ++
+  (maybe [] (map pfSingleLoc . NonEmpty.toList) $
+    Map.lookup qualPrelimDeclId $ index.failed)
 
 getDecls :: DeclIndex -> [C.Decl Parse]
-getDecls = map fst . Map.elems . succeeded
+getDecls = map psDecl . Map.elems . succeeded

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

@@ -201,7 +201,7 @@ macroDefinition info = \curr -> do
           , declAnn  = NoAnn
           }
     decl <- mkDecl <$> getUnparsedMacro unit curr
-    foldContinueWith [ParseSucceeded decl []]
+    foldContinueWith [ParseSucceeded $ ParseSuccess decl []]
 
 structDecl :: C.DeclInfo Parse -> Parser
 structDecl info = \curr -> do
@@ -260,7 +260,7 @@ structDecl info = \curr -> do
               , declKind = C.DeclOpaque (C.NameKindTagged C.TagKindStruct)
               , declAnn  = NoAnn
               }
-        in  foldContinueWith [ParseSucceeded decl []]
+        in  foldContinueWith [ParseSucceeded $ ParseSuccess decl []]
       DefinitionElsewhere _ ->
         foldContinue
 
@@ -507,7 +507,7 @@ functionDecl info = \curr -> do
                       ]
                     funDecl = mkDecl purity
                 in  map parseSucceed otherDecls ++
-                      [ ParseSucceeded funDecl $
+                      [ ParseSucceeded $ ParseSuccess funDecl $
                           nonPublicVisibility ++ potentialDuplicate
                       ]
   where
@@ -631,11 +631,11 @@ varDecl info = \curr -> do
 
             in  case cls of
               VarGlobal ->
-                singleton $
-                  ParseSucceeded (mkDecl $ C.DeclGlobal typ) msgs
+                singleton $ ParseSucceeded $
+                  ParseSuccess (mkDecl $ C.DeclGlobal typ) msgs
               VarConst ->
-                singleton $
-                  ParseSucceeded (mkDecl $ C.DeclGlobal typ) msgs
+                singleton $ ParseSucceeded $
+                  ParseSuccess (mkDecl $ C.DeclGlobal typ) msgs
               VarThreadLocal ->
                 singleton $
                   parseFailWith' $ ParseUnsupportedTLS :| msgs