Allow choice of binding category and renaming of bindings in specific categories (e.g., functions)

hs-bindgen/app/HsBindgen/Cli/Preprocess.hs

@@ -19,6 +19,7 @@ import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
 
 import HsBindgen
 import HsBindgen.App
+import HsBindgen.Backend.HsModule.Translation (useAllCategories)
 import HsBindgen.Backend.UniqueId
 import HsBindgen.Config
 import HsBindgen.Config.Internal
@@ -86,7 +87,9 @@ exec GlobalOpts{..} Opts{..} = do
 
     artefacts :: Artefact ()
     artefacts = do
-        writeBindingsMultiple hsOutputDir
+        -- TODO_PR: Which command line options to adjust the binding category
+        -- predicate do we want to provide?
+        writeBindingsMultiple useAllCategories hsOutputDir
         forM_ outputBindingSpec writeBindingSpec
 
 {-------------------------------------------------------------------------------

hs-bindgen/app/HsBindgen/Cli/ToolSupport/Literate.hs

@@ -24,7 +24,8 @@ import Text.Read (readMaybe)
 
 import HsBindgen
 import HsBindgen.App
-import HsBindgen.Backend.SHs.AST
+import HsBindgen.Backend.HsModule.Translation (SDeclPredicate, useSafeCategory)
+import HsBindgen.Backend.SHs.AST (ByCategory)
 import HsBindgen.Backend.UniqueId
 import HsBindgen.Config
 import HsBindgen.Errors
@@ -71,12 +72,12 @@ parseOpts = do
 -------------------------------------------------------------------------------}
 
 data Lit = Lit {
-      globalOpts   :: GlobalOpts
-    , config       :: Config
-    , uniqueId     :: UniqueId
-    , hsModuleName :: Hs.ModuleName
-    , safety       :: Safety
-    , inputs       :: [UncheckedHashIncludeArg]
+      globalOpts               :: GlobalOpts
+    , config                   :: Config
+    , uniqueId                 :: UniqueId
+    , hsModuleName             :: Hs.ModuleName
+    , bindingCategoryPredicate :: ByCategory SDeclPredicate
+    , inputs                   :: [UncheckedHashIncludeArg]
     }
 
 parseLit :: Parser Lit
@@ -85,22 +86,11 @@ parseLit = Lit
   <*> parseConfig
   <*> parseUniqueId
   <*> parseHsModuleName
-  <*> parseSafety
+  -- TODO_PR: Which command line options to adjust the binding category
+  -- predicate do we want to provide?
+  <*> pure useSafeCategory
   <*> parseInputs
 
-parseSafety :: Parser Safety
-parseSafety = asum [
-      flag' Safe $ mconcat [
-          long "safe"
-        , help "Use _safe_ foreign function imports (default)"
-        ]
-    , flag' Unsafe $ mconcat [
-          long "unsafe"
-        , help "Use _unsafe_ foreign function imports"
-        ]
-    , pure Safe
-    ]
-
 {-------------------------------------------------------------------------------
   Execution
 -------------------------------------------------------------------------------}
@@ -114,7 +104,7 @@ exec literateOpts = do
     let GlobalOpts{..} = globalOpts
         bindgenConfig = toBindgenConfig config uniqueId hsModuleName
     void $ hsBindgen tracerConfig bindgenConfig inputs $
-      writeBindings safety (Just literateOpts.output)
+      writeBindings bindingCategoryPredicate (Just literateOpts.output)
   where
     throwIO' :: String -> IO a
     throwIO' = throwIO . LiterateFileException literateOpts.input

hs-bindgen/src-internal/HsBindgen.hs

@@ -26,6 +26,7 @@ import System.FilePath (takeDirectory, (<.>), (</>))
 import HsBindgen.Artefact
 import HsBindgen.Backend
 import HsBindgen.Backend.HsModule.Render
+import HsBindgen.Backend.HsModule.Translation
 import HsBindgen.Backend.SHs.AST
 import HsBindgen.BindingSpec.Gen
 import HsBindgen.Boot
@@ -111,35 +112,39 @@ writeUseDeclGraph mPath = do
          $ UseDeclGraph.dumpMermaid index useDeclGraph
 
 -- | Get bindings (single module).
