Skip to content

Commit f85bf79

Browse files
bolt12bolt12
committed
Integrate --create-dirs flag into new design
1 parent 6b52bb6 commit f85bf79

File tree

13 files changed

+90
-56
lines changed

13 files changed

+90
-56
lines changed

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,5 +58,5 @@ exec :: GlobalOpts -> Opts -> IO ()
5858
exec GlobalOpts{..} Opts{..} = do
5959
let artefact = writeTests output
6060
-- AllowFileOverwrite for tests
61-
bindgenConfig = toBindgenConfig config AllowFileOverwrite uniqueId defBaseModuleName
61+
bindgenConfig = toBindgenConfig config CreateDirStructure AllowFileOverwrite uniqueId defBaseModuleName
6262
void $ hsBindgen tracerConfig bindgenConfig inputs artefact

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ data Opts = Opts {
3939
, hsModuleName :: Hs.ModuleName
4040
, output :: Maybe FilePath
4141
, inputs :: [UncheckedHashIncludeArg]
42+
, outputDirPolicy :: OutputDirPolicy
4243
, fileOverwritePolicy :: FileOverwritePolicy
4344
}
4445

@@ -50,6 +51,7 @@ parseOpts =
5051
<*> parseHsModuleName
5152
<*> optional parseOutput'
5253
<*> parseInputs
54+
<*> parseOutputDirPolicy
5355
<*> parseFileOverwritePolicy
5456

5557
parseOutput' :: Parser FilePath
@@ -67,5 +69,5 @@ parseOutput' = strOption $ mconcat [
6769
exec :: GlobalOpts -> Opts -> IO ()
6870
exec GlobalOpts{..} Opts{..} = do
6971
let artefact = writeIncludeGraph output
70-
bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
72+
bindgenConfig = toBindgenConfig config outputDirPolicy fileOverwritePolicy uniqueId hsModuleName
7173
void $ hsBindgen tracerConfig bindgenConfig inputs artefact

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ data Opts = Opts {
3939
, hsModuleName :: Hs.ModuleName
4040
, output :: Maybe FilePath
4141
, inputs :: [UncheckedHashIncludeArg]
42+
, outputDirPolicy :: OutputDirPolicy
4243
, fileOverwritePolicy :: FileOverwritePolicy
4344
}
4445

@@ -50,6 +51,7 @@ parseOpts =
5051
<*> parseHsModuleName
5152
<*> optional parseOutput'
5253
<*> parseInputs
54+
<*> parseOutputDirPolicy
5355
<*> parseFileOverwritePolicy
5456

5557
parseOutput' :: Parser FilePath
@@ -67,5 +69,5 @@ parseOutput' = strOption $ mconcat [
6769
exec :: GlobalOpts -> Opts -> IO ()
6870
exec GlobalOpts{..} Opts{..} = do
6971
let artefact = writeUseDeclGraph output
70-
bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
72+
bindgenConfig = toBindgenConfig config outputDirPolicy fileOverwritePolicy uniqueId hsModuleName
7173
void $ hsBindgen tracerConfig bindgenConfig inputs artefact

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ data Opts = Opts {
3838
, uniqueId :: UniqueId
3939
, hsModuleName :: Hs.ModuleName
4040
, inputs :: [UncheckedHashIncludeArg]
41+
, outputDirPolicy :: OutputDirPolicy
4142
, fileOverwritePolicy :: FileOverwritePolicy
4243
}
4344

@@ -48,6 +49,7 @@ parseOpts =
4849
<*> parseUniqueId
4950
<*> parseHsModuleName
5051
<*> parseInputs
52+
<*> parseOutputDirPolicy
5153
<*> parseFileOverwritePolicy
5254

