Skip to content

Commit 48f7ed0

Browse files
dschrempfdschrempf
committed
Binding category predicates
1 parent 75f70ae commit 48f7ed0

File tree

13 files changed

+124
-103
lines changed

13 files changed

+124
-103
lines changed

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
1919

2020
import HsBindgen
2121
import HsBindgen.App
22+
import HsBindgen.Backend.HsModule.Translation (useAllCategories)
2223
import HsBindgen.Backend.UniqueId
2324
import HsBindgen.Config
2425
import HsBindgen.Config.Internal
@@ -86,7 +87,9 @@ exec GlobalOpts{..} Opts{..} = do
8687

8788
artefacts :: Artefact ()
8889
artefacts = do
89-
writeBindingsMultiple hsOutputDir
90+
-- TODO_PR: Which command line options to adjust the binding category
91+
-- predicate do we want to provide?
92+
writeBindingsMultiple useAllCategories hsOutputDir
9093
forM_ outputBindingSpec writeBindingSpec
9194

9295
{-------------------------------------------------------------------------------

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

Lines changed: 12 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,8 @@ import Text.Read (readMaybe)
2424

2525
import HsBindgen
2626
import HsBindgen.App
27-
import HsBindgen.Backend.SHs.AST
27+
import HsBindgen.Backend.HsModule.Translation (SDeclPredicate, useSafeCategory)
28+
import HsBindgen.Backend.SHs.AST (ByCategory)
2829
import HsBindgen.Backend.UniqueId
2930
import HsBindgen.Config
3031
import HsBindgen.Errors
@@ -71,12 +72,12 @@ parseOpts = do
7172
-------------------------------------------------------------------------------}
7273

7374
data Lit = Lit {
74-
globalOpts :: GlobalOpts
75-
, config :: Config
76-
, uniqueId :: UniqueId
77-
, hsModuleName :: Hs.ModuleName
78-
, safety :: Safety
79-
, inputs :: [UncheckedHashIncludeArg]
75+
globalOpts :: GlobalOpts
76+
, config :: Config
77+
, uniqueId :: UniqueId
78+
, hsModuleName :: Hs.ModuleName
79+
, bindingCategoryPredicate :: ByCategory SDeclPredicate
80+
, inputs :: [UncheckedHashIncludeArg]
8081
}
8182

8283
parseLit :: Parser Lit
@@ -85,22 +86,11 @@ parseLit = Lit
8586
<*> parseConfig
8687
<*> parseUniqueId
8788
<*> parseHsModuleName
88-
<*> parseSafety
89+
-- TODO_PR: Which command line options to adjust the binding category
90+
-- predicate do we want to provide?
91+
<*> pure useSafeCategory
8992
<*> parseInputs
9093

91-
parseSafety :: Parser Safety
92-
parseSafety = asum [
93-
flag' Safe $ mconcat [
94-
long "safe"
95-
, help "Use _safe_ foreign function imports (default)"
96-
]
97-
, flag' Unsafe $ mconcat [
98-
long "unsafe"
99-
, help "Use _unsafe_ foreign function imports"
100-
]
101-
, pure Safe
102-
]
103-
10494
{-------------------------------------------------------------------------------
10595
Execution
10696
-------------------------------------------------------------------------------}
@@ -114,7 +104,7 @@ exec literateOpts = do
114104
let GlobalOpts{..} = globalOpts
115105
bindgenConfig = toBindgenConfig config uniqueId hsModuleName
116106
void $ hsBindgen tracerConfig bindgenConfig inputs $
117-
writeBindings safety (Just literateOpts.output)
107+
writeBindings bindingCategoryPredicate (Just literateOpts.output)
118108
where
119109
throwIO' :: String -> IO a
120110
throwIO' = throwIO . LiterateFileException literateOpts.input

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

