Merge pull request #1326 from well-typed/edsko/declid-p

Give `DeclId` a pass `p` parameter

Author: edsko

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

@@ -1,13 +1,27 @@
-module HsBindgen.Frontend.AST.Coerce (CoercePass(..)) where
+module HsBindgen.Frontend.AST.Coerce (
+    CoercePass(..)
+  , CoercePassId(..)
+  , CoercePassTypedefRef(..)
+  ) where
 
 import Prelude hiding (Enum)
 
-import Data.Bifunctor (bimap)
-
 import Clang.HighLevel.Documentation qualified as CDoc
 
 import HsBindgen.Frontend.AST.Internal
+import HsBindgen.Frontend.Naming
 import HsBindgen.Frontend.Pass
+import HsBindgen.Imports
+
+{-------------------------------------------------------------------------------
+  Type families
+-------------------------------------------------------------------------------}
+
+class CoercePassId (p :: Pass) (p' :: Pass) where
+  coercePassId :: Proxy '(p, p') -> Id p -> Id p'
+
+class CoercePassTypedefRef (p :: Pass) (p' :: Pass) where
+  coercePassTypedefRef :: Proxy '(p, p') -> TypedefRef p -> TypedefRef p'
 
 {-------------------------------------------------------------------------------
   Coercing between passes
@@ -16,6 +30,11 @@ import HsBindgen.Frontend.Pass
 class CoercePass a p p' where
   coercePass :: a p -> a p'
 
+instance CoercePass DeclId p p' where
+  coercePass = \case
+      DeclIdNamed name origin -> DeclIdNamed name origin
+      DeclIdBuiltin name      -> DeclIdBuiltin name
+
 instance (
       CoercePass Decl p p'
     , Ann "TranslationUnit" p ~ Ann "TranslationUnit" p'
@@ -27,12 +46,12 @@ instance (
       }
 
 instance (
-      Id p ~ Id p'
+      CoercePassId p p'
     ) => CoercePass CommentRef p p' where
-  coercePass (ById t) = ById t
+  coercePass (ById t) = ById (coercePassId (Proxy @'(p, p')) t)
 
 instance (
-      Id p ~ Id p'
+      CoercePassId p p'
     ) => CoercePass CDoc.Comment (CommentRef p) (CommentRef p') where
   coercePass comment = fmap coercePass comment
 
@@ -54,12 +73,14 @@ instance (
       }
 
 instance (
-      Id p ~ Id p'
+      CoercePassId p p'
     , CoercePass Comment p p'
     ) => CoercePass DeclInfo p p' where
-  coercePass info = DeclInfo{ declComment = fmap coercePass declComment
-                            , ..
-                            }
+  coercePass info = DeclInfo{
+        declId      = coercePassId (Proxy @'(p, p')) declId
+      , declComment = fmap coercePass declComment
+      , ..
+      }
     where
       DeclInfo{..} = info
 
@@ -199,24 +220,30 @@ instance (
       }
 
 instance (
-      Id p ~ Id p'
+      CoercePassId p p'
     , ArgumentName p ~ ArgumentName p'
-    , CoercePass TypedefRefWrapper p p'
+    , CoercePassTypedefRef p p'
     , ExtBinding p ~ ExtBinding p'
     ) => CoercePass Type p p' where
-  coercePass (TypePrim prim)           = TypePrim prim
-  coercePass (TypeStruct uid)          = TypeStruct uid
-  coercePass (TypeUnion uid)           = TypeUnion uid
-  coercePass (TypeEnum uid)            = TypeEnum uid
-  coercePass (TypeTypedef typedef)     = TypeTypedef $
-      unTypedefRefWrapper . coercePass @_ @p @p' . TypedefRefWrapper $ typedef
-  coercePass (TypeMacroTypedef uid)    = TypeMacroTypedef uid
-  coercePass (TypePointer typ)         = TypePointer (coercePass typ)
-  coercePass (TypeFun args res)        = TypeFun (map coercePass args) (coercePass res)
-  coercePass  TypeVoid                 = TypeVoid
-  coercePass (TypeConstArray n typ)    = TypeConstArray n (coercePass typ)
-  coercePass (TypeIncompleteArray typ) = TypeIncompleteArray (coercePass typ)
-  coercePass (TypeExtBinding ext)      = TypeExtBinding ext
-  coercePass (TypeBlock typ)           = TypeBlock (coercePass typ)
-  coercePass (TypeConst typ)           = TypeConst (coercePass typ)
-  coercePass (TypeComplex prim)        = TypeComplex prim
+  coercePass = \case
+      TypePrim prim           -> TypePrim prim
+      TypeStruct uid          -> TypeStruct (goId uid)
+      TypeUnion uid           -> TypeUnion (goId uid)
+      TypeEnum uid            -> TypeEnum (goId uid)
+      TypeTypedef typedef     -> TypeTypedef (goTypedefRef typedef)
+      TypeMacroTypedef uid    -> TypeMacroTypedef (goId uid)
+      TypePointer typ         -> TypePointer (coercePass typ)
+      TypeFun args res        -> TypeFun (map coercePass args) (coercePass res)
+      TypeVoid                -> TypeVoid
+      TypeConstArray n typ    -> TypeConstArray n (coercePass typ)
+      TypeIncompleteArray typ -> TypeIncompleteArray (coercePass typ)
+      TypeExtBinding ext      -> TypeExtBinding ext
+      TypeBlock typ           -> TypeBlock (coercePass typ)
+      TypeConst typ           -> TypeConst (coercePass typ)
+      TypeComplex prim        -> TypeComplex prim
+    where
+      goId :: Id p -> Id p'
+      goId = coercePassId (Proxy @'(p, p'))
+
+      goTypedefRef :: TypedefRef p -> TypedefRef p'
+      goTypedefRef = coercePassTypedefRef (Proxy @'(p, p'))

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

