Skip to content

Commit 1068755

Browse files
emilypiemilypi
committed
Rewrite cabal init command
* Restructures the `cabal init` command to fix historical issues. All flags are preserved. * Codebases for interactive and non-interactive flags are disentangled. * Data structures now exploit relevant stanza structure and formatters only care about stanza data * Heuristics and prompts have a pure and impure implementation. * Sets default behavior to be `--interactive` as opposed to `--non-interactive`. * Rewrites tests to achieve 98% coverage * Golden files now test every stanza individually * Every flag is covered by a unit test * Interactive, simple, and non-interactive workflows are covered.
1 parent 4f8aeb2 commit 1068755

File tree

86 files changed

+7286
-2448
lines changed

Some content is hidden

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

86 files changed

+7286
-2448
lines changed

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

Lines changed: 9 additions & 4 deletions
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

Lines changed: 2 additions & 2 deletions
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

Lines changed: 5 additions & 6 deletions
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

Lines changed: 12 additions & 2 deletions
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

Lines changed: 23 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@
1313
-- Entry point to the default cabal-install front-end.
1414
-----------------------------------------------------------------------------
1515

16+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
1617
module Main (main) where
1718

1819
import Distribution.Client.Setup
@@ -109,11 +110,12 @@ import Distribution.Client.Sandbox (loadConfigOrSandboxConfig
109110
,updateInstallDirs)
110111
import Distribution.Client.Tar (createTarGzFile)
111112
import Distribution.Client.Types.Credentials (Password (..))
112-
import Distribution.Client.Init (initCabal)
113+
import Distribution.Client.Init (initCmd)
113114
import Distribution.Client.Manpage (manpageCmd)
114115
import Distribution.Client.ManpageFlags (ManpageFlags (..))
115116
import Distribution.Client.Utils (determineNumJobs
116117
,relaxEncodingErrors
118+
,cabalInstallVersion
117119
)
118120

119121
import Distribution.Package (packageId)
@@ -219,9 +221,9 @@ mainWorker args = do
219221
++ "defaults if you run 'cabal update'."
220222
printOptionsList = putStr . unlines
221223
printErrors errs = dieNoVerbosity $ intercalate "\n" errs
222-
printNumericVersion = putStrLn $ display cabalVersion
224+
printNumericVersion = putStrLn $ display cabalInstallVersion
223225
printVersion = putStrLn $ "cabal-install version "
224-
++ display cabalVersion
226+
++ display cabalInstallVersion
225227
++ "\ncompiled using version "
226228
++ display cabalVersion
227229
++ " of the Cabal library "
@@ -918,24 +920,24 @@ unpackAction getFlags extraArgs globalFlags = do
918920
getAction getFlags extraArgs globalFlags
919921

920922
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'
923+
initAction initFlags extraArgs globalFlags
924+
| not (null extraArgs) =
925+
die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
926+
| otherwise = do
927+
confFlags <- loadConfigOrSandboxConfig verbosity globalFlags
928+
-- override with `--with-compiler` from CLI if available
929+
let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
930+
initFlags' = savedInitFlags confFlags `mappend` initFlags
931+
globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags
932+
933+
(comp, _, progdb) <- configCompilerAux' confFlags'
934+
935+
withRepoContext verbosity globalFlags' $ \repoContext ->
936+
initCmd verbosity (configPackageDB' confFlags')
937+
repoContext comp progdb initFlags'
938+
where
939+
verbosity = fromFlag (initVerbosity initFlags)
940+
compFlags = mempty { configHcPath = initHcPath initFlags }
939941

940942
userConfigAction :: UserConfigFlags -> [String] -> Action
941943
userConfigAction ucflags extraArgs globalFlags = do

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -841,8 +841,8 @@ commentSavedConfig = do
841841
IT.cabalVersion = toFlag IT.defaultCabalVersion,
842842
IT.language = toFlag Haskell2010,
843843
IT.license = NoFlag,
844-
IT.sourceDirs = Just [IT.defaultSourceDir],
845-
IT.applicationDirs = Just [IT.defaultApplicationDir]
844+
IT.sourceDirs = Flag [IT.defaultSourceDir],
845+
IT.applicationDirs = Flag [IT.defaultApplicationDir]
846846
},
847847
savedInstallFlags = defaultInstallFlags,
848848
savedClientInstallFlags= defaultClientInstallFlags,

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

Lines changed: 2 additions & 2 deletions
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

Lines changed: 48 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -13,13 +13,53 @@
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 = case interactive initFlags of
60+
NoFlag -> Interactive.createProject
61+
Flag True
62+
| fromFlagOrDefault False (simpleProject initFlags) ->
63+
Simple.createProject
64+
| otherwise -> Interactive.createProject
65+
Flag False -> NonInteractive.createProject

0 commit comments

Comments
 (0)