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.
haskell · May 4, 2021 · 1068755 · 1068755
1 parent 4f8aeb2
commit 1068755
Show file tree

Hide file tree

Showing 86 changed files with 7,286 additions and 2,448 deletions.
diff --git a/Cabal/src/Distribution/Fields/Pretty.hs b/Cabal/src/Distribution/Fields/Pretty.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE LambdaCase #-}
 -- | Cabal-like file AST types: 'Field', 'Section' etc,
 --
 -- This (intermediate) data type is used for pretty-printing.
@@ -35,6 +36,7 @@ import qualified Text.PrettyPrint as PP
 data PrettyField ann
     = PrettyField ann FieldName PP.Doc
     | PrettySection ann FieldName [PP.Doc] [PrettyField ann]
+    | PrettyEmpty
   deriving (Functor, Foldable, Traversable)
 
 -- | Prettyprint a list of fields.
@@ -74,8 +76,8 @@ showFields' rann post n = unlines . renderFields (Opts rann indent post)
     indent2 xs = ' ' : ' ' : xs
 
 data Opts ann = Opts
-  { _optAnnotation ::(ann -> [String])
-  , _optIndent ::(String -> String)
+  { _optAnnotation :: ann -> [String]
+  , _optIndent :: String -> String
   , _optPostprocess :: ann -> [String] -> [String]
   }
 
@@ -87,6 +89,7 @@ renderFields opts fields = flattenBlocks $ map (renderField opts len) fields
     maxNameLength !acc []                            = acc
     maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest
     maxNameLength !acc (PrettySection {}   : rest)   = maxNameLength acc rest
+    maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest
 
 -- | Block of lines,
 -- 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)
     ++
     post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
     ++
-    (map indent $ renderFields opts fields)
+    map indent (renderFields opts fields)
+
+renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty
 
 -------------------------------------------------------------------------------
 -- Transform from Parsec.Field
@@ -161,7 +166,7 @@ prettyFieldLines _ fls = PP.vcat
 
 -- | Used in 'fromParsecFields'.
 prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
-prettySectionArgs _ = map $ \sa -> case sa of
+prettySectionArgs _ = map $ \case
     P.SecArgName _ bs  -> showToken $ fromUTF8BS bs
     P.SecArgStr _ bs   -> showToken $ fromUTF8BS bs
     P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs

diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
@@ -118,7 +118,7 @@ runTest pkg_descr lbi clbi flags suite = do
     let suiteLog = buildLog exit
 
     -- Write summary notice to log file indicating start of test suite
-    appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName'
+    appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
 
     -- Append contents of temporary log file to the final human-
     -- readable log file
@@ -144,7 +144,7 @@ runTest pkg_descr lbi clbi flags suite = do
     when isCoverageEnabled $
         case PD.library pkg_descr of
             Nothing ->
-                die' verbosity $ "Error: test coverage is only supported for packages with a library component"
+                die' verbosity "Error: test coverage is only supported for packages with a library component"
 
             Just library ->
                 markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library

diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -158,12 +158,11 @@ runTest pkg_descr lbi clbi flags suite = do
     notice verbosity $ summarizeSuiteFinish suiteLog
 
     when isCoverageEnabled $
-        case PD.library pkg_descr of
-            Nothing ->
-                die' verbosity $ "Error: test coverage is only supported for packages with a library component"
-
-            Just library ->
-                markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+      case PD.library pkg_descr of
+        Nothing ->
+          die' verbosity "Error: test coverage is only supported for packages with a library component"
+        Just library ->
+          markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
 
     return suiteLog
   where

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -119,12 +119,16 @@ library
         Distribution.Client.IndexUtils.IndexState
         Distribution.Client.IndexUtils.Timestamp
         Distribution.Client.Init
-        Distribution.Client.Init.Command
         Distribution.Client.Init.Defaults
         Distribution.Client.Init.FileCreators
-        Distribution.Client.Init.Heuristics
+        Distribution.Client.Init.FlagExtractors
+        Distribution.Client.Init.Format
+        Distribution.Client.Init.Interactive.Command
+        Distribution.Client.Init.NonInteractive.Command
+        Distribution.Client.Init.NonInteractive.Heuristics
         Distribution.Client.Init.Licenses
         Distribution.Client.Init.Prompt
