Address review feedback

Author: bolt12

hs-bindgen/app/HsBindgen/App.hs

@@ -162,7 +162,6 @@ parseConfig = Config
     <*> parseSelectPredicate
     <*> parseProgramSlicing
     <*> parsePathStyle
-    <*> parseFileOverwritePolicy
 
 {-------------------------------------------------------------------------------
   Binding specifications

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

@@ -59,5 +59,6 @@ parseOpts =
 exec :: GlobalOpts -> Opts -> IO ()
 exec GlobalOpts{..} Opts{..} = do
     let artefact = writeTests output
-        bindgenConfig = toBindgenConfig config uniqueId defHsModuleName
+        -- AllowFileOverwrite for tests
+        bindgenConfig = toBindgenConfig config AllowFileOverwrite uniqueId defHsModuleName
     void $ hsBindgen tracerConfig bindgenConfig inputs artefact

hs-bindgen/app/HsBindgen/Cli/Info/IncludeGraph.hs

@@ -40,6 +40,7 @@ data Opts = Opts {
     , hsModuleName :: Hs.ModuleName
     , output       :: Maybe FilePath
     , inputs       :: [UncheckedHashIncludeArg]
+    , fileOverwritePolicy :: FileOverwritePolicy
     }
 
 parseOpts :: Parser Opts
@@ -50,6 +51,7 @@ parseOpts =
       <*> parseHsModuleName
       <*> optional parseOutput'
       <*> parseInputs
+      <*> parseFileOverwritePolicy
 
 parseOutput' :: Parser FilePath
 parseOutput' = strOption $ mconcat [
@@ -65,6 +67,6 @@ parseOutput' = strOption $ mconcat [
 
 exec :: GlobalOpts -> Opts -> IO ()
 exec GlobalOpts{..} Opts{..} = do
-    let artefact = writeIncludeGraph (fileOverwritePolicy config) output
-        bindgenConfig = toBindgenConfig config uniqueId hsModuleName
+    let artefact = writeIncludeGraph output
+        bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
     void $ hsBindgen tracerConfig bindgenConfig inputs artefact

hs-bindgen/app/HsBindgen/Cli/Info/UseDeclGraph.hs

@@ -40,6 +40,7 @@ data Opts = Opts {
     , hsModuleName :: Hs.ModuleName
     , output       :: Maybe FilePath
     , inputs       :: [UncheckedHashIncludeArg]
+    , fileOverwritePolicy :: FileOverwritePolicy
     }
 
 parseOpts :: Parser Opts
@@ -50,6 +51,7 @@ parseOpts =
       <*> parseHsModuleName
       <*> optional parseOutput'
       <*> parseInputs
+      <*> parseFileOverwritePolicy
 
 parseOutput' :: Parser FilePath
 parseOutput' = strOption $ mconcat [
@@ -65,6 +67,6 @@ parseOutput' = strOption $ mconcat [
 
 exec :: GlobalOpts -> Opts -> IO ()
 exec GlobalOpts{..} Opts{..} = do
-    let artefact = writeUseDeclGraph (fileOverwritePolicy config) output
-        bindgenConfig = toBindgenConfig config uniqueId hsModuleName
+    let artefact = writeUseDeclGraph output
+        bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
     void $ hsBindgen tracerConfig bindgenConfig inputs artefact

hs-bindgen/app/HsBindgen/Cli/Internal/Frontend.hs

@@ -39,6 +39,7 @@ data Opts = Opts {
     , uniqueId     :: UniqueId
     , hsModuleName :: Hs.ModuleName
     , inputs       :: [UncheckedHashIncludeArg]
+    , fileOverwritePolicy :: FileOverwritePolicy
     }
 
 parseOpts :: Parser Opts
@@ -48,6 +49,7 @@ parseOpts =
       <*> parseUniqueId
       <*> parseHsModuleName
       <*> parseInputs
+      <*> parseFileOverwritePolicy
 
 {-------------------------------------------------------------------------------
   Execution
@@ -56,5 +58,5 @@ parseOpts =
 exec :: GlobalOpts -> Opts -> IO ()
 exec GlobalOpts{..} Opts{..} = do
     let artefact = ReifiedC >>= liftIO . print
-        bindgenConfig = toBindgenConfig config uniqueId hsModuleName
+        bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
     hsBindgen tracerConfig bindgenConfig inputs artefact

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

@@ -47,6 +47,7 @@ data Opts = Opts {
     , outputBindingSpec   :: Maybe FilePath
     -- NOTE: Inputs (arguments) must be last, options must go before it.
     , inputs              :: [UncheckedHashIncludeArg]
+    , fileOverwritePolicy :: FileOverwritePolicy
     }
   deriving (Generic)
 
@@ -60,6 +61,7 @@ parseOpts =
       <*> parseOutputDirPolicy
       <*> optional parseGenBindingSpec
       <*> parseInputs
+      <*> parseFileOverwritePolicy
 
 {-------------------------------------------------------------------------------
   Execution
@@ -79,15 +81,15 @@ exec GlobalOpts{..} Opts{..} = do
     void $ run $ artefacts
   where
     bindgenConfig :: BindgenConfig
-    bindgenConfig = toBindgenConfig config uniqueId hsModuleName
+    bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
 
     run :: Artefact a -> IO a
     run = hsBindgen tracerConfig bindgenConfig inputs
 
     artefacts :: Artefact ()
     artefacts = do
-        writeBindingsMultiple (fileOverwritePolicy config) hsOutputDir
-        forM_ outputBindingSpec (writeBindingSpec (fileOverwritePolicy config))
+        writeBindingsMultiple hsOutputDir
+        forM_ outputBindingSpec writeBindingSpec
 
 {-------------------------------------------------------------------------------
   Exception

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

@@ -48,6 +48,7 @@ info = progDesc $ mconcat [
 data Opts = Opts {
       input  :: FilePath
     , output :: FilePath
+    , fileOverwritePolicy :: FileOverwritePolicy
     }
   deriving (Show, Eq)
 
@@ -64,6 +65,8 @@ parseOpts = do
 
     input  <- strArgument $ metavar "IN"
     output <- strArgument $ metavar "OUT"
+
+    fileOverwritePolicy <- parseFileOverwritePolicy
     return Opts{..}
 
 {-------------------------------------------------------------------------------
@@ -112,9 +115,9 @@ exec literateOpts = do
     Lit{..} <- maybe (throwIO' "cannot parse arguments in literate file") return $
       pureParseLit args
     let GlobalOpts{..} = globalOpts
-        bindgenConfig = toBindgenConfig config uniqueId hsModuleName
+        bindgenConfig = toBindgenConfig config (literateOpts.fileOverwritePolicy ) uniqueId hsModuleName
     void $ hsBindgen tracerConfig bindgenConfig inputs $
-      writeBindings (fileOverwritePolicy config) safety (Just literateOpts.output)
+      writeBindings safety (Just literateOpts.output)
   where
     throwIO' :: String -> IO a
     throwIO' = throwIO . LiterateFileException literateOpts.input

hs-bindgen/src-internal/HsBindgen.hs

@@ -16,12 +16,10 @@ module HsBindgen
   ) where
 
 import Control.Monad (join)
-import Control.Monad.Trans.Reader (ask)
 import Data.Foldable qualified as Foldable
 import Data.Map qualified as Map
 import Data.Text qualified as T
-import System.Directory (createDirectoryIfMissing, doesFileExist)
-import System.FilePath (takeDirectory, (<.>), (</>))
+import System.FilePath ((<.>), (</>))
 
 import HsBindgen.Artefact
 import HsBindgen.Backend
@@ -73,6 +71,7 @@ hsBindgen
       -- 4. Artefacts.
       withTracerSafe tracerConfigSafe $ \tracerSafe -> do
         runArtefacts
+          (backendFileOverwrite bindgenBackendConfig)
           tracerSafe
           tracerUnsafeRef
           bootArtefact
@@ -96,19 +95,19 @@ hsBindgen
 -------------------------------------------------------------------------------}
 
 -- | Write the include graph to `STDOUT` or a file.
-writeIncludeGraph :: FileOverwritePolicy -> Maybe FilePath -> Artefact ()
-writeIncludeGraph fop mPath = do
+writeIncludeGraph :: Maybe FilePath -> Artefact ()
+writeIncludeGraph mPath = do
     (p, includeGraph) <- IncludeGraph
-    Lift $ write fop "include graph" mPath
-         $ IncludeGraph.dumpMermaid p includeGraph
+    write "include graph" mPath $
+      IncludeGraph.dumpMermaid p includeGraph
 
 -- | Write @use-decl@ graph to file.
-writeUseDeclGraph :: FileOverwritePolicy -> Maybe FilePath -> Artefact ()
-writeUseDeclGraph fop mPath = do
+writeUseDeclGraph :: Maybe FilePath -> Artefact ()
+writeUseDeclGraph mPath = do
     index <- DeclIndex
     useDeclGraph <- UseDeclGraph
-    Lift $ write fop "use-decl graph" mPath
-         $ UseDeclGraph.dumpMermaid index useDeclGraph
+    write "use-decl graph" mPath $
+      UseDeclGraph.dumpMermaid index useDeclGraph
 
 -- | Get bindings (single module).
 getBindings :: Safety -> Artefact String
@@ -122,10 +121,10 @@ getBindings safety = do
 -- | Write bindings to file.
 --
 -- If no file is given, print to standard output.
-writeBindings :: FileOverwritePolicy -> Safety -> Maybe FilePath -> Artefact ()
-writeBindings fop safety mPath = do
+writeBindings :: Safety -> Maybe FilePath -> Artefact ()
+writeBindings safety mPath = do
     bindings <- getBindings safety
-    Lift $ write fop "bindings" mPath bindings
+    write "bindings" mPath bindings
 
 -- | Get bindings (one module per binding category).
 getBindingsMultiple :: Artefact (ByCategory String)
@@ -136,24 +135,23 @@ getBindingsMultiple = fmap render <$> FinalModules
 -- Each file contains a different binding category.
 --
 -- If no file is given, print to standard output.
-writeBindingsMultiple :: FileOverwritePolicy -> FilePath -> Artefact ()
-writeBindingsMultiple fop hsOutputDir = do
+writeBindingsMultiple :: FilePath -> Artefact ()
+writeBindingsMultiple hsOutputDir = do
     moduleBaseName     <- FinalModuleBaseName
     bindingsByCategory <- getBindingsMultiple
-    Lift $ writeByCategory "bindings" hsOutputDir fop moduleBaseName bindingsByCategory
+    writeByCategory "bindings" hsOutputDir moduleBaseName bindingsByCategory
 
 -- | Write binding specifications to file.
-writeBindingSpec :: FileOverwritePolicy -> FilePath -> Artefact ()
-writeBindingSpec fop path = do
+writeBindingSpec :: FilePath -> Artefact ()
+writeBindingSpec path = do
   moduleBaseName <- FinalModuleBaseName
   getMainHeaders <- GetMainHeaders
   omitTypes      <- OmitTypes
   hsDecls        <- HsDecls
-  tracer         <- Lift $ artefactTracer <$> ask
-  traceWith tracer $ RunArtefactWriteFile "binding specifications" path
   -- Binding specifications only specify types.
-  liftIO $ genBindingSpec moduleBaseName path fop getMainHeaders omitTypes $
-    fromMaybe [] (Map.lookup BType $ unByCategory hsDecls)
+  let bindingSpec = genBindingSpec moduleBaseName getMainHeaders omitTypes $
+                      fromMaybe [] (Map.lookup BType $ unByCategory hsDecls)
+  PendingFileWrite "binding specifications" path (BindingSpecContent bindingSpec)
 
 -- | Create test suite in directory.
 writeTests :: FilePath -> Artefact ()
@@ -171,40 +169,27 @@ writeTests testDir = do
   Helpers
 -------------------------------------------------------------------------------}
 
-write :: FileOverwritePolicy -> String -> Maybe FilePath -> String -> ArtefactM ()
-write _                    _    Nothing     str = liftIO $ putStrLn str
-write fop what (Just path) str = do
-      tracer <- artefactTracer <$> ask
-      traceWith tracer $ RunArtefactWriteFile what path
-      liftIO $ do
-        -- Check if file exists and policy forbids overwriting
-        fileExists <- doesFileExist path
-        case fop of
-          ProtectExistingFiles
-            | fileExists ->
-            throwIO (FileAlreadyExistsException path)
-          _ -> do
-            createDirectoryIfMissing True $ takeDirectory path
-            writeFile path str
+write :: String -> Maybe FilePath -> String -> Artefact ()
+write _    Nothing str     = liftIO $ putStrLn str
+write what (Just path) str = PendingFileWrite what path (TextContent str)
 
 writeByCategory ::
      String
   -> FilePath
-  -> FileOverwritePolicy
   -> Hs.ModuleName
   -> ByCategory String
-  -> ArtefactM ()
-writeByCategory what hsOutputDir fop moduleBaseName =
-    mapM_ (uncurry writeCategory) . Map.toList . unByCategory
+  -> Artefact ()
+writeByCategory what hsOutputDir moduleBaseName =
+    Foldable.foldl' (>>) (pure ()) . map (uncurry writeCategory) . Map.toList . unByCategory
   where
-    writeCategory :: BindingCategory -> String -> ArtefactM ()
-    writeCategory cat str = do
+    writeCategory :: BindingCategory -> String -> Artefact ()
+    writeCategory cat str =
       let addSubModule = case cat of
             BType    -> id
             otherCat -> (</> displayBindingCategory otherCat)
           path = addSubModule baseFilePath <.> "hs"
           whatWithCategory = what ++ " (" ++ show cat ++ ")"
-      write fop whatWithCategory (Just path) str
+      in write whatWithCategory (Just path) str
 
     baseFilePath :: FilePath
     baseFilePath = Foldable.foldl' (</>) "" $