@@ -554,7 +554,7 @@ instance PrettyForTrace (C.Located (Id p)) => PrettyForTrace (DeclInfo p) where
   prettyForTrace DeclInfo{declId, declLoc} =
     prettyForTrace $ C.Located declLoc declId
 
-instance Id p ~ C.DeclId => PrettyForTrace (Decl p) where
+instance Id p ~ C.DeclId p => PrettyForTrace (Decl p) where
   prettyForTrace decl =
     let qualDeclId = declQualDeclId decl
     in  prettyForTrace $ C.Located (decl.declInfo.declLoc) qualDeclId
@@ -568,16 +568,16 @@ declQualPrelimDeclId :: HasCallStack =>
 declQualPrelimDeclId Decl{declInfo = DeclInfo{declId}, declKind} =
     C.qualPrelimDeclId declId (declKindNameKind declKind)
 
-declOrigQualPrelimDeclId :: Id p ~ C.DeclId => Decl p -> C.QualPrelimDeclId
+declOrigQualPrelimDeclId :: Id p ~ C.DeclId p => Decl p -> C.QualPrelimDeclId
 declOrigQualPrelimDeclId Decl{declInfo = DeclInfo{declId}, declKind} =
     C.qualDeclIdToQualPrelimDeclId $
       C.declIdToQualDeclId declId (declKindNameKind declKind)
 
-declQualDeclId :: Id p ~ C.DeclId => Decl p -> C.QualDeclId
+declQualDeclId :: Id p ~ C.DeclId p => Decl p -> C.QualDeclId p
 declQualDeclId Decl{declInfo = DeclInfo{declId}, declKind} =
     C.declIdToQualDeclId declId (declKindNameKind declKind)
 
-declQualName :: Id p ~ C.DeclId => Decl p -> C.QualName
+declQualName :: Id p ~ C.DeclId p => Decl p -> C.QualName
 declQualName Decl{declInfo = DeclInfo{declId}, declKind} =
     C.QualName (C.declIdName declId) (declKindNameKind declKind)
 

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

@@ -17,7 +17,6 @@ import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph
 import HsBindgen.Frontend.Analysis.UseDeclGraph (Usage (..), ValOrRef (..))
 import HsBindgen.Frontend.AST.Internal qualified as C
 import HsBindgen.Frontend.Naming qualified as C
-import HsBindgen.Frontend.Pass.HandleTypedefs.IsPass (HandleTypedefs)
 import HsBindgen.Frontend.Pass.Select.IsPass (Select)
 import HsBindgen.Imports
 