-getBindings :: Safety -> Artefact String
-getBindings safety = do
-    finalModule <- finalModuleArtefact
-    Lift $ pure . render $ finalModule
-  where finalModuleArtefact = case safety of
-          Safe   -> FinalModuleSafe
-          Unsafe -> FinalModuleUnsafe
+--
+-- Be careful to use an appropriate `CategoryChoice` avoiding name clashes, for
+-- example, between safe and unsafe functions.
+getBindings :: ByCategory SDeclPredicate -> Artefact String
+getBindings predicate = do
+    name  <- FinalModuleBaseName
+    decls <- FinalDecls
+    pure $ render $ translateModuleSingle name predicate decls
 
 -- | Write bindings to file.
 --
 -- If no file is given, print to standard output.
-writeBindings :: Safety -> Maybe FilePath -> Artefact ()
-writeBindings safety mPath = do
-    bindings <- getBindings safety
+writeBindings :: ByCategory SDeclPredicate -> Maybe FilePath -> Artefact ()
+writeBindings predicate mPath = do
+    bindings <- getBindings predicate
     Lift $ write "bindings" mPath bindings
 
 -- | Get bindings (one module per binding category).
-getBindingsMultiple :: Artefact (ByCategory String)
-getBindingsMultiple = fmap render <$> FinalModules
+getBindingsMultiple :: ByCategory SDeclPredicate -> Artefact (ByCategory String)
+getBindingsMultiple predicate = do
+  name  <- FinalModuleBaseName
+  decls <- FinalDecls
+  pure $ render <$> translateModuleMultiple name predicate decls
 
 -- | Write bindings to files in provided output directory.
 --
 -- Each file contains a different binding category.
 --
 -- If no file is given, print to standard output.
-writeBindingsMultiple :: FilePath -> Artefact ()
-writeBindingsMultiple hsOutputDir = do
+writeBindingsMultiple :: ByCategory SDeclPredicate -> FilePath -> Artefact ()
+writeBindingsMultiple predicate hsOutputDir = do
     moduleBaseName     <- FinalModuleBaseName
-    bindingsByCategory <- getBindingsMultiple
+    bindingsByCategory <- getBindingsMultiple predicate
     Lift $ writeByCategory "bindings" hsOutputDir moduleBaseName bindingsByCategory
 
 -- | Write binding specifications to file.

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

@@ -20,7 +20,6 @@ import Clang.Paths
 import HsBindgen.Backend
 import HsBindgen.Backend.Hs.AST qualified as Hs
 import HsBindgen.Backend.Hs.CallConv (UserlandCapiWrapper)
-import HsBindgen.Backend.HsModule.Translation
 import HsBindgen.Backend.SHs.AST
 import HsBindgen.Backend.SHs.AST qualified as SHs
 import HsBindgen.Boot
@@ -57,9 +56,6 @@ data Artefact (a :: Star) where
   HsDecls             :: Artefact (ByCategory [Hs.Decl])
   FinalDecls          :: Artefact (ByCategory ([UserlandCapiWrapper], [SHs.SDecl]))
   FinalModuleBaseName :: Artefact Hs.ModuleName
-  FinalModuleSafe     :: Artefact HsModule
-  FinalModuleUnsafe   :: Artefact HsModule
-  FinalModules        :: Artefact (ByCategory HsModule)
   -- * Lift and sequence artefacts
   Lift                :: ArtefactM a -> Artefact a
   Bind                :: Artefact b  -> (b -> Artefact c ) -> Artefact c
@@ -137,9 +133,6 @@ runArtefacts
       HsDecls             -> liftIO backendHsDecls
       FinalDecls          -> liftIO backendFinalDecls
       FinalModuleBaseName -> pure backendFinalModuleBaseName
-      FinalModuleSafe     -> liftIO backendFinalModuleSafe
-      FinalModuleUnsafe   -> liftIO backendFinalModuleUnsafe
-      FinalModules        -> liftIO backendFinalModules
       -- Lift and sequence.
       (Lift f)            -> lift f
       (Bind x   f)        -> do

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

@@ -7,7 +7,6 @@ module HsBindgen.Backend
 import HsBindgen.Backend.Hs.AST qualified as Hs
 import HsBindgen.Backend.Hs.CallConv
 import HsBindgen.Backend.Hs.Translation qualified as Hs
-import HsBindgen.Backend.HsModule.Translation
 import HsBindgen.Backend.SHs.AST qualified as SHs
 import HsBindgen.Backend.SHs.Simplify qualified as SHs
 import HsBindgen.Backend.SHs.Translation qualified as SHs