Lines changed: 17 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import System.FilePath (takeDirectory, (<.>), (</>))
2626
import HsBindgen.Artefact
2727
import HsBindgen.Backend
2828
import HsBindgen.Backend.HsModule.Render
29+
import HsBindgen.Backend.HsModule.Translation
2930
import HsBindgen.Backend.SHs.AST
3031
import HsBindgen.BindingSpec.Gen
3132
import HsBindgen.Boot
@@ -111,35 +112,36 @@ writeUseDeclGraph mPath = do
111112
$ UseDeclGraph.dumpMermaid index useDeclGraph
112113

113114
-- | Get bindings (single module).
114-
getBindings :: Safety -> Artefact String
115-
getBindings safety = do
116-
finalModule <- finalModuleArtefact
117-
Lift $ pure . render $ finalModule
118-
where finalModuleArtefact = case safety of
119-
Safe -> FinalModuleSafe
120-
Unsafe -> FinalModuleUnsafe
115+
getBindings :: ByCategory SDeclPredicate -> Artefact String
116+
getBindings predicate = do
117+
name <- FinalModuleBaseName
118+
decls <- FinalDecls
119+
pure $ render $ translateModuleSingle name predicate decls
121120

122121
-- | Write bindings to file.
123122
--
124123
-- If no file is given, print to standard output.
125-
writeBindings :: Safety -> Maybe FilePath -> Artefact ()
126-
writeBindings safety mPath = do
127-
bindings <- getBindings safety
124+
writeBindings :: ByCategory SDeclPredicate -> Maybe FilePath -> Artefact ()
125+
writeBindings predicate mPath = do
126+
bindings <- getBindings predicate
128127
Lift $ write "bindings" mPath bindings
129128

130129
-- | Get bindings (one module per binding category).
131-
getBindingsMultiple :: Artefact (ByCategory String)
132-
getBindingsMultiple = fmap render <$> FinalModules
130+
getBindingsMultiple :: ByCategory SDeclPredicate -> Artefact (ByCategory String)
131+
getBindingsMultiple predicate = do
132+
name <- FinalModuleBaseName
133+
decls <- FinalDecls
134+
pure $ render <$> translateModuleMultiple name predicate decls
133135

134136
-- | Write bindings to files in provided output directory.
135137
--
136138
-- Each file contains a different binding category.
137139
--
138140
-- If no file is given, print to standard output.
139-
writeBindingsMultiple :: FilePath -> Artefact ()
140-
writeBindingsMultiple hsOutputDir = do
141+
writeBindingsMultiple :: ByCategory SDeclPredicate -> FilePath -> Artefact ()
142+
writeBindingsMultiple predicate hsOutputDir = do
141143
moduleBaseName <- FinalModuleBaseName
142-
bindingsByCategory <- getBindingsMultiple
144+
bindingsByCategory <- getBindingsMultiple predicate
143145
Lift $ writeByCategory "bindings" hsOutputDir moduleBaseName bindingsByCategory
144146

145147
-- | Write binding specifications to file.

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

Lines changed: 0 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ import Clang.Paths
2020
import HsBindgen.Backend
2121
import HsBindgen.Backend.Hs.AST qualified as Hs
2222
import HsBindgen.Backend.Hs.CallConv (UserlandCapiWrapper)
23-
import HsBindgen.Backend.HsModule.Translation
2423
import HsBindgen.Backend.SHs.AST
2524
import HsBindgen.Backend.SHs.AST qualified as SHs
2625
import HsBindgen.Boot
@@ -57,9 +56,6 @@ data Artefact (a :: Star) where
5756
HsDecls :: Artefact (ByCategory [Hs.Decl])
5857
FinalDecls :: Artefact (ByCategory ([UserlandCapiWrapper], [SHs.SDecl]))
5958
FinalModuleBaseName :: Artefact Hs.ModuleName
60-
FinalModuleSafe :: Artefact HsModule
61-
FinalModuleUnsafe :: Artefact HsModule
62-
FinalModules :: Artefact (ByCategory HsModule)
6359
-- * Lift and sequence artefacts
6460
Lift :: ArtefactM a -> Artefact a
6561
Bind :: Artefact b -> (b -> Artefact c ) -> Artefact c
@@ -137,9 +133,6 @@ runArtefacts
137133
HsDecls -> liftIO backendHsDecls
138134
FinalDecls -> liftIO backendFinalDecls
139135
FinalModuleBaseName -> pure backendFinalModuleBaseName
140-
FinalModuleSafe -> liftIO backendFinalModuleSafe
141-
FinalModuleUnsafe -> liftIO backendFinalModuleUnsafe
142-
FinalModules -> liftIO backendFinalModules
143136
-- Lift and sequence.
144137
(Lift f) -> lift f
145138
(Bind x f) -> do

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