@@ -107,12 +106,12 @@ import HsBindgen.Imports
 -- thing also in the case of this name clash.
 data TypedefAnalysis = TypedefAnalysis {
       -- | Declarations (structs, unions, or enums) that need to be renamed
-      rename :: Map C.Name C.DeclId
+      rename :: Map C.Name (C.DeclId Select)
 
       -- | Typedefs that need to be squashed
       --
       -- We record what use sites of the typedef should be replaced with.
-    , squash :: Map C.Name (C.Type HandleTypedefs)
+    , squash :: Map C.Name (C.Type Select)
     }
   deriving stock (Show, Eq)
 
@@ -152,7 +151,7 @@ fromDecls declUseGraph = mconcat . map aux
 
 analyseTypedef ::
      DeclUseGraph
-  -> C.DeclId
+  -> C.DeclId Select
   -> C.Typedef Select
   -> TypedefAnalysis
 analyseTypedef declUseGraph uid typedef =
@@ -222,7 +221,7 @@ typedefOfTagged typedefName valOrRef taggedType@TaggedTypeId{..} useSites
 --
 -- If we rename a datatype with a name which was /already/ not original, we
 -- leave the origin information unchanged.
-updateOrigin :: C.DeclId -> C.NameOrigin
+updateOrigin :: C.DeclId Select -> C.NameOrigin
 updateOrigin (C.DeclIdBuiltin _name) =
     -- TODO: Ideally we'd have a separate pass to deal with builtin types,
     -- and strengthen the types in such as a way that we don't have to deal with
@@ -246,7 +245,7 @@ updateOrigin (C.DeclIdNamed oldName origin) =
 -- This is nearly identical to 'C.QualDeclId', except that we use 'C.TagKind'
 -- rather than 'C.NameKind' (in other words, we rule out 'C.NameKindOrdinary').
 data TaggedTypeId = TaggedTypeId {
-      taggedTypeDeclId :: C.DeclId
+      taggedTypeDeclId :: C.DeclId Select
     , taggedTypeIdKind :: C.TagKind
     }
   deriving stock (Eq, Generic, Ord, Show)
@@ -268,7 +267,7 @@ toTaggedTypeId = \case
     C.TypeEnum   declId -> Just $ TaggedTypeId declId C.TagKindEnum
     _otherwise          -> Nothing
 
-fromTaggedTypeId :: TaggedTypeId -> C.Type HandleTypedefs
+fromTaggedTypeId :: TaggedTypeId -> C.Type Select
 fromTaggedTypeId (TaggedTypeId declId kind) =
     case kind of
       C.TagKindStruct -> C.TypeStruct declId

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

@@ -85,6 +85,7 @@ import Clang.HighLevel.Types
 import Clang.LowLevel.Core
 
 import HsBindgen.Errors
+import HsBindgen.Frontend.Pass
 import HsBindgen.Imports
 import HsBindgen.Util.Tracer (PrettyForTrace (prettyForTrace))
 
@@ -386,23 +387,23 @@ instance PrettyForTrace NameOrigin where
 --
 -- All declarations have names after renaming in the @NameAnon@ pass.  This type
 -- is used until the @MangleNames@ pass.
-data DeclId =
+data DeclId (p :: Pass) =
     DeclIdNamed Name NameOrigin
   | DeclIdBuiltin Name
   deriving stock (Show, Eq, Ord, Generic)
 
-declIdName :: DeclId -> Name
+declIdName :: DeclId p -> Name
 declIdName (DeclIdNamed name _origin) = name
 declIdName (DeclIdBuiltin name) = name
 
-instance PrettyForTrace DeclId where
+instance PrettyForTrace (DeclId p) where
   prettyForTrace = \case
       DeclIdNamed name origin ->
         prettyForTrace name <+> PP.parens (prettyForTrace origin)
       DeclIdBuiltin name ->
         prettyForTrace name
 
-instance PrettyForTrace (Located DeclId) where
+instance PrettyForTrace (Located (DeclId p)) where
   prettyForTrace (Located loc declId) =
       case declId of
         DeclIdNamed name origin -> PP.hsep [
@@ -417,13 +418,13 @@ instance PrettyForTrace (Located DeclId) where
 -------------------------------------------------------------------------------}
 
 -- | Declaration identifier, qualified by 'NameKind'