@@ -37,20 +36,15 @@ backend tracer BackendConfig{..} BootArtefact{..} FrontendArtefact{..} = do
         moduleBaseName <$> frontendIndex
                        <*> frontendCDecls
 
+    -- TODO_PR: Add pass performing category selection and renaming.
+    -- The backend artefact should contain the transformed declarations.
+
     -- 2. @Hs@ declarations to simple @Hs@ declarations.
     sHsDecls <- cache $ SHs.translateDecls <$> backendHsDecls
 
     -- 3. Simplify.
     backendFinalDecls <- cache $ SHs.simplifySHs <$> sHsDecls
 
-    -- 4. Translate to modules.
-    backendFinalModuleSafe <- cache $
-      translateModuleSingle SHs.Safe moduleBaseName <$> backendFinalDecls
-    backendFinalModuleUnsafe <- cache $
-      translateModuleSingle SHs.Unsafe moduleBaseName <$> backendFinalDecls
-    backendFinalModules <- cache $
-      translateModuleMultiple moduleBaseName <$> backendFinalDecls
-
     pure $ BackendArtefact {
       backendFinalModuleBaseName = moduleBaseName
     , ..
@@ -69,9 +63,6 @@ data BackendArtefact = BackendArtefact {
     backendHsDecls             :: IO (SHs.ByCategory [Hs.Decl])
   , backendFinalDecls          :: IO (SHs.ByCategory ([UserlandCapiWrapper], [SHs.SDecl]))
   , backendFinalModuleBaseName :: Hs.ModuleName
-  , backendFinalModuleSafe     :: IO HsModule
-  , backendFinalModuleUnsafe   :: IO HsModule
-  , backendFinalModules        :: IO (SHs.ByCategory HsModule)
   }
 
 {-------------------------------------------------------------------------------

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

@@ -69,7 +69,7 @@ data TranslationOpts = TranslationOpts {
       -- | Default set of classes to derive for typedefs
     , translationDeriveTypedef :: [(Hs.Strategy Hs.HsType, Hs.TypeClass)]
 
-      -- | Ensure that identifier generated by @hs-bindgen@ are unique.
+      -- | Ensure that identifiers generated by @hs-bindgen@ are unique.
     , translationUniqueId :: UniqueId
     }
   deriving stock (Show, Eq, Generic)

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeData #-}
 
 module HsBindgen.Backend.HsModule.Translation (
     -- * GhcPragma
@@ -7,11 +8,16 @@ module HsBindgen.Backend.HsModule.Translation (
   , ImportListItem(..)
     -- * HsModule
   , HsModule(..)
+    -- * Binding category selection
+  , SDeclPredicate
+  , useSafeCategory
+  , useUnsafeCategory
+  , useAllCategories
+  , selectModuleMultiple
     -- * Translation
   , defHsModuleName
   , translateModuleMultiple
   , translateModuleSingle
-  , mergeDecls
   ) where
 
 import Data.Foldable qualified as Foldable
@@ -65,6 +71,71 @@ data HsModule = HsModule {
     , hsModuleDecls                :: [SDecl]
     }
 
+{-------------------------------------------------------------------------------
+  Binding category selection
+-------------------------------------------------------------------------------}
+
+-- TODO_PR: Use `Hs.Name` (but then we need `ImpredicativeTypes`).
+type SDeclPredicate = Text -> Bool
+
+type data Level = Types | Terms
+
+-- TODO_PR: Qualified (ByCategory.Choice).
+data CategoryChoice (lvl :: Level) where
+  ExcludeCategory     :: CategoryChoice lvl
+  IncludeTypeCategory :: CategoryChoice Types
+  IncludeTermCategory :: (Text -> Text) -> CategoryChoice Terms
+
+-- TODO_PR Defaults: Move to category module; use qualified names.
+--
+-- TH and literal mode: use types safe globals, no renaming.
+-- Preprocess: Use all categories, no renaming.
+useSafeCategory, useUnsafeCategory, useAllCategories :: ByCategory SDeclPredicate
+-- TODO_PR should also exclude pointers as written above.
+useSafeCategory   = ByCategory $ Map.singleton BUnsafe (const False)
+-- TODO_PR should also exclude pointers as written above.
+useUnsafeCategory = ByCategory $ Map.singleton BSafe   (const False)
+useAllCategories  = ByCategory   Map.empty
+
+-- TODO_PR: Fix #1262
+-- TODO_PR: Golden test case for #1262.
+
+-- TODO_PR: Work with Hs.Decl.
+--
+-- Start with panic for all cases.
+--
+-- Only deal with function and foreign imports for function cases.
+--
+-- DVar.
+--
+-- panic for the rest.
+selectCategory ::
+     SDeclPredicate
+  -> SDecl
+  -> Bool
+selectCategory p = \case
+  (DVar              x)  -> p $ Hs.getName x.varName
+  (DInst             _)  -> True
+  (DRecord           x)  -> p $ Hs.getName x.dataType
+  (DNewtype          x)  -> p $ Hs.getName x.newtypeName
+  (DEmptyData        x)  -> p $ Hs.getName x.emptyDataName
+  (DDerivingInstance _)  -> True
+  (DForeignImport    x)  -> p $ Hs.getName x.foreignImportName
+  (DFunction         x)  -> p $ Hs.getName x.functionName
+  (DPatternSynonym   x)  -> p $ Hs.getName x.patSynName
+  (DPragma (NOINLINE n)) -> p $ Hs.getName n
+
+-- Default to selecting all declarations.
+getPredicate :: BindingCategory -> ByCategory SDeclPredicate -> SDeclPredicate
+getPredicate x = fromMaybe (const True) . Map.lookup x . unByCategory
+
+selectModuleMultiple ::
+     ByCategory SDeclPredicate
+  -> ByCategory ([UserlandCapiWrapper], [SDecl])
+  -> ByCategory ([UserlandCapiWrapper], [SDecl])
+selectModuleMultiple predByCat = mapByCategory $ \cat (wrappers, decls) ->
+    (wrappers, filter (selectCategory $ getPredicate cat predByCat) decls)
+
 {-------------------------------------------------------------------------------
   Translation
 -------------------------------------------------------------------------------}
@@ -74,46 +145,30 @@ defHsModuleName = "Generated"
 
 translateModuleMultiple ::
      Hs.ModuleName
+  -> ByCategory SDeclPredicate
   -> ByCategory ([UserlandCapiWrapper], [SDecl])
   -> ByCategory HsModule
-translateModuleMultiple moduleBaseName declsByCat =
-  mapByCategory go declsByCat
+translateModuleMultiple moduleBaseName predByCat declsByCat =
+    mapByCategory go $ selectModuleMultiple predByCat declsByCat
   where
     go :: BindingCategory -> ([UserlandCapiWrapper], [SDecl]) -> HsModule
-    go cat (wrappers, decls) =
-      translateModule' (Just cat) moduleBaseName wrappers decls
+    go cat xs = translateModule' (Just cat) moduleBaseName xs
 
 translateModuleSingle ::
-     Safety
-  -> Hs.ModuleName
+     Hs.ModuleName
+  -> ByCategory SDeclPredicate
   -> ByCategory ([UserlandCapiWrapper], [SDecl])
   -> HsModule
-translateModuleSingle safety name declsByCat =
-  translateModule' Nothing name wrappers decls
-  where
-    wrappers :: [UserlandCapiWrapper]
-    decls :: [SDecl]
-    (wrappers, decls) = mergeDecls safety declsByCat
-
-mergeDecls ::
-  Safety
-  -> ByCategory ([UserlandCapiWrapper], [SDecl])
-  -> ([UserlandCapiWrapper], [SDecl])
-mergeDecls safety declsByCat =
-    Foldable.fold $ ByCategory $ removeSafetyCategory $ unByCategory declsByCat
-  where
-    safetyToRemove = case safety of
-      Safe   -> BUnsafe
-      Unsafe -> BSafe
-    removeSafetyCategory = Map.filterWithKey (\k _ -> k /= safetyToRemove)
+translateModuleSingle name predByCat declsByCat =
+    translateModule' Nothing name $ Foldable.fold $
+      selectModuleMultiple predByCat declsByCat
 
 translateModule' ::
      Maybe BindingCategory
   -> Hs.ModuleName
-  -> [UserlandCapiWrapper]
-  -> [SDecl]
+  -> ([UserlandCapiWrapper], [SDecl])
   -> HsModule
-translateModule' mcat moduleBaseName hsModuleUserlandCapiWrappers hsModuleDecls =
+translateModule' mcat moduleBaseName (hsModuleUserlandCapiWrappers, hsModuleDecls) =
     let hsModulePragmas =
           resolvePragmas hsModuleUserlandCapiWrappers hsModuleDecls
         hsModuleImports =