Skip to content

Commit a39d590

Browse files
emilypiemilypi
authored
Merge pull request #7344 from ptkato/cabal-init-rewrite
Cabal Init Omnibus
2 parents 2596f85 + 1ae7433 commit a39d590

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

60 files changed

+6856
-2452
lines changed

‎Cabal/src/Distribution/Fields/Pretty.hs

+9-4
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveFunctor #-}
33
{-# LANGUAGE DeriveFoldable #-}
44
{-# LANGUAGE DeriveTraversable #-}
5+
{-# LANGUAGE LambdaCase #-}
56
-- | Cabal-like file AST types: 'Field', 'Section' etc,
67
--
78
-- This (intermediate) data type is used for pretty-printing.
@@ -35,6 +36,7 @@ import qualified Text.PrettyPrint as PP
3536
data PrettyField ann
3637
= PrettyField ann FieldName PP.Doc
3738
| PrettySection ann FieldName [PP.Doc] [PrettyField ann]
39+
| PrettyEmpty
3840
deriving (Functor, Foldable, Traversable)
3941

4042
-- | Prettyprint a list of fields.
@@ -74,8 +76,8 @@ showFields' rann post n = unlines . renderFields (Opts rann indent post)
7476
indent2 xs = ' ' : ' ' : xs
7577

7678
data Opts ann = Opts
77-
{ _optAnnotation ::(ann -> [String])
78-
, _optIndent ::(String -> String)
79+
{ _optAnnotation :: ann -> [String]
80+
, _optIndent :: String -> String
7981
, _optPostprocess :: ann -> [String] -> [String]
8082
}
8183

@@ -87,6 +89,7 @@ renderFields opts fields = flattenBlocks $ map (renderField opts len) fields
8789
maxNameLength !acc [] = acc
8890
maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest
8991
maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest
92+
maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest
9093

9194
-- | Block of lines,
9295
-- Boolean parameter tells whether block should be surrounded by empty lines
@@ -134,7 +137,9 @@ renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields)
134137
++
135138
post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
136139
++
137-
(map indent $ renderFields opts fields)
140+
map indent (renderFields opts fields)
141+
142+
renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty
138143

139144
-------------------------------------------------------------------------------
140145
-- Transform from Parsec.Field
@@ -161,7 +166,7 @@ prettyFieldLines _ fls = PP.vcat
161166

162167
-- | Used in 'fromParsecFields'.
163168
prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
164-
prettySectionArgs _ = map $ \sa -> case sa of
169+
prettySectionArgs _ = map $ \case
165170
P.SecArgName _ bs -> showToken $ fromUTF8BS bs
166171
P.SecArgStr _ bs -> showToken $ fromUTF8BS bs
167172
P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs

‎Cabal/src/Distribution/Simple/Test/ExeV10.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -118,7 +118,7 @@ runTest pkg_descr lbi clbi flags suite = do
118118
let suiteLog = buildLog exit
119119

120120
-- Write summary notice to log file indicating start of test suite
121-
appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName'
121+
appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
122122

123123
-- Append contents of temporary log file to the final human-
124124
-- readable log file
@@ -144,7 +144,7 @@ runTest pkg_descr lbi clbi flags suite = do
144144
when isCoverageEnabled $
145145
case PD.library pkg_descr of
146146
Nothing ->
147-
die' verbosity $ "Error: test coverage is only supported for packages with a library component"
147+
die' verbosity "Error: test coverage is only supported for packages with a library component"
148148

149149
Just library ->
150150
markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library

‎Cabal/src/Distribution/Simple/Test/LibV09.hs

+5-6
Original file line numberDiff line numberDiff line change
@@ -158,12 +158,11 @@ runTest pkg_descr lbi clbi flags suite = do
158158
notice verbosity $ summarizeSuiteFinish suiteLog
159159

160160
when isCoverageEnabled $
161-
case PD.library pkg_descr of
162-
Nothing ->
163-
die' verbosity $ "Error: test coverage is only supported for packages with a library component"
164-
165-
Just library ->
166-
markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
161+
case PD.library pkg_descr of
162+
Nothing ->
163+
die' verbosity "Error: test coverage is only supported for packages with a library component"
164+
Just library ->
165+
markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
167166

168167
return suiteLog
169168
where

‎cabal-install/cabal-install.cabal

+12-2
Original file line numberDiff line numberDiff line change
@@ -119,12 +119,16 @@ library
119119
Distribution.Client.IndexUtils.IndexState
120120
Distribution.Client.IndexUtils.Timestamp
121121
Distribution.Client.Init
122-
Distribution.Client.Init.Command
123122
Distribution.Client.Init.Defaults
124123
Distribution.Client.Init.FileCreators
125-
Distribution.Client.Init.Heuristics
124+
Distribution.Client.Init.FlagExtractors
125+
Distribution.Client.Init.Format
126+
Distribution.Client.Init.Interactive.Command
127+
Distribution.Client.Init.NonInteractive.Command
128+
Distribution.Client.Init.NonInteractive.Heuristics
126129
Distribution.Client.Init.Licenses
127130
Distribution.Client.Init.Prompt
131+
Distribution.Client.Init.Simple
128132
Distribution.Client.Init.Types
129133
Distribution.Client.Init.Utils
130134
Distribution.Client.Install
@@ -203,6 +207,7 @@ library
203207
directory >= 1.2.2.0 && < 1.4,
204208
echo >= 0.1.3 && < 0.2,
205209
edit-distance >= 0.2.2 && < 0.3,
210+
exceptions,
206211
filepath >= 1.4.0.0 && < 1.5,
207212
hashable >= 1.0 && < 1.4,
208213
HTTP >= 4000.1.5 && < 4000.4,
@@ -273,6 +278,11 @@ Test-Suite unit-tests
273278
UnitTests.Distribution.Client.Glob
274279
UnitTests.Distribution.Client.GZipUtils
275280
UnitTests.Distribution.Client.Init
281+
UnitTests.Distribution.Client.Init.Golden
282+
UnitTests.Distribution.Client.Init.Interactive
283+
UnitTests.Distribution.Client.Init.NonInteractive
284+
UnitTests.Distribution.Client.Init.Simple
285+
UnitTests.Distribution.Client.Init.Utils
276286
UnitTests.Distribution.Client.Store
277287
UnitTests.Distribution.Client.Tar
278288
UnitTests.Distribution.Client.TreeDiffInstances

‎cabal-install/main/Main.hs

+22-21
Original file line numberDiff line numberDiff line change
@@ -109,11 +109,12 @@ import Distribution.Client.Sandbox (loadConfigOrSandboxConfig
109109
,updateInstallDirs)
110110
import Distribution.Client.Tar (createTarGzFile)
111111
import Distribution.Client.Types.Credentials (Password (..))
112-
import Distribution.Client.Init (initCabal)
112+
import Distribution.Client.Init (initCmd)
113113
import Distribution.Client.Manpage (manpageCmd)
114114
import Distribution.Client.ManpageFlags (ManpageFlags (..))
115115
import Distribution.Client.Utils (determineNumJobs
116116
,relaxEncodingErrors
117+
,cabalInstallVersion
117118
)
118119

119120
import Distribution.Package (packageId)
@@ -219,9 +220,9 @@ mainWorker args = do
219220
++ "defaults if you run 'cabal update'."
220221
printOptionsList = putStr . unlines
221222
printErrors errs = dieNoVerbosity $ intercalate "\n" errs
222-
printNumericVersion = putStrLn $ display cabalVersion
223+
printNumericVersion = putStrLn $ display cabalInstallVersion
223224
printVersion = putStrLn $ "cabal-install version "
224-
++ display cabalVersion
225+
++ display cabalInstallVersion
225226
++ "\ncompiled using version "
226227
++ display cabalVersion
227228
++ " of the Cabal library "
@@ -918,24 +919,24 @@ unpackAction getFlags extraArgs globalFlags = do
918919
getAction getFlags extraArgs globalFlags
919920

920921
initAction :: InitFlags -> [String] -> Action
921-
initAction initFlags extraArgs globalFlags = do
922-
let verbosity = fromFlag (initVerbosity initFlags)
923-
when (extraArgs /= []) $
924-
die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
925-
config <- loadConfigOrSandboxConfig verbosity globalFlags
926-
let configFlags = savedConfigureFlags config `mappend`
927-
-- override with `--with-compiler` from CLI if available
928-
mempty { configHcPath = initHcPath initFlags }
929-
let initFlags' = savedInitFlags config `mappend` initFlags
930-
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
931-
(comp, _, progdb) <- configCompilerAux' configFlags
932-
withRepoContext verbosity globalFlags' $ \repoContext ->
933-
initCabal verbosity
934-
(configPackageDB' configFlags)
935-
repoContext
936-
comp
937-
progdb
938-
initFlags'
922+
initAction initFlags extraArgs globalFlags
923+
| not (null extraArgs) =
924+
die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
925+
| otherwise = do
926+
confFlags <- loadConfigOrSandboxConfig verbosity globalFlags
927+
-- override with `--with-compiler` from CLI if available
928+
let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
929+
initFlags' = savedInitFlags confFlags `mappend` initFlags
930+
globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags
931+
932+
(comp, _, progdb) <- configCompilerAux' confFlags'
933+
934+
withRepoContext verbosity globalFlags' $ \repoContext ->
935+
initCmd verbosity (configPackageDB' confFlags')
936+
repoContext comp progdb initFlags'
937+
where
938+
verbosity = fromFlag (initVerbosity initFlags)
939+
compFlags = mempty { configHcPath = initHcPath initFlags }
939940

940941
userConfigAction :: UserConfigFlags -> [String] -> Action
941942
userConfigAction ucflags extraArgs globalFlags = do

‎cabal-install/src/Distribution/Client/Config.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -264,6 +264,7 @@ instance Semigroup SavedConfig where
264264
IT.email = combine IT.email,
265265
IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules,
266266
IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc,
267+
IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc,
267268
IT.homepage = combine IT.homepage,
268269
IT.initHcPath = combine IT.initHcPath,
269270
IT.initVerbosity = combine IT.initVerbosity,
@@ -841,8 +842,8 @@ commentSavedConfig = do
841842
IT.cabalVersion = toFlag IT.defaultCabalVersion,
842843
IT.language = toFlag Haskell2010,
843844
IT.license = NoFlag,
844-
IT.sourceDirs = Just [IT.defaultSourceDir],
845-
IT.applicationDirs = Just [IT.defaultApplicationDir]
845+
IT.sourceDirs = Flag [IT.defaultSourceDir],
846+
IT.applicationDirs = Flag [IT.defaultApplicationDir]
846847
},
847848
savedInstallFlags = defaultInstallFlags,
848849
savedClientInstallFlags= defaultClientInstallFlags,

‎cabal-install/src/Distribution/Client/GenBounds.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ module Distribution.Client.GenBounds (
1818
import Prelude ()
1919
import Distribution.Client.Compat.Prelude
2020

21-
import Distribution.Client.Init
21+
import Distribution.Client.Utils
2222
( incVersion )
2323
import Distribution.Client.Freeze
2424
( getFreezePkgs )
@@ -93,7 +93,7 @@ genBounds
9393
-> GlobalFlags
9494
-> FreezeFlags
9595
-> IO ()
96-
genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do
96+
genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do
9797
let cinfo = compilerInfo comp
9898

9999
cwd <- getCurrentDirectory

‎cabal-install/src/Distribution/Client/Init.hs

+47-8
Original file line numberDiff line numberDiff line change
@@ -13,13 +13,52 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16-
module Distribution.Client.Init (
16+
module Distribution.Client.Init
17+
( -- * Commands
18+
initCmd
19+
) where
1720

18-
-- * Commands
19-
initCabal
20-
, incVersion
21+
import qualified Distribution.Client.Init.Interactive.Command as Interactive
22+
import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive
23+
import qualified Distribution.Client.Init.Simple as Simple
24+
import Distribution.Verbosity
25+
import Distribution.Client.Setup (RepoContext)
26+
import Distribution.Simple.Compiler
27+
import Distribution.Simple.Program (ProgramDb)
28+
import Distribution.Client.Init.Types
29+
import Distribution.Simple.Setup
30+
import Distribution.Client.IndexUtils
31+
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))
32+
import Distribution.Client.Init.FileCreators
2133

22-
) where
23-
24-
import Distribution.Client.Init.Command
25-
( initCabal, incVersion )
34+
-- | This is the main driver for the init script.
35+
--
36+
initCmd
37+
:: Verbosity
38+
-> PackageDBStack
39+
-> RepoContext
40+
-> Compiler
41+
-> ProgramDb
42+
-> InitFlags
43+
-> IO ()
44+
initCmd v packageDBs repoCtxt comp progdb initFlags = do
45+
installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
46+
sourcePkgDb <- getSourcePackages v repoCtxt
47+
hSetBuffering stdout NoBuffering
48+
settings <- createProject v installedPkgIndex sourcePkgDb initFlags
49+
writeProject settings
50+
where
51+
-- When no flag is set, default to interactive.
52+
--
53+
-- When `--interactive` is set, if we also set `--simple`,
54+
-- then we interactive generate a simple project with sensible defaults.
55+
--
56+
-- If `--simple` is not set, default to interactive. When the flag
57+
-- is explicitly set to `--non-interactive`, then we choose non-interactive.
58+
--
59+
createProject
60+
| fromFlagOrDefault False (simpleProject initFlags) =
61+
Simple.createProject
62+
| otherwise = case interactive initFlags of
63+
Flag False -> NonInteractive.createProject comp
64+
_ -> Interactive.createProject

0 commit comments

Comments
 (0)