5355
{-------------------------------------------------------------------------------
@@ -57,5 +59,5 @@ parseOpts =
5759
exec :: GlobalOpts -> Opts -> IO ()
5860
exec GlobalOpts{..} Opts{..} = do
5961
let artefact = ReifiedC >>= liftIO . print
60-
bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
62+
bindgenConfig = toBindgenConfig config outputDirPolicy fileOverwritePolicy uniqueId hsModuleName
6163
hsBindgen tracerConfig bindgenConfig inputs artefact

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

Lines changed: 3 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -13,18 +13,17 @@ module HsBindgen.Cli.Preprocess (
1313
, exec
1414
) where
1515

16-
import Control.Exception (Exception (..))
1716
import Options.Applicative hiding (info)
1817
import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
1918

2019
import HsBindgen
2120
import HsBindgen.App
2221
import HsBindgen.Config
2322
import HsBindgen.Config.Internal
24-
import HsBindgen.Errors
2523
import HsBindgen.Frontend.RootHeader
2624
import HsBindgen.Imports
2725
import HsBindgen.Language.Haskell qualified as Hs
26+
import HsBindgen.Util.Tracer (FileSystemException (..))
2827

2928
{-------------------------------------------------------------------------------
3029
CLI help
@@ -80,29 +79,13 @@ exec GlobalOpts{..} Opts{..} = do
8079
void $ run $ artefacts
8180
where
8281
bindgenConfig :: BindgenConfig
83-
bindgenConfig = toBindgenConfig config fileOverwritePolicy uniqueId hsModuleName
82+
bindgenConfig = toBindgenConfig config outputDirPolicy fileOverwritePolicy uniqueId hsModuleName
8483

8584
run :: Artefact a -> IO a
8685
run = hsBindgen tracerConfig bindgenConfig inputs
8786

8887
artefacts :: Artefact ()
8988
artefacts = do
89+
DirectoryCreate hsOutputDir
9090
writeBindingsMultiple hsOutputDir
9191
forM_ outputBindingSpec writeBindingSpec
92-
93-
{-------------------------------------------------------------------------------
94-
Exception
95-
-------------------------------------------------------------------------------}
96-
97-
data OutputDirectoryMissingException =
98-
OutputDirectoryMissingException FilePath
99-
deriving Show
100-
101-
instance Exception OutputDirectoryMissingException where
102-
toException = hsBindgenExceptionToException
103-
fromException = hsBindgenExceptionFromException
104-
displayException (OutputDirectoryMissingException path) = unlines
105-
[ "Output directory does not exist: " ++ path
106-
, ""
107-
, "Use --create-output-dirs to create it automatically, or create the directory manually."
108-
]

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

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ info = progDesc $ mconcat [
4747
data Opts = Opts {
4848
input :: FilePath
4949
, output :: FilePath
50+
, outputDirPolicy :: OutputDirPolicy
5051
, fileOverwritePolicy :: FileOverwritePolicy
5152
}
5253
deriving (Show, Eq)
@@ -65,6 +66,7 @@ parseOpts = do
6566
input <- strArgument $ metavar "IN"
6667
output <- strArgument $ metavar "OUT"
6768

69+
outputDirPolicy <- parseOutputDirPolicy
6870
fileOverwritePolicy <- parseFileOverwritePolicy
6971
return Opts{..}
7072

@@ -114,7 +116,13 @@ exec literateOpts = do
114116
Lit{..} <- maybe (throwIO' "cannot parse arguments in literate file") return $
115117
pureParseLit args
116118
let GlobalOpts{..} = globalOpts
117-
bindgenConfig = toBindgenConfig config (literateOpts.fileOverwritePolicy ) uniqueId hsModuleName
119+
bindgenConfig =
120+
toBindgenConfig
121+
config
122+
(literateOpts.outputDirPolicy)
123+
(literateOpts.fileOverwritePolicy )
124+
uniqueId
125+
hsModuleName
118126
void $ hsBindgen tracerConfig bindgenConfig inputs $
119127
writeBindings safety (Just literateOpts.output)
120128
where

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

Lines changed: 31 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,8 @@ import Data.Foldable (foldrM)
1919
import Data.Foldable qualified as Foldable
2020
import Data.Map qualified as Map
2121
import Data.Text qualified as T
22-
import System.Directory (createDirectoryIfMissing, doesFileExist)
22+
import System.Directory (createDirectoryIfMissing, doesDirectoryExist,
23+
doesFileExist)
2324
import System.FilePath (takeDirectory, (<.>), (</>))
2425

2526
import HsBindgen.Artefact
@@ -82,7 +83,10 @@ hsBindgen
8283

8384
-- Execute file system actions based on FileOverwritePolicy
8485
value <- either throwIO pure result
85-
executeFileSystemActions (backendFileOverwrite bindgenBackendConfig) fsActions
86+
executeFileSystemActions
87+
(backendOutputDirPolicy bindgenBackendConfig)
88+
(backendFileOverwrite bindgenBackendConfig)
89+
fsActions
8690
return value
8791
where
8892
tracerConfigSafe :: TracerConfig SafeLevel a
@@ -99,10 +103,23 @@ hsBindgen
99103
-------------------------------------------------------------------------------}
100104

101105
-- | Execute collected file system actions based on FileOverwritePolicy
102-
executeFileSystemActions :: FileOverwritePolicy -> [FileSystemAction] -> IO ()
103-
executeFileSystemActions fop actions = do
106+
executeFileSystemActions :: OutputDirPolicy -> FileOverwritePolicy -> [FileSystemAction] -> IO ()
107+
executeFileSystemActions outputDirPolicy fop actions = do
108+
-- Get the first directory path that exists if any
109+
mbDirPath <-
110+
foldrM (\f mbp -> do
111+
case f of
112+
CreateDir path
113+
| Just _ <- mbp -> pure mbp
114+
| otherwise -> do
115+
fileExists <- doesDirectoryExist path
116+
pure $ if fileExists
117+
then Just path
118+
else mbp
119+
_ -> pure mbp
120+
) Nothing actions
104121
-- Get the first file path that exists if any
105-
mbPath <-
122+
mbFilePath <-
106123
foldrM (\f mbp -> do
107124
case f of
108125
WriteFile _ path _
@@ -112,11 +129,19 @@ executeFileSystemActions fop actions = do
112129
pure $ if fileExists
113130
then Just path
114131
else mbp
132+
_ -> pure mbp
115133
) Nothing actions
134+
case outputDirPolicy of
135+
DoNotCreateDirStructure
136+
| Just outputDir <- mbDirPath ->
137+
throwIO (OutputDirectoryMissingException outputDir)
138+
_ -> pure ()
116139
case fop of
117140
ProtectExistingFiles
118-
| Just path <- mbPath -> throwIO (FileAlreadyExistsException path)
141+
| Just path <- mbFilePath -> throwIO (FileAlreadyExistsException path)
119142
_ -> forM_ actions $ \case
143+
CreateDir outputDir ->
144+
createDirectoryIfMissing True outputDir
120145
WriteFile _ path content -> do
121146
createDirectoryIfMissing True (takeDirectory path)
122147
case content of

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

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,8 @@ data Artefact (a :: Star) where
6565
FinalModuleSafe :: Artefact HsModule
6666
FinalModuleUnsafe :: Artefact HsModule
6767
FinalModules :: Artefact (ByCategory HsModule)
68-
-- * File writes
68+
-- * File system actions
69+
DirectoryCreate :: FilePath -> Artefact ()
6970
FileWrite :: String -> FilePath -> FileContent -> Artefact ()
7071
-- * Lift and sequence artefacts
7172
Lift :: ArtefactM a -> Artefact a
@@ -102,7 +103,8 @@ data ArtefactEnv = ArtefactEnv {
102103

103104
-- | A file system action to be executed
104105
data FileSystemAction =
105-
WriteFile String FilePath FileContent
106+
CreateDir FilePath
107+
| WriteFile String FilePath FileContent
106108

107109
-- | Content to be written to a file
108110
--
@@ -182,7 +184,8 @@ runArtefacts
182184
case mbError of
183185
Just err -> throwError err
184186
Nothing -> runArtefact $ f r
185-
-- File writes.
187+
-- File system operations.
188+
DirectoryCreate path -> lift $ tell [CreateDir path]
186189
FileWrite what path content -> lift $ tell [WriteFile what path content]
187190

188191
{-------------------------------------------------------------------------------

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

Lines changed: 5 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,8 @@ module HsBindgen.Config (
66
, UniqueId(..)
77
, toBindgenConfig
88
, defBaseModuleName
9-
10-
-- * Client
11-
, OutputDirPolicy(..)
12-
, FileOverwritePolicy(..)
13-
9+
, OutputDirPolicy (..)
10+
, FileOverwritePolicy (..)
1411
-- * Template Haskell
1512
, ConfigTH(..)
1613
)
@@ -54,8 +51,8 @@ data Config_ path = Config {
5451
deriving stock (Functor, Foldable, Traversable)
5552
deriving anyclass (Default)
5653

57-
toBindgenConfig :: Config_ FilePath -> FileOverwritePolicy -> UniqueId -> Hs.ModuleName -> BindgenConfig
58-
toBindgenConfig Config{..} fop uniqueId hsModuleName =
54+
toBindgenConfig :: Config_ FilePath -> OutputDirPolicy -> FileOverwritePolicy -> UniqueId -> Hs.ModuleName -> BindgenConfig
55+
toBindgenConfig Config{..} outputDirPolicy fop uniqueId hsModuleName =
5956
BindgenConfig bootConfig frontendConfig backendConfig
6057
where
6158
bootConfig = BootConfig {
@@ -76,23 +73,10 @@ toBindgenConfig Config{..} fop uniqueId hsModuleName =
7673
, backendHaddockConfig = HaddockConfig {
7774
pathStyle = haddockPathStyle
7875
}
76+
, backendOutputDirPolicy = outputDirPolicy
7977
, backendFileOverwrite = fop
8078
}
8179

82-
{-------------------------------------------------------------------------------
83-
Client
84-
-------------------------------------------------------------------------------}
85-
86-
-- NOTE: Stable public API.
87-
88-
data OutputDirPolicy
89-
= CreateDirStructure
90-
| DoNotCreateDirStructure
91-
deriving (Show, Eq)
92-
93-
instance Default OutputDirPolicy where
94-
def = DoNotCreateDirStructure
95-
9680
{-------------------------------------------------------------------------------
9781
Template Haskell
9882
-------------------------------------------------------------------------------}

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

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,8 @@ module HsBindgen.Config.Internal
99
, BackendConfig (..)
1010
, BackendConfigMsg (..)
1111
, checkBackendConfig
12+
-- * Output directory policy
13+
, OutputDirPolicy (..)
1214
-- * File overwrite policy
1315
, FileOverwritePolicy (..)
1416
-- * Re-exports
@@ -90,6 +92,7 @@ data FrontendConfig = FrontendConfig {
9092
data BackendConfig = BackendConfig {
9193
backendTranslationConfig :: TranslationConfig
9294
, backendHaddockConfig :: HaddockConfig
95+
, backendOutputDirPolicy :: OutputDirPolicy
9396
, backendFileOverwrite :: FileOverwritePolicy
9497
}
9598
deriving stock (Show, Eq, Generic)
@@ -106,6 +109,18 @@ data BackendConfigMsg = BackendConfigUniqueId UniqueIdMsg
106109
deriving stock (Show, Generic)
107110
deriving anyclass (PrettyForTrace, IsTrace Level)
108111

112+
{-------------------------------------------------------------------------------
113+
Output dir policy
114+
-------------------------------------------------------------------------------}
115+
116+
data OutputDirPolicy
117+
= CreateDirStructure
118+
| DoNotCreateDirStructure
119+
deriving (Show, Eq)
120+
121+
instance Default OutputDirPolicy where
122+
def = DoNotCreateDirStructure
123+
109124
{-------------------------------------------------------------------------------
110125
File overwrite policy
111126
-------------------------------------------------------------------------------}

0 commit comments

Comments
 (0)