Make current type name optional in getInstances

Author: jorisdral

hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation.hs

@@ -241,7 +241,7 @@ structDecs opts haddockConfig info struct spec fields = do
         -- #1286.
       where
         insts :: Set Hs.TypeClass
-        insts = Hs.getInstances instanceMap structName candidateInsts $
+        insts = Hs.getInstances instanceMap (Just structName) candidateInsts $
           Hs.fieldType <$> Vec.toList structFields
 
         hsStruct :: Hs.Struct n
@@ -503,7 +503,7 @@ unionDecs haddockConfig info union spec = do
         getAccessorDecls :: C.UnionField -> [Hs.Decl]
         getAccessorDecls C.UnionField{..} =
           let hsType = Type.topLevel unionFieldType
-              fInsts = Hs.getInstances instanceMap newtypeName insts [hsType]
+              fInsts = Hs.getInstances instanceMap (Just newtypeName) insts [hsType]
               getterName = "get_" <> C.nameHs (C.fieldName unionFieldInfo)
               setterName = "set_" <> C.nameHs (C.fieldName unionFieldInfo)
               commentRefName name = Just $ HsDoc.paragraph [
@@ -822,7 +822,7 @@ typedefDecs opts haddockConfig info typedef spec = do
         insts =
           Hs.getInstances
             instanceMap
-            newtypeName
+            (Just newtypeName)
             candidateInsts
             [Hs.fieldType newtypeField]
 
@@ -979,7 +979,7 @@ macroDecsTypedef opts haddockConfig info macroType spec = do
         fieldType = Type.topLevel ty
 
         insts :: Set Hs.TypeClass
-        insts = Hs.getInstances instanceMap newtypeName candidateInsts [fieldType]
+        insts = Hs.getInstances instanceMap (Just newtypeName) candidateInsts [fieldType]
 
         hsNewtype :: Hs.Newtype
         hsNewtype = Hs.Newtype {
@@ -1530,7 +1530,7 @@ constGetter ty instsMap info pureStubName = concat [
           -- superclass constraints. See issue #993.
           Hs.Storable
             `elem`
-              Hs.getInstances instsMap "unused" (Set.singleton Hs.Storable) [ty]
+              Hs.getInstances instsMap Nothing (Set.singleton Hs.Storable) [ty]
         ]
   where
     -- *** Getter ***

hs-bindgen/src-internal/HsBindgen/Backend/Hs/Translation/Instances.hs

@@ -18,10 +18,10 @@ type InstanceMap = Map (Name NsTypeConstr) (Set TypeClass)
 
 getInstances ::
      HasCallStack
-  => InstanceMap       -- ^ Current state
-  -> Name NsTypeConstr -- ^ Name of current type
-  -> Set TypeClass     -- ^ Candidate instances
-  -> [HsType]          -- ^ Dependencies
+  => InstanceMap               -- ^ Current state
+  -> Maybe (Name NsTypeConstr) -- ^ Name of current type (optionaL)
+  -> Set TypeClass             -- ^ Candidate instances
+  -> [HsType]                  -- ^ Dependencies
   -> Set TypeClass
 getInstances instanceMap name = aux
   where
@@ -32,7 +32,7 @@ getInstances instanceMap name = aux
       | otherwise = case hsType of
           HsPrimType primType -> aux (acc /\ hsPrimTypeInsts primType) hsTypes
           HsTypRef name'
-            | name' == name -> aux acc hsTypes
+            | Just name' == name -> aux acc hsTypes
             | otherwise -> case Map.lookup name' instanceMap of
                 Just instances -> aux (acc /\ instances) hsTypes
                 Nothing -> panicPure $ "type not found: " ++ show name'