Lines changed: 0 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ module HsBindgen.Backend
77
import HsBindgen.Backend.Hs.AST qualified as Hs
88
import HsBindgen.Backend.Hs.CallConv
99
import HsBindgen.Backend.Hs.Translation qualified as Hs
10-
import HsBindgen.Backend.HsModule.Translation
1110
import HsBindgen.Backend.SHs.AST qualified as SHs
1211
import HsBindgen.Backend.SHs.Simplify qualified as SHs
1312
import HsBindgen.Backend.SHs.Translation qualified as SHs
@@ -43,14 +42,6 @@ backend tracer BackendConfig{..} BootArtefact{..} FrontendArtefact{..} = do
4342
-- 3. Simplify.
4443
backendFinalDecls <- cache $ SHs.simplifySHs <$> sHsDecls
4544

46-
-- 4. Translate to modules.
47-
backendFinalModuleSafe <- cache $
48-
translateModuleSingle SHs.Safe moduleBaseName <$> backendFinalDecls
49-
backendFinalModuleUnsafe <- cache $
50-
translateModuleSingle SHs.Unsafe moduleBaseName <$> backendFinalDecls
51-
backendFinalModules <- cache $
52-
translateModuleMultiple moduleBaseName <$> backendFinalDecls
53-
5445
pure $ BackendArtefact {
5546
backendFinalModuleBaseName = moduleBaseName
5647
, ..
@@ -69,9 +60,6 @@ data BackendArtefact = BackendArtefact {
6960
backendHsDecls :: IO (SHs.ByCategory [Hs.Decl])
7061
, backendFinalDecls :: IO (SHs.ByCategory ([UserlandCapiWrapper], [SHs.SDecl]))
7162
, backendFinalModuleBaseName :: Hs.ModuleName
72-
, backendFinalModuleSafe :: IO HsModule
73-
, backendFinalModuleUnsafe :: IO HsModule
74-
, backendFinalModules :: IO (SHs.ByCategory HsModule)
7563
}
7664

7765
{-------------------------------------------------------------------------------

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ data TranslationOpts = TranslationOpts {
6969
-- | Default set of classes to derive for typedefs
7070
, translationDeriveTypedef :: [(Hs.Strategy Hs.HsType, Hs.TypeClass)]
7171

72-
-- | Ensure that identifier generated by @hs-bindgen@ are unique.
72+
-- | Ensure that identifiers generated by @hs-bindgen@ are unique.
7373
, translationUniqueId :: UniqueId
7474
}
7575
deriving stock (Show, Eq, Generic)

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

Lines changed: 57 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -7,11 +7,16 @@ module HsBindgen.Backend.HsModule.Translation (
77
, ImportListItem(..)
88
-- * HsModule
99
, HsModule(..)
10+
-- * Binding category selection
11+
, SDeclPredicate
12+
, useSafeCategory
13+
, useUnsafeCategory
14+
, useAllCategories
15+
, selectModuleMultiple
1016
-- * Translation
1117
, defHsModuleName
1218
, translateModuleMultiple
1319
, translateModuleSingle
14-
, mergeDecls
1520
) where
1621

1722
import Data.Foldable qualified as Foldable
@@ -65,6 +70,46 @@ data HsModule = HsModule {
6570
, hsModuleDecls :: [SDecl]
6671
}
6772

73+
{-------------------------------------------------------------------------------
74+
Binding category selection
75+
-------------------------------------------------------------------------------}
76+
77+
-- TODO_PR: Use `Hs.Name` (but then we need `ImpredicativeTypes`).
78+
type SDeclPredicate = Text -> Bool
79+
80+
useSafeCategory, useUnsafeCategory, useAllCategories :: ByCategory SDeclPredicate
81+
useSafeCategory = ByCategory $ Map.singleton BUnsafe (const False)
82+
useUnsafeCategory = ByCategory $ Map.singleton BSafe (const False)
83+
useAllCategories = ByCategory Map.empty
84+
85+
-- TODO_PR: Double check the select function.
86+
selectCategory ::
87+
SDeclPredicate
88+
-> SDecl
89+
-> Bool
90+
selectCategory p = \case
91+
(DVar x) -> p $ Hs.getName x.varName
92+
(DInst _) -> True
93+
(DRecord x) -> p $ Hs.getName x.dataType
94+
(DNewtype x) -> p $ Hs.getName x.newtypeName
95+
(DEmptyData x) -> p $ Hs.getName x.emptyDataName
96+
(DDerivingInstance _) -> True
97+
(DForeignImport x) -> p $ Hs.getName x.foreignImportName
98+
(DFunction x) -> p $ Hs.getName x.functionName
99+
(DPatternSynonym x) -> p $ Hs.getName x.patSynName
100+
(DPragma (NOINLINE n)) -> p $ Hs.getName n
101+
102+
-- Default to selecting all declarations.
103+
getPredicate :: BindingCategory -> ByCategory SDeclPredicate -> SDeclPredicate
104+
getPredicate x = fromMaybe (const True) . Map.lookup x . unByCategory
105+
106+
selectModuleMultiple ::
107+
ByCategory SDeclPredicate
108+
-> ByCategory ([UserlandCapiWrapper], [SDecl])
109+
-> ByCategory ([UserlandCapiWrapper], [SDecl])
110+
selectModuleMultiple predByCat = mapByCategory $ \cat (wrappers, decls) ->
111+
(wrappers, filter (selectCategory $ getPredicate cat predByCat) decls)
112+
68113
{-------------------------------------------------------------------------------
69114
Translation
70115
-------------------------------------------------------------------------------}
@@ -74,46 +119,30 @@ defHsModuleName = "Generated"
74119

75120
translateModuleMultiple ::
76121
Hs.ModuleName
122+
-> ByCategory SDeclPredicate
77123
-> ByCategory ([UserlandCapiWrapper], [SDecl])
78124
-> ByCategory HsModule
79-
translateModuleMultiple moduleBaseName declsByCat =
80-
mapByCategory go declsByCat
125+
translateModuleMultiple moduleBaseName predByCat declsByCat =
126+
mapByCategory go $ selectModuleMultiple predByCat declsByCat
81127
where
82128
go :: BindingCategory -> ([UserlandCapiWrapper], [SDecl]) -> HsModule
83-
go cat (wrappers, decls) =
84-
translateModule' (Just cat) moduleBaseName wrappers decls
129+
go cat xs = translateModule' (Just cat) moduleBaseName xs
85130

86131
translateModuleSingle ::
87-
Safety
88-
-> Hs.ModuleName
132+
Hs.ModuleName
133+
-> ByCategory SDeclPredicate
89134
-> ByCategory ([UserlandCapiWrapper], [SDecl])
90135
-> HsModule
91-
translateModuleSingle safety name declsByCat =
92-
translateModule' Nothing name wrappers decls
93-
where
94-
wrappers :: [UserlandCapiWrapper]
95-
decls :: [SDecl]
96-
(wrappers, decls) = mergeDecls safety declsByCat
97-
98-
mergeDecls ::
99-
Safety
100-
-> ByCategory ([UserlandCapiWrapper], [SDecl])
101-
-> ([UserlandCapiWrapper], [SDecl])
102-
mergeDecls safety declsByCat =
103-
Foldable.fold $ ByCategory $ removeSafetyCategory $ unByCategory declsByCat
104-
where
105-
safetyToRemove = case safety of
106-
Safe -> BUnsafe
107-
Unsafe -> BSafe
108-
removeSafetyCategory = Map.filterWithKey (\k _ -> k /= safetyToRemove)
136+
translateModuleSingle name predByCat declsByCat =
137+
translateModule' Nothing name $ Foldable.fold $
138+
selectModuleMultiple predByCat declsByCat
109139

110140
translateModule' ::
111141
Maybe BindingCategory
112142
-> Hs.ModuleName
113-
-> [UserlandCapiWrapper]
114-
-> [SDecl]
143+
-> ([UserlandCapiWrapper], [SDecl])
115144
-> HsModule
116-
translateModule' mcat moduleBaseName hsModuleUserlandCapiWrappers hsModuleDecls =
145+
translateModule' mcat moduleBaseName (hsModuleUserlandCapiWrappers, hsModuleDecls) =
117146
let hsModulePragmas =
118147
resolvePragmas hsModuleUserlandCapiWrappers hsModuleDecls
119148
hsModuleImports =

‎hs-bindgen/src-internal/HsBindgen/Backend/SHs/AST.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -301,7 +301,7 @@ data SDecl =
301301
deriving stock (Show)
302302

303303
newtype ByCategory a = ByCategory { unByCategory :: Map BindingCategory a }
304-
deriving newtype (Functor, Foldable, Show)
304+
deriving newtype (Eq, Functor, Foldable, Show)
305305

306306
mapByCategory :: (BindingCategory -> a -> b) -> ByCategory a -> ByCategory b
307307
mapByCategory f = ByCategory . Map.mapWithKey f . unByCategory

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

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ where
1515

1616
import HsBindgen.Backend.Hs.Haddock.Config
1717
import HsBindgen.Backend.Hs.Translation
18+
import HsBindgen.Backend.HsModule.Translation
1819
import HsBindgen.Backend.SHs.AST
1920
import HsBindgen.Backend.UniqueId
2021
import HsBindgen.BindingSpec
@@ -46,9 +47,9 @@ data Config_ path = Config {
4647
, programSlicing :: ProgramSlicing
4748

4849
-- * Backend
49-
, haddockPathStyle :: PathStyle
50+
, haddockPathStyle :: PathStyle
5051
}
51-
deriving stock (Show, Eq, Generic)
52+
deriving stock (Eq, Show, Generic)
5253
deriving stock (Functor, Foldable, Traversable)
5354
deriving anyclass (Default)
5455

@@ -107,7 +108,7 @@ data ConfigTH = ConfigTH {
107108
--
108109
-- >>> def :: Safety
109110
-- Safe
110-
safety :: Safety
111+
bindingCategoryPredicate :: ByCategory SDeclPredicate
111112

112113
-- | Show trace messages of the provided 'Level' or higher.
113114
--
@@ -123,5 +124,11 @@ data ConfigTH = ConfigTH {
123124
-- errors.
124125
, customLogLevelSettings :: [CustomLogLevelSetting]
125126
}
126-
deriving stock (Show, Eq, Generic)
127-
deriving anyclass Default
127+
deriving stock (Generic)
128+
129+
instance Default ConfigTH where
130+
def = ConfigTH {
131+
bindingCategoryPredicate = useSafeCategory
132+
, verbosity = def
133+
, customLogLevelSettings = def
134+
}

0 commit comments

Comments
 (0)