+        Distribution.Client.Init.Simple
         Distribution.Client.Init.Types
         Distribution.Client.Init.Utils
         Distribution.Client.Install
@@ -203,6 +207,7 @@ library
         directory  >= 1.2.2.0  && < 1.4,
         echo       >= 0.1.3    && < 0.2,
         edit-distance >= 0.2.2 && < 0.3,
+        exceptions,
         filepath   >= 1.4.0.0  && < 1.5,
         hashable   >= 1.0      && < 1.4,
         HTTP       >= 4000.1.5 && < 4000.4,
@@ -273,6 +278,11 @@ Test-Suite unit-tests
       UnitTests.Distribution.Client.Glob
       UnitTests.Distribution.Client.GZipUtils
       UnitTests.Distribution.Client.Init
+      UnitTests.Distribution.Client.Init.Golden
+      UnitTests.Distribution.Client.Init.Interactive
+      UnitTests.Distribution.Client.Init.NonInteractive
+      UnitTests.Distribution.Client.Init.Simple
+      UnitTests.Distribution.Client.Init.Utils
       UnitTests.Distribution.Client.Store
       UnitTests.Distribution.Client.Tar
       UnitTests.Distribution.Client.TreeDiffInstances

diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs
@@ -13,6 +13,7 @@
 -- Entry point to the default cabal-install front-end.
 -----------------------------------------------------------------------------
 
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
 module Main (main) where
 
 import Distribution.Client.Setup
@@ -109,11 +110,12 @@ import Distribution.Client.Sandbox            (loadConfigOrSandboxConfig
                                               ,updateInstallDirs)
 import Distribution.Client.Tar                (createTarGzFile)
 import Distribution.Client.Types.Credentials  (Password (..))
-import Distribution.Client.Init               (initCabal)
+import Distribution.Client.Init               (initCmd)
 import Distribution.Client.Manpage            (manpageCmd)
 import Distribution.Client.ManpageFlags       (ManpageFlags (..))
 import Distribution.Client.Utils              (determineNumJobs
                                               ,relaxEncodingErrors
+                                              ,cabalInstallVersion
                                               )
 
 import Distribution.Package (packageId)
@@ -219,9 +221,9 @@ mainWorker args = do
                   ++ "defaults if you run 'cabal update'."
     printOptionsList = putStr . unlines
     printErrors errs = dieNoVerbosity $ intercalate "\n" errs
-    printNumericVersion = putStrLn $ display cabalVersion
+    printNumericVersion = putStrLn $ display cabalInstallVersion
     printVersion        = putStrLn $ "cabal-install version "
-                                  ++ display cabalVersion
+                                  ++ display cabalInstallVersion
                                   ++ "\ncompiled using version "
                                   ++ display cabalVersion
                                   ++ " of the Cabal library "
@@ -918,24 +920,24 @@ unpackAction getFlags extraArgs globalFlags = do
   getAction getFlags extraArgs globalFlags
 
 initAction :: InitFlags -> [String] -> Action