-data QualDeclId = QualDeclId {
-      qualDeclId     :: DeclId
+data QualDeclId p = QualDeclId {
+      qualDeclId     :: DeclId p
     , qualDeclIdKind :: NameKind
     }
   deriving stock (Eq, Generic, Ord, Show)
 
-instance PrettyForTrace (Located QualDeclId) where
+instance PrettyForTrace (Located (QualDeclId p)) where
   prettyForTrace (Located loc QualDeclId{..}) =
       case qualDeclId of
         DeclIdNamed name origin -> PP.hsep [
@@ -433,13 +434,13 @@ instance PrettyForTrace (Located QualDeclId) where
         DeclIdBuiltin name ->
           prettyForTrace (QualName name qualDeclIdKind)
 
-qualDeclIdName :: QualDeclId -> Name
+qualDeclIdName :: QualDeclId p -> Name
 qualDeclIdName = declIdName . qualDeclId
 
-declIdToQualDeclId :: DeclId -> NameKind -> QualDeclId
+declIdToQualDeclId :: DeclId p -> NameKind -> QualDeclId p
 declIdToQualDeclId = QualDeclId
 
-qualDeclIdToQualPrelimDeclId :: HasCallStack => QualDeclId -> QualPrelimDeclId
+qualDeclIdToQualPrelimDeclId :: HasCallStack => QualDeclId p -> QualPrelimDeclId
 qualDeclIdToQualPrelimDeclId (QualDeclId declId kind) =
     case declId of
       DeclIdNamed name origin ->

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

@@ -1,7 +1,6 @@
 module HsBindgen.Frontend.Pass (
     Pass
   , IsPass(..)
-  , TypedefRefWrapper(..)
   , NoAnn(..)
   , NoConfig(..)
   ) where
@@ -85,10 +84,6 @@ class IsPass (p :: Pass) where
   -- | Trace messages possibly emitted by the pass
   type Msg p :: Star
 
--- | Newtype wrapper intended for class instances and constraints where
--- partially applied type synonyms are not allowed.
-newtype TypedefRefWrapper p = TypedefRefWrapper { unTypedefRefWrapper :: TypedefRef p }
-
 data NoAnn = NoAnn
   deriving stock (Show, Eq, Ord)
 

hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs

@@ -7,7 +7,7 @@ module HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass (
 import HsBindgen.Frontend.Analysis.DeclIndex
 import HsBindgen.Frontend.Analysis.DeclUseGraph
 import HsBindgen.Frontend.Analysis.UseDeclGraph
-import HsBindgen.Frontend.AST.Coerce (CoercePass (..))
+import HsBindgen.Frontend.AST.Coerce
 import HsBindgen.Frontend.AST.Internal (ValidPass)
 import HsBindgen.Frontend.Naming qualified as C
 import HsBindgen.Frontend.Pass
@@ -66,5 +66,8 @@ data ConstructTranslationUnitMsg =
   CoercePass
 -------------------------------------------------------------------------------}
 
-instance CoercePass TypedefRefWrapper Parse ConstructTranslationUnit where
-  coercePass (TypedefRefWrapper p) = TypedefRefWrapper (coercePass p)
+instance CoercePassId Parse ConstructTranslationUnit where
+  coercePassId _ = id
+
+instance CoercePassTypedefRef Parse ConstructTranslationUnit where
+  coercePassTypedefRef _ = coercePass

hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/IsPass.hs

@@ -3,7 +3,7 @@ module HsBindgen.Frontend.Pass.HandleMacros.IsPass (
   , HandleMacrosReparseMsg(..)
   ) where
 
-import HsBindgen.Frontend.AST.Coerce (CoercePass (..))
+import HsBindgen.Frontend.AST.Coerce
 import HsBindgen.Frontend.AST.Internal (CheckedMacro, ValidPass)
 import HsBindgen.Frontend.Naming qualified as C
 import HsBindgen.Frontend.Pass
@@ -38,5 +38,8 @@ instance IsPass HandleMacros where
   CoercePass
 -------------------------------------------------------------------------------}
 
-instance CoercePass TypedefRefWrapper ConstructTranslationUnit HandleMacros where
-  coercePass (TypedefRefWrapper ref) = TypedefRefWrapper (coercePass ref)
+instance CoercePassId ConstructTranslationUnit HandleMacros where
+  coercePassId _ = id
+
+instance CoercePassTypedefRef ConstructTranslationUnit HandleMacros where
+  coercePassTypedefRef _ = coercePass