-initAction initFlags extraArgs globalFlags = do
-  let verbosity = fromFlag (initVerbosity initFlags)
-  when (extraArgs /= []) $
-    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
-  config <- loadConfigOrSandboxConfig verbosity globalFlags
-  let configFlags  = savedConfigureFlags config `mappend`
-                     -- override with `--with-compiler` from CLI if available
-                     mempty { configHcPath = initHcPath initFlags }
-  let initFlags'   = savedInitFlags      config `mappend` initFlags
-  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags
-  (comp, _, progdb) <- configCompilerAux' configFlags
-  withRepoContext verbosity globalFlags' $ \repoContext ->
-    initCabal verbosity
-            (configPackageDB' configFlags)
-            repoContext
-            comp
-            progdb
-            initFlags'
+initAction initFlags extraArgs globalFlags
+    | not (null extraArgs) =
+      die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
+    | otherwise = do
+      confFlags <- loadConfigOrSandboxConfig verbosity globalFlags
+      -- override with `--with-compiler` from CLI if available
+      let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
+          initFlags' = savedInitFlags confFlags `mappend` initFlags
+          globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags
+
+      (comp, _, progdb) <- configCompilerAux' confFlags'
+
+      withRepoContext verbosity globalFlags' $ \repoContext ->
+        initCmd verbosity (configPackageDB' confFlags')
+          repoContext comp progdb initFlags'
+  where
+    verbosity = fromFlag (initVerbosity initFlags)
+    compFlags = mempty { configHcPath = initHcPath initFlags }
 
 userConfigAction :: UserConfigFlags -> [String] -> Action
 userConfigAction ucflags extraArgs globalFlags = do

diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
@@ -841,8 +841,8 @@ commentSavedConfig = do
             IT.cabalVersion    = toFlag IT.defaultCabalVersion,
             IT.language        = toFlag Haskell2010,
             IT.license         = NoFlag,
-            IT.sourceDirs      = Just [IT.defaultSourceDir],
-            IT.applicationDirs = Just [IT.defaultApplicationDir]
+            IT.sourceDirs      = Flag [IT.defaultSourceDir],
+            IT.applicationDirs = Flag [IT.defaultApplicationDir]
             },
         savedInstallFlags      = defaultInstallFlags,
         savedClientInstallFlags= defaultClientInstallFlags,

diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs
@@ -18,7 +18,7 @@ module Distribution.Client.GenBounds (
 import Prelude ()
 import Distribution.Client.Compat.Prelude
 
-import Distribution.Client.Init
+import Distribution.Client.Utils
          ( incVersion )
 import Distribution.Client.Freeze
          ( getFreezePkgs )
@@ -93,7 +93,7 @@ genBounds
     -> GlobalFlags
     -> FreezeFlags
     -> IO ()
-genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do 
+genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do
     let cinfo = compilerInfo comp
 
     cwd <- getCurrentDirectory

diff --git a/cabal-install/src/Distribution/Client/Init.hs b/cabal-install/src/Distribution/Client/Init.hs
@@ -13,13 +13,53 @@
 --
 -----------------------------------------------------------------------------
 
-module Distribution.Client.Init (
+module Distribution.Client.Init
+( -- * Commands
+  initCmd
+) where
 
-    -- * Commands
-    initCabal
-  , incVersion
+import qualified Distribution.Client.Init.Interactive.Command as Interactive
+import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive
+import qualified Distribution.Client.Init.Simple as Simple
+import Distribution.Verbosity
+import Distribution.Client.Setup (RepoContext)
+import Distribution.Simple.Compiler
+import Distribution.Simple.Program (ProgramDb)
+import Distribution.Client.Init.Types
+import Distribution.Simple.Setup
+import Distribution.Client.IndexUtils
+import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))
+import Distribution.Client.Init.FileCreators
 
-  ) where
-
-import Distribution.Client.Init.Command
-  ( initCabal, incVersion )
+-- | This is the main driver for the init script.
+--
+initCmd
+    :: Verbosity
+    -> PackageDBStack
+    -> RepoContext
+    -> Compiler
+    -> ProgramDb
+    -> InitFlags
+    -> IO ()
+initCmd v packageDBs repoCtxt comp progdb initFlags = do
+    installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
+    sourcePkgDb <- getSourcePackages v repoCtxt
+    hSetBuffering stdout NoBuffering
+    settings <- createProject v installedPkgIndex sourcePkgDb initFlags
+    writeProject settings
+  where
+    -- When no flag is set, default to interactive.
+    --
+    -- When `--interactive` is set, if we also set `--simple`,
+    -- then we interactive generate a simple project with sensible defaults.
+    --
+    -- If `--simple` is not set, default to interactive. When the flag
+    -- is explicitly set to `--non-interactive`, then we choose non-interactive.
+    --
+    createProject = case interactive initFlags of
+      NoFlag -> Interactive.createProject
+      Flag True
+        | fromFlagOrDefault False (simpleProject initFlags) ->
+          Simple.createProject
+        | otherwise -> Interactive.createProject
+      Flag False -> NonInteractive.createProject