packages feed

cabal-install 3.2.0.0 → 3.4.0.0

raw patch · 181 files changed

+8170/−10199 lines, 181 filesdep +regex-basedep +regex-posixdep −networkdep ~Cabaldep ~basedep ~directorysetup-changednew-uploader

Dependencies added: regex-base, regex-posix

Dependencies removed: network

Dependency ranges changed: Cabal, base, directory, hackage-security, random, time

Files

Distribution/Client/BuildReports/Anonymous.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Reporting@@ -17,111 +19,44 @@     Outcome(..),      -- * Constructing and writing reports-    new,+    newBuildReport,      -- * parsing and pretty printing-    parse,-    parseList,-    show,+    parseBuildReport,+    parseBuildReportList,+    showBuildReport, --    showList,   ) where +import Distribution.Client.Compat.Prelude import Prelude ()-import Distribution.Client.Compat.Prelude hiding (show) -import qualified Distribution.Client.Types as BR-         ( BuildOutcome, BuildFailure(..), BuildResult(..)-         , DocsResult(..), TestsResult(..) )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )-import qualified Paths_cabal_install (version)+import Distribution.CabalSpecVersion+import Distribution.Client.BuildReports.Types+import Distribution.Client.Utils              (cabalInstallVersion)+import Distribution.Compiler                  (CompilerId (..))+import Distribution.FieldGrammar+import Distribution.Fields                    (readFields, showFields)+import Distribution.Fields.ParseResult        (ParseResult, parseFatalFailure, runParseResult)+import Distribution.Package                   (PackageIdentifier (..), mkPackageName)+import Distribution.PackageDescription        (FlagAssignment)+import Distribution.Parsec                    (PError (..), zeroPos)+import Distribution.System                    (Arch, OS) -import Distribution.Package-         ( PackageIdentifier(..), mkPackageName )-import Distribution.PackageDescription-         ( FlagName, mkFlagName, unFlagName-         , FlagAssignment, mkFlagAssignment, unFlagAssignment )-import Distribution.Version-         ( mkVersion' )-import Distribution.System-         ( OS, Arch )-import Distribution.Compiler-         ( CompilerId(..) )-import qualified Distribution.Deprecated.Text as Text-         ( Text(disp, parse) )-import Distribution.Deprecated.ParseUtils-         ( FieldDescr(..), ParseResult(..), Field(..)-         , simpleField, listField, ppFields, readFields-         , syntaxError, locatedErrorMsg )-import Distribution.Simple.Utils-         ( comparing )+import qualified Distribution.Client.BuildReports.Lens as L+import qualified Distribution.Client.Types             as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) -import qualified Distribution.Deprecated.ReadP as Parse-         ( ReadP, pfail, munch1, skipSpaces )-import qualified Text.PrettyPrint as Disp-         ( Doc, render, char, text )-import Text.PrettyPrint-         ( (<+>) )+import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BS8 -import Data.Char as Char-         ( isAlpha, isAlphaNum ) -data BuildReport-   = BuildReport {-    -- | The package this build report is about-    package         :: PackageIdentifier,--    -- | The OS and Arch the package was built on-    os              :: OS,-    arch            :: Arch,--    -- | The Haskell compiler (and hopefully version) used-    compiler        :: CompilerId,--    -- | The uploading client, ie cabal-install-x.y.z-    client          :: PackageIdentifier,--    -- | Which configurations flags we used-    flagAssignment  :: FlagAssignment,--    -- | Which dependent packages we were using exactly-    dependencies    :: [PackageIdentifier],--    -- | Did installing work ok?-    installOutcome  :: InstallOutcome,--    --   Which version of the Cabal library was used to compile the Setup.hs---    cabalVersion    :: Version,--    --   Which build tools we were using (with versions)---    tools      :: [PackageIdentifier],--    -- | Configure outcome, did configure work ok?-    docsOutcome     :: Outcome,--    -- | Configure outcome, did configure work ok?-    testsOutcome    :: Outcome-  }--data InstallOutcome-   = PlanningFailed-   | DependencyFailed PackageIdentifier-   | DownloadFailed-   | UnpackFailed-   | SetupFailed-   | ConfigureFailed-   | BuildFailed-   | TestsFailed-   | InstallFailed-   | InstallOk-  deriving Eq--data Outcome = NotTried | Failed | Ok-  deriving Eq+-------------------------------------------------------------------------------+-- New+------------------------------------------------------------------------------- -new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment+newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment     -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport-new os' arch' comp pkgid flags deps result =+newBuildReport os' arch' comp pkgid flags deps result =   BuildReport {     package               = pkgid,     os                    = os',@@ -159,159 +94,64 @@  cabalInstallID :: PackageIdentifier cabalInstallID =-  PackageIdentifier (mkPackageName "cabal-install")-                    (mkVersion' Paths_cabal_install.version)+  PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion --- --------------------------------------------------------------- * External format--- ------------------------------------------------------------+-------------------------------------------------------------------------------+-- FieldGrammar+------------------------------------------------------------------------------- -initialBuildReport :: BuildReport-initialBuildReport = BuildReport {-    package         = requiredField "package",-    os              = requiredField "os",-    arch            = requiredField "arch",-    compiler        = requiredField "compiler",-    client          = requiredField "client",-    flagAssignment  = mempty,-    dependencies    = [],-    installOutcome  = requiredField "install-outcome",---    cabalVersion  = Nothing,---    tools         = [],-    docsOutcome     = NotTried,-    testsOutcome    = NotTried-  }-  where-    requiredField fname = error ("required field: " ++ fname)+fieldDescrs+    :: ( Applicative (g BuildReport), FieldGrammar c g+       , c (Identity Arch)+       , c (Identity CompilerId)+       , c (Identity FlagAssignment)+       , c (Identity InstallOutcome)+       , c (Identity OS)+       , c (Identity Outcome)+       , c (Identity PackageIdentifier)+       , c (List VCat (Identity PackageIdentifier) PackageIdentifier)+       )+    => g BuildReport BuildReport+fieldDescrs = BuildReport+    <$> uniqueField       "package"                           L.package+    <*> uniqueField       "os"                                L.os+    <*> uniqueField       "arch"                              L.arch+    <*> uniqueField       "compiler"                          L.compiler+    <*> uniqueField       "client"                            L.client+    <*> monoidalField     "flags"                             L.flagAssignment+    <*> monoidalFieldAla  "dependencies"       (alaList VCat) L.dependencies+    <*> uniqueField       "install-outcome"                   L.installOutcome+    <*> uniqueField       "docs-outcome"                      L.docsOutcome+    <*> uniqueField       "tests-outcome"                     L.testsOutcome  -- ----------------------------------------------------------------------------- -- Parsing -parse :: String -> Either String BuildReport-parse s = case parseFields s of-  ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror-  ParseOk   _ report -> Right report+parseBuildReport :: BS.ByteString -> Either String BuildReport+parseBuildReport s = case snd $ runParseResult $ parseFields s of+  Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]+  Right report -> Right report -parseFields :: String -> ParseResult BuildReport+parseFields :: BS.ByteString -> ParseResult BuildReport parseFields input = do-  fields <- traverse extractField =<< readFields input-  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)-                       sortedFieldDescrs-                       (sortBy (comparing (\(_,name,_) -> name)) fields)-  checkMerged initialBuildReport merged--  where-    extractField :: Field -> ParseResult (Int, String, String)-    extractField (F line name value)  = return (line, name, value)-    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"-    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"--    checkMerged report [] = return report-    checkMerged report (merged:remaining) = case merged of-      InBoth fieldDescr (line, _name, value) -> do-        report' <- fieldSet fieldDescr line value report-        checkMerged report' remaining-      OnlyInRight (line, name, _) ->-        syntaxError line ("Unrecognized field " ++ name)-      OnlyInLeft  fieldDescr ->-        fail ("Missing field " ++ fieldName fieldDescr)+  fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input+  case partitionFields fields of+    (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs+    _otherwise    -> parseFatalFailure zeroPos "found sections in BuildReport" -parseList :: String -> [BuildReport]-parseList str =-  [ report | Right report <- map parse (split str) ]+parseBuildReportList :: BS.ByteString -> [BuildReport]+parseBuildReportList str =+  [ report | Right report <- map parseBuildReport (split str) ]    where-    split :: String -> [String]-    split = filter (not . null) . unfoldr chunk . lines+    split :: BS.ByteString -> [BS.ByteString]+    split = filter (not . BS.null) . unfoldr chunk . BS8.lines     chunk [] = Nothing-    chunk ls = case break null ls of-                 (r, rs) -> Just (unlines r, dropWhile null rs)+    chunk ls = case break BS.null ls of+                 (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)  -- ----------------------------------------------------------------------------- -- Pretty-printing -show :: BuildReport -> String-show = Disp.render . ppFields fieldDescrs---- -------------------------------------------------------------------------------- Description of the fields, for parsing/printing--fieldDescrs :: [FieldDescr BuildReport]-fieldDescrs =- [ simpleField "package"         Text.disp      Text.parse-                                 package        (\v r -> r { package = v })- , simpleField "os"              Text.disp      Text.parse-                                 os             (\v r -> r { os = v })- , simpleField "arch"            Text.disp      Text.parse-                                 arch           (\v r -> r { arch = v })- , simpleField "compiler"        Text.disp      Text.parse-                                 compiler       (\v r -> r { compiler = v })- , simpleField "client"          Text.disp      Text.parse-                                 client         (\v r -> r { client = v })- , listField   "flags"           dispFlag       parseFlag-                                 (unFlagAssignment . flagAssignment)-                                 (\v r -> r { flagAssignment = mkFlagAssignment v })- , listField   "dependencies"    Text.disp      Text.parse-                                 dependencies   (\v r -> r { dependencies = v })- , simpleField "install-outcome" Text.disp      Text.parse-                                 installOutcome (\v r -> r { installOutcome = v })- , simpleField "docs-outcome"    Text.disp      Text.parse-                                 docsOutcome    (\v r -> r { docsOutcome = v })- , simpleField "tests-outcome"   Text.disp      Text.parse-                                 testsOutcome   (\v r -> r { testsOutcome = v })- ]--sortedFieldDescrs :: [FieldDescr BuildReport]-sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs--dispFlag :: (FlagName, Bool) -> Disp.Doc-dispFlag (fname, True)  =                  Disp.text (unFlagName fname)-dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname)--parseFlag :: Parse.ReadP r (FlagName, Bool)-parseFlag = do-  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')-  case name of-    ('-':flag) -> return (mkFlagName flag, False)-    flag       -> return (mkFlagName flag, True)--instance Text.Text InstallOutcome where-  disp PlanningFailed  = Disp.text "PlanningFailed"-  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid-  disp DownloadFailed  = Disp.text "DownloadFailed"-  disp UnpackFailed    = Disp.text "UnpackFailed"-  disp SetupFailed     = Disp.text "SetupFailed"-  disp ConfigureFailed = Disp.text "ConfigureFailed"-  disp BuildFailed     = Disp.text "BuildFailed"-  disp TestsFailed     = Disp.text "TestsFailed"-  disp InstallFailed   = Disp.text "InstallFailed"-  disp InstallOk       = Disp.text "InstallOk"--  parse = do-    name <- Parse.munch1 Char.isAlphaNum-    case name of-      "PlanningFailed"   -> return PlanningFailed-      "DependencyFailed" -> do Parse.skipSpaces-                               pkgid <- Text.parse-                               return (DependencyFailed pkgid)-      "DownloadFailed"   -> return DownloadFailed-      "UnpackFailed"     -> return UnpackFailed-      "SetupFailed"      -> return SetupFailed-      "ConfigureFailed"  -> return ConfigureFailed-      "BuildFailed"      -> return BuildFailed-      "TestsFailed"      -> return TestsFailed-      "InstallFailed"    -> return InstallFailed-      "InstallOk"        -> return InstallOk-      _                  -> Parse.pfail--instance Text.Text Outcome where-  disp NotTried = Disp.text "NotTried"-  disp Failed   = Disp.text "Failed"-  disp Ok       = Disp.text "Ok"-  parse = do-    name <- Parse.munch1 Char.isAlpha-    case name of-      "NotTried" -> return NotTried-      "Failed"   -> return Failed-      "Ok"       -> return Ok-      _          -> Parse.pfail+showBuildReport :: BuildReport -> String+showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs
+ Distribution/Client/BuildReports/Lens.hs view
@@ -0,0 +1,46 @@+module Distribution.Client.BuildReports.Lens (+    BuildReport,+    module Distribution.Client.BuildReports.Lens,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens+import Prelude ()++import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome)+import Distribution.Compiler                  (CompilerId)+import Distribution.System                    (Arch, OS)+import Distribution.Types.Flag                (FlagAssignment)+import Distribution.Types.PackageId           (PackageIdentifier)++import qualified Distribution.Client.BuildReports.Types as T++package :: Lens' BuildReport PackageIdentifier+package f s = fmap (\x -> s { T.package = x }) (f (T.package s))++os :: Lens' BuildReport OS+os f s = fmap (\x -> s { T.os = x }) (f (T.os s))++arch :: Lens' BuildReport Arch+arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s))++compiler :: Lens' BuildReport CompilerId+compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s))++client :: Lens' BuildReport PackageIdentifier+client f s = fmap (\x -> s { T.client = x }) (f (T.client s))++flagAssignment :: Lens' BuildReport FlagAssignment+flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s))++dependencies :: Lens' BuildReport [PackageIdentifier]+dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s))++installOutcome :: Lens' BuildReport InstallOutcome+installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s))++docsOutcome :: Lens' BuildReport Outcome+docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s))++testsOutcome :: Lens' BuildReport Outcome+testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s))
Distribution/Client/BuildReports/Storage.hs view
@@ -1,4 +1,3 @@--- TODO {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- |@@ -25,8 +24,11 @@     fromPlanningFailure,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (BuildReport)  import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan@@ -48,12 +50,11 @@ import Distribution.Compiler          ( CompilerId(..), CompilerInfo(..)  ) import Distribution.Simple.Utils-         ( comparing, equating )+         ( equating ) -import Data.List-         ( groupBy, sortBy )-import Data.Maybe-         ( mapMaybe )+import Data.List.NonEmpty+         ( groupBy )+import qualified Data.List as L import System.FilePath          ( (</>), takeDirectory ) import System.Directory@@ -68,17 +69,18 @@   -- the writes for each report are atomic (under 4k and flush at boundaries)    where-    format r = '\n' : BuildReport.show r ++ "\n"+    format r = '\n' : showBuildReport r ++ "\n"     separate :: [(BuildReport, Maybe Repo)]              -> [(Repo, [BuildReport])]     separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))-             . map concat-             . groupBy (equating (repoName . head))-             . sortBy (comparing (repoName . head))-             . groupBy (equating repoName)+             . map (concatMap toList)+             . L.groupBy (equating (repoName' . head))+             . sortBy (comparing (repoName' . head))+             . groupBy (equating repoName')              . onlyRemote-    repoName (_,_,rrepo) = remoteRepoName rrepo +    repoName' (_,_,rrepo) = remoteRepoName rrepo+     onlyRemote :: [(BuildReport, Maybe Repo)]                -> [(BuildReport, Repo, RemoteRepo)]     onlyRemote rs =@@ -101,7 +103,7 @@   , let output = concatMap format reports'   ]   where-    format r = '\n' : BuildReport.show r ++ "\n"+    format r = '\n' : showBuildReport r ++ "\n"      reportFileName template report =         fromPathTemplate (substPathTemplate env template)@@ -116,7 +118,7 @@                     platform      groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))-                    . groupBy (equating  fst)+                    . L.groupBy (equating  fst)                     . sortBy  (comparing fst)  -- ------------------------------------------------------------@@ -141,13 +143,13 @@ fromPlanPackage (Platform arch os) comp                 (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))                 (Just buildResult) =-      Just ( BuildReport.new os arch comp+      Just ( newBuildReport os arch comp                              (packageId srcPkg) flags                              (map packageId (CD.nonSetupDeps deps))                              buildResult            , extractRepo srcPkg)   where-    extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })+    extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ })                   = Just repo     extractRepo _ = Nothing @@ -157,5 +159,5 @@ fromPlanningFailure :: Platform -> CompilerId     -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] fromPlanningFailure (Platform arch os) comp pkgids flags =-  [ (BuildReport.new os arch comp pkgid flags [] (Left PlanningFailed), Nothing)+  [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)   | pkgid <- pkgids ]
Distribution/Client/BuildReports/Types.hs view
@@ -13,40 +13,154 @@ ----------------------------------------------------------------------------- module Distribution.Client.BuildReports.Types (     ReportLevel(..),-  ) where+    BuildReport (..),+    InstallOutcome(..),+    Outcome(..),+) where -import qualified Distribution.Deprecated.Text as Text-         ( Text(..) )+import Distribution.Client.Compat.Prelude+import Prelude () -import qualified Distribution.Deprecated.ReadP as Parse-         ( pfail, munch1 )-import qualified Text.PrettyPrint as Disp-         ( text )+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp -import Data.Char as Char-         ( isAlpha, toLower )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured)+import Distribution.Compiler           (CompilerId (..))+import Distribution.PackageDescription (FlagAssignment)+import Distribution.System             (Arch, OS)+import Distribution.Types.PackageId    (PackageIdentifier) +-------------------------------------------------------------------------------+-- ReportLevel+-------------------------------------------------------------------------------  data ReportLevel = NoReports | AnonymousReports | DetailedReports-  deriving (Eq, Ord, Enum, Show, Generic)+  deriving (Eq, Ord, Enum, Bounded, Show, Generic)  instance Binary ReportLevel instance Structured ReportLevel -instance Text.Text ReportLevel where-  disp NoReports        = Disp.text "none"-  disp AnonymousReports = Disp.text "anonymous"-  disp DetailedReports  = Disp.text "detailed"-  parse = do-    name <- Parse.munch1 Char.isAlpha+instance Pretty ReportLevel where+  pretty NoReports        = Disp.text "none"+  pretty AnonymousReports = Disp.text "anonymous"+  pretty DetailedReports  = Disp.text "detailed"++instance Parsec ReportLevel where+  parsec = do+    name <- P.munch1 isAlpha     case lowercase name of       "none"       -> return NoReports       "anonymous"  -> return AnonymousReports       "detailed"   -> return DetailedReports-      _            -> Parse.pfail+      _            -> P.unexpected $ "ReportLevel: " ++ name  lowercase :: String -> String-lowercase = map Char.toLower+lowercase = map toLower++-------------------------------------------------------------------------------+-- BuildReport+-------------------------------------------------------------------------------++data BuildReport = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }+  deriving (Eq, Show, Generic)++++-------------------------------------------------------------------------------+-- InstallOutcome+-------------------------------------------------------------------------------++data InstallOutcome+   = PlanningFailed+   | DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | TestsFailed+   | InstallFailed+   | InstallOk+  deriving (Eq, Show, Generic)++instance Pretty InstallOutcome where+  pretty PlanningFailed  = Disp.text "PlanningFailed"+  pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid+  pretty DownloadFailed  = Disp.text "DownloadFailed"+  pretty UnpackFailed    = Disp.text "UnpackFailed"+  pretty SetupFailed     = Disp.text "SetupFailed"+  pretty ConfigureFailed = Disp.text "ConfigureFailed"+  pretty BuildFailed     = Disp.text "BuildFailed"+  pretty TestsFailed     = Disp.text "TestsFailed"+  pretty InstallFailed   = Disp.text "InstallFailed"+  pretty InstallOk       = Disp.text "InstallOk"++instance Parsec InstallOutcome where+  parsec = do+    name <- P.munch1 isAlpha+    case name of+      "PlanningFailed"   -> return PlanningFailed+      "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "TestsFailed"      -> return TestsFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> P.unexpected $ "InstallOutcome: " ++ name++-------------------------------------------------------------------------------+-- Outcome+-------------------------------------------------------------------------------++data Outcome = NotTried | Failed | Ok+  deriving (Eq, Show, Enum, Bounded, Generic)++instance Pretty Outcome where+  pretty NotTried = Disp.text "NotTried"+  pretty Failed   = Disp.text "Failed"+  pretty Ok       = Disp.text "Ok"++instance Parsec Outcome where+  parsec = do+    name <- P.munch1 isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> P.unexpected $ "Outcome: " ++ name
Distribution/Client/BuildReports/Upload.hs view
@@ -7,6 +7,9 @@     , uploadReports     ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ {- import Network.Browser          ( BrowserAction, request, setAllowRedirects )@@ -17,14 +20,10 @@ -} import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) -import Control.Monad-         ( forM_ ) import System.FilePath.Posix          ( (</>) ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (BuildReport)-import Distribution.Deprecated.Text (display)-import Distribution.Verbosity (Verbosity)+import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup@@ -35,7 +34,7 @@  uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () uploadReports verbosity repoCtxt auth uri reports = do-  forM_ reports $ \(report, mbBuildLog) -> do+  for_ reports $ \(report, mbBuildLog) -> do      buildId <- postBuildReport verbosity repoCtxt auth uri report      case mbBuildLog of        Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog@@ -43,9 +42,9 @@  postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId postBuildReport verbosity repoCtxt auth uri buildReport = do-  let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }+  let fullURI = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" }   transport <- repoContextGetTransport repoCtxt-  res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)+  res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth)   case res of     (303, redir) -> return $ undefined redir --TODO parse redir     _ -> die' verbosity "unrecognized response" -- give response@@ -53,7 +52,7 @@ {-   setAllowRedirects False   (_, response) <- request Request {-    rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },+    rqURI     = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" },     rqMethod  = POST,     rqHeaders = [Header HdrContentType   ("text/plain"),                  Header HdrContentLength (show (length body)),
Distribution/Client/Check.hs view
@@ -28,7 +28,6 @@        (parseGenericPackageDescription, runParseResult) import Distribution.Parsec                           (PWarning (..), showPError, showPWarning) import Distribution.Simple.Utils                     (defaultPackageDesc, die', notice, warn)-import Distribution.Verbosity                        (Verbosity) import System.IO                                     (hPutStr, stderr)  import qualified Data.ByteString  as BS
Distribution/Client/CmdBench.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}  -- | cabal-install CLI command: bench --@@ -8,35 +8,38 @@     benchAction,      -- * Internals exposed for testing-    TargetProblem(..),+    componentNotBenchmarkProblem,+    isSubComponentProblem,+    noBenchmarksProblem,     selectPackageTargets,     selectComponentTarget   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages-+         ( renderTargetSelector, showTargetSelector, renderTargetProblem,+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,+           targetSelectorFilter )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )-import qualified Distribution.Client.Setup as Client-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault ) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Utils          ( wrapText, die' ) -import Control.Monad (when)---benchCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                          , HaddockFlags, TestFlags, BenchmarkFlags-                          )-benchCommand = Client.installCommand {+benchCommand :: CommandUI (NixStyleFlags ())+benchCommand = CommandUI {   commandName         = "v2-bench",   commandSynopsis     = "Run benchmarks",   commandUsage        = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ],@@ -62,9 +65,10 @@      ++ "  " ++ pname ++ " v2-bench cname\n"      ++ "    Run the benchmark named cname\n"      ++ "  " ++ pname ++ " v2-bench cname -O2\n"-     ++ "    Run the benchmark built with '-O2' (including local libs used)\n\n"+     ++ "    Run the benchmark built with '-O2' (including local libs used)\n" -     ++ cmdCommonHelpTextNewBuildBeta+   , commandDefaultFlags = defaultNixStyleFlags ()+   , commandOptions      = nixStyleOptions (const [])    }  @@ -75,12 +79,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---benchAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-               , HaddockFlags, TestFlags, BenchmarkFlags )-            -> [String] -> GlobalFlags -> IO ()-benchAction ( configFlags, configExFlags, installFlags-            , haddockFlags, testFlags, benchmarkFlags )-            targetStrings globalFlags = do+benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -102,7 +102,6 @@                      $ resolveTargets                          selectPackageTargets                          selectComponentTarget-                         TargetProblemCommon                          elaboratedPlan                          Nothing                          targetSelectors@@ -119,11 +118,8 @@     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags                    mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags  -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,@@ -133,7 +129,7 @@ -- or fail if there are no benchmarks or no buildable benchmarks. -- selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either TargetProblem [k]+                     -> [AvailableTarget k] -> Either BenchTargetProblem [k] selectPackageTargets targetSelector targets      -- If there are any buildable benchmark targets then we select those@@ -146,7 +142,7 @@      -- If there are no benchmarks but some other targets then we report that   | not (null targets)-  = Left (TargetProblemNoBenchmarks targetSelector)+  = Left (noBenchmarksProblem targetSelector)      -- If there are no targets at all then we report that   | otherwise@@ -168,34 +164,27 @@ -- to the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem k+                      -> AvailableTarget k -> Either BenchTargetProblem k selectComponentTarget subtarget@WholeComponent t   | CBenchName _ <- availableTargetComponentName t-  = either (Left . TargetProblemCommon) return $-           selectComponentTargetBasic subtarget t+  = selectComponentTargetBasic subtarget t   | otherwise-  = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t)-                                             (availableTargetComponentName t))+  = Left (componentNotBenchmarkProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t))  selectComponentTarget subtarget t-  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)-                                      (availableTargetComponentName t)-                                       subtarget)+  = Left (isSubComponentProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. ---data TargetProblem =-     TargetProblemCommon        TargetProblemCommon--     -- | The 'TargetSelector' matches benchmarks but none are buildable-   | TargetProblemNoneEnabled  TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets    TargetSelector-+data BenchProblem =      -- | The 'TargetSelector' matches targets but no benchmarks-   | TargetProblemNoBenchmarks TargetSelector+     TargetProblemNoBenchmarks TargetSelector       -- | The 'TargetSelector' refers to a component that is not a benchmark    | TargetProblemComponentNotBenchmark PackageId ComponentName@@ -204,25 +193,30 @@    | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget   deriving (Eq, Show) -reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "run" problem+type BenchTargetProblem = TargetProblem BenchProblem -renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "benchmark" targetSelector targets+noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem+noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks -renderTargetProblem (TargetProblemNoBenchmarks targetSelector) =-    "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any benchmarks."+componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem+componentNotBenchmarkProblem pkgid name = CustomTargetProblem $+  TargetProblemComponentNotBenchmark pkgid name -renderTargetProblem (TargetProblemNoTargets targetSelector) =+isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem BenchProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderBenchTargetProblem++renderBenchTargetProblem :: BenchTargetProblem -> String+renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =     case targetSelectorFilter targetSelector of       Just kind | kind /= BenchKind         -> "The bench command is for running benchmarks, but the target '"@@ -230,16 +224,26 @@            ++ renderTargetSelector targetSelector ++ "."        _ -> renderTargetProblemNoTargets "benchmark" targetSelector+renderBenchTargetProblem problem =+    renderTargetProblem "benchmark" renderBenchProblem problem -renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) =+renderBenchProblem :: BenchProblem -> String+renderBenchProblem (TargetProblemNoBenchmarks targetSelector) =+    "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any benchmarks."++renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) =     "The bench command is for running benchmarks, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ " from the package "- ++ display pkgid ++ "."+ ++ prettyShow pkgid ++ "."   where     targetSelector = TargetComponent pkgid cname WholeComponent -renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) =     "The bench command can only run benchmarks as a whole, "  ++ "not files or modules within them, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "
Distribution/Client/CmdBuild.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild (@@ -6,7 +7,6 @@     buildAction,      -- * Internals exposed for testing-    TargetProblem(..),     selectPackageTargets,     selectComponentTarget   ) where@@ -15,30 +15,26 @@ import Distribution.Client.Compat.Prelude  import Distribution.Client.ProjectOrchestration+import Distribution.Client.TargetProblem+         ( TargetProblem (..), TargetProblem' ) import Distribution.Client.CmdErrorMessages +import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , liftOptions, yesNoOpt )-import qualified Distribution.Client.Setup as Client-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags-         , Flag(..), toFlag, fromFlag, fromFlagOrDefault )+         ( GlobalFlags, ConfigFlags(..), yesNoOpt )+import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives, option )+         ( CommandUI(..), usageAlternatives, option, optionName ) import Distribution.Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Utils          ( wrapText, die' )  import qualified Data.Map as Map  -buildCommand ::-  CommandUI-  (BuildFlags, ( ConfigFlags, ConfigExFlags-               , InstallFlags, HaddockFlags-               , TestFlags, BenchmarkFlags ))+buildCommand :: CommandUI (NixStyleFlags BuildFlags) buildCommand = CommandUI {   commandName         = "v2-build",   commandSynopsis     = "Compile targets within the project.",@@ -68,26 +64,18 @@      ++ "    Build the component named cname in the project\n"      ++ "  " ++ pname ++ " v2-build cname --enable-profiling\n"      ++ "    Build the component in profiling mode "-     ++ "(including dependencies as needed)\n\n"+     ++ "(including dependencies as needed)\n" -     ++ cmdCommonHelpTextNewBuildBeta,-  commandDefaultFlags =-      (defaultBuildFlags, commandDefaultFlags Client.installCommand),-  commandOptions = \ showOrParseArgs ->-      liftOptions snd setSnd-          (commandOptions Client.installCommand showOrParseArgs) ++-      liftOptions fst setFst-          [ option [] ["only-configure"]-              "Instead of performing a full build just run the configure step"-              buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v })-              (yesNoOpt showOrParseArgs)-          ]+  , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (\showOrParseArgs ->+    [ option [] ["only-configure"]+        "Instead of performing a full build just run the configure step"+        buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v })+        (yesNoOpt showOrParseArgs)+    ])   } -  where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)- data BuildFlags = BuildFlags     { buildOnlyConfigure  :: Flag Bool     }@@ -104,16 +92,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---buildAction ::-  ( BuildFlags-  , ( ConfigFlags, ConfigExFlags, InstallFlags-    , HaddockFlags, TestFlags, BenchmarkFlags ))-  -> [String] -> GlobalFlags -> IO ()-buildAction-  ( buildFlags-  , ( configFlags, configExFlags, installFlags-    , haddockFlags, testFlags, benchmarkFlags ))-            targetStrings globalFlags = do+buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()+buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do     -- TODO: This flags defaults business is ugly     let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags                                  <> buildOnlyConfigure buildFlags)@@ -132,11 +112,10 @@              -- Interpret the targets on the command line as build targets             -- (as opposed to say repl or haddock targets).-            targets <- either (reportTargetProblems verbosity) return+            targets <- either (reportBuildTargetProblems verbosity) return                      $ resolveTargets                          selectPackageTargets                          selectComponentTarget-                         TargetProblemCommon                          elaboratedPlan                          Nothing                          targetSelectors@@ -160,11 +139,8 @@     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags                   mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags  -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,@@ -175,7 +151,7 @@ -- components -- selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either TargetProblem [k]+                     -> [AvailableTarget k] -> Either TargetProblem' [k] selectPackageTargets targetSelector targets      -- If there are any buildable targets then we select those@@ -208,36 +184,12 @@ -- For the @build@ command we just need the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget subtarget =-    either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic subtarget----- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @build@ command.----data TargetProblem =-     TargetProblemCommon       TargetProblemCommon--     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector-  deriving (Eq, Show)--reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem+                      -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "build" problem-renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "build" targetSelector targets-renderTargetProblem(TargetProblemNoTargets targetSelector) =-    renderTargetProblemNoTargets "build" targetSelector+reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildTargetProblems verbosity problems =+  reportTargetProblems verbosity "build" problems  reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity =
Distribution/Client/CmdClean.hs view
@@ -20,12 +20,8 @@ import Distribution.Simple.Utils     ( info, die', wrapText, handleDoesNotExist ) import Distribution.Verbosity-    ( Verbosity, normal )+    ( normal ) -import Control.Monad-    ( mapM_ )-import Control.Exception-    ( throwIO ) import System.Directory     ( removeDirectoryRecursive, removeFile     , doesDirectoryExist, getDirectoryContents )@@ -111,5 +107,5 @@  removeEnvFiles :: FilePath -> IO () removeEnvFiles dir =-  (mapM_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))+  (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))   =<< getDirectoryContents dir
Distribution/Client/CmdConfigure.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure (@@ -5,31 +6,36 @@     configureAction,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import System.Directory-import Control.Monad+import System.FilePath import qualified Data.Map as Map  import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig          ( writeProjectLocalExtraConfig ) +import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault ) import Distribution.Verbosity          ( normal )  import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )+         ( CommandUI(..), usageAlternatives, optionName ) import Distribution.Simple.Utils          ( wrapText, notice )-import qualified Distribution.Client.Setup as Client -configureCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                              , HaddockFlags, TestFlags, BenchmarkFlags-                              )-configureCommand = Client.installCommand {+import Distribution.Client.DistDirLayout+         ( DistDirLayout(..) )++configureCommand :: CommandUI (NixStyleFlags ())+configureCommand = CommandUI {   commandName         = "v2-configure",   commandSynopsis     = "Add extra project configuration",   commandUsage        = usageAlternatives "v2-configure" [ "[FLAGS]" ],@@ -64,10 +70,12 @@      ++ "    program and check the resulting configuration works.\n"      ++ "  " ++ pname ++ " v2-configure\n"      ++ "    Reset the local configuration to empty and check the overall\n"-     ++ "    project configuration works.\n\n"+     ++ "    project configuration works.\n" -     ++ cmdCommonHelpTextNewBuildBeta-   }+  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (const [])+  }  -- | To a first approximation, the @configure@ just runs the first phase of -- the @build@ command where we bring the install plan up to date (thus@@ -79,12 +87,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---configureAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-                   , HaddockFlags, TestFlags, BenchmarkFlags )-                -> [String] -> GlobalFlags -> IO ()-configureAction ( configFlags, configExFlags, installFlags-                , haddockFlags, testFlags, benchmarkFlags )-                _extraArgs globalFlags = do+configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do     --TODO: deal with _extraArgs, since flags with wrong syntax end up there      baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand@@ -92,10 +96,26 @@     -- Write out the @cabal.project.local@ so it gets picked up by the     -- planning phase. If old config exists, then print the contents     -- before overwriting-    exists <- doesFileExist "cabal.project.local"++    let localFile = distProjectFile (distDirLayout baseCtx) "local"+        -- | Chooses cabal.project.local~, or if it already exists+        -- cabal.project.local~0, cabal.project.local~1 etc.+        firstFreeBackup = firstFreeBackup' (0 :: Int)+        firstFreeBackup' i = do+          let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1))+          exists <- doesFileExist backup+          if exists+            then firstFreeBackup' (i + 1)+            else return backup++    -- If cabal.project.local already exists, back up to cabal.project.local~[n]+    exists <- doesFileExist localFile     when exists $ do-        notice verbosity "'cabal.project.local' file already exists. Now overwriting it."-        copyFile "cabal.project.local" "cabal.project.local~"+        backup <- firstFreeBackup+        notice verbosity $+          quote (takeFileName localFile) <> " already exists, backing it up to "+          <> quote (takeFileName backup) <> "."+        copyFile localFile backup     writeProjectLocalExtraConfig (distDirLayout baseCtx)                                  cliConfig @@ -122,9 +142,7 @@     printPlan verbosity baseCtx' buildCtx   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags                   mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    quote s = "'" <> s <> "'"
Distribution/Client/CmdErrorMessages.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} + -- | Utilities to help format error messages for the various CLI commands. -- module Distribution.Client.CmdErrorMessages (@@ -10,23 +13,29 @@ import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning+         ( AvailableTarget(..), AvailableTargetStatus(..),+           CannotPruneDependencies(..), TargetRequested(..) ) import Distribution.Client.TargetSelector-         ( ComponentKindFilter, componentKind, showTargetSelector )+         ( SubComponentTarget(..) )+import Distribution.Client.TargetProblem+         ( TargetProblem(..), TargetProblem' )+import Distribution.Client.TargetSelector+         ( ComponentKind(..), ComponentKindFilter, TargetSelector(..),+           componentKind, showTargetSelector )  import Distribution.Package-         ( packageId, PackageName, packageName )+         ( PackageId, packageId, PackageName, packageName )+import Distribution.Simple.Utils+         ( die' ) import Distribution.Types.ComponentName-         ( showComponentName )+         ( ComponentName(..), showComponentName ) import Distribution.Types.LibraryName          ( LibraryName(..) ) import Distribution.Solver.Types.OptionalStanza          ( OptionalStanza(..) )-import Distribution.Deprecated.Text-         ( display )  import qualified Data.List.NonEmpty as NE-import Data.Function (on)   -----------------------@@ -74,7 +83,7 @@ -- things, e.g. grouping components by package name -- -- > renderListSemiAnd--- >   [     "the package " ++ display pkgname ++ " components "+-- >   [     "the package " ++ prettyShow pkgname ++ " components " -- >      ++ renderListCommaAnd showComponentName components -- >   | (pkgname, components) <- sortGroupOn packageName allcomponents ] --@@ -91,19 +100,19 @@ renderTargetSelector :: TargetSelector -> String renderTargetSelector (TargetPackage _ pkgids Nothing) =     "the " ++ plural (listPlural pkgids) "package" "packages" ++ " "- ++ renderListCommaAnd (map display pkgids)+ ++ renderListCommaAnd (map prettyShow pkgids)  renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) =     "the " ++ renderComponentKind Plural kfilter  ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " "- ++ renderListCommaAnd (map display pkgids)+ ++ renderListCommaAnd (map prettyShow pkgids)  renderTargetSelector (TargetPackageNamed pkgname Nothing) =-    "the package " ++ display pkgname+    "the package " ++ prettyShow pkgname  renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) =     "the " ++ renderComponentKind Plural kfilter- ++ " in the package " ++ display pkgname+ ++ " in the package " ++ prettyShow pkgname  renderTargetSelector (TargetAllPackages Nothing) =     "all the packages in the project"@@ -117,8 +126,8 @@  ++ renderComponentName (packageName pkgid) cname  renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) =-    renderSubComponentTarget subtarget ++ "the component " ++ display ucname- ++ " in the package " ++ display pkgname+    renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname+ ++ " in the package " ++ prettyShow pkgname  renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) =     renderSubComponentTarget subtarget ++ "the "@@ -129,7 +138,7 @@ renderSubComponentTarget (FileTarget filename)  =   "the file " ++ filename ++ "in " renderSubComponentTarget (ModuleTarget modname) =-  "the module" ++ display modname ++ "in "+  "the module" ++ prettyShow modname ++ "in "   renderOptionalStanza :: Plural -> OptionalStanza -> String@@ -169,12 +178,12 @@ targetSelectorFilter  TargetComponentUnknown{}       = Nothing  renderComponentName :: PackageName -> ComponentName -> String-renderComponentName pkgname (CLibName LMainLibName) = "library " ++ display pkgname-renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ display name-renderComponentName _ (CFLibName   name) = "foreign library " ++ display name-renderComponentName _ (CExeName    name) = "executable " ++ display name-renderComponentName _ (CTestName   name) = "test suite " ++ display name-renderComponentName _ (CBenchName  name) = "benchmark " ++ display name+renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname+renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name+renderComponentName _ (CFLibName   name) = "foreign library " ++ prettyShow name+renderComponentName _ (CExeName    name) = "executable " ++ prettyShow name+renderComponentName _ (CTestName   name) = "test suite " ++ prettyShow name+renderComponentName _ (CBenchName  name) = "benchmark " ++ prettyShow name  renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of@@ -192,39 +201,55 @@   ---------------------------------------------------------- Renderering error messages for TargetProblemCommon+-- Renderering error messages for TargetProblem -- -renderTargetProblemCommon :: String -> TargetProblemCommon -> String-renderTargetProblemCommon verb (TargetNotInProject pkgname) =-    "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not "+-- | Default implementation of 'reportTargetProblems' simply renders one problem per line.+reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a+reportTargetProblems verbosity verb =+  die' verbosity . unlines . map (renderTargetProblem verb absurd)++-- | Default implementation of 'renderTargetProblem'.+renderTargetProblem+    :: String           -- ^ verb+    -> (a -> String)    -- ^ how to render custom problems+    -> TargetProblem a+    -> String+renderTargetProblem _verb f (CustomTargetProblem x) = f x+renderTargetProblem verb  _ (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled verb targetSelector targets+renderTargetProblem verb  _ (TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets verb targetSelector++renderTargetProblem verb _ (TargetNotInProject pkgname) =+    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "  ++ "in this project (either directly or indirectly). If you want to add it "  ++ "to the project then edit the cabal.project file." -renderTargetProblemCommon verb (TargetAvailableInIndex pkgname) =-    "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not "+renderTargetProblem verb _ (TargetAvailableInIndex pkgname) =+    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "  ++ "in this project (either directly or indirectly), but it is in the current "  ++ "package index. If you want to add it to the project then edit the "  ++ "cabal.project file." -renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) =+renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) =     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "- ++ "package " ++ display pkgid ++ " is not local to the project, and cabal "+ ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal "  ++ "does not currently support building test suites or benchmarks of "  ++ "non-local dependencies. To run test suites or benchmarks from "  ++ "dependencies you can unpack the package locally and adjust the "  ++ "cabal.project file to include that package directory." -renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) =+renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) =     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "- ++ "marked as 'buildable: False' within the '" ++ display (packageName pkgid)+ ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid)  ++ ".cabal' file (at least for the current configuration). If you believe it "  ++ "should be buildable then check the .cabal file to see if the buildable "  ++ "property is conditional on flags. Alternatively you may simply have to "  ++ "edit the .cabal file to declare it as buildable and fix any resulting "  ++ "build problems." -renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) =+renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) =     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because "  ++ "building " ++ compkinds ++ " has been explicitly disabled in the "  ++ "configuration. You can adjust this configuration in the "@@ -237,10 +262,10 @@    where      compkinds = renderComponentKind Plural (componentKind cname) -renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) =+renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) =     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "  ++ "solver did not find a plan that included the " ++ compkinds- ++ " for " ++ display pkgid ++ ". It is probably worth trying again with "+ ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with "  ++ compkinds ++ " explicitly enabled in the configuration in the "  ++ "cabal.project{.local} file. This will ask the solver to find a plan with "  ++ "the " ++ compkinds ++ " available. It will either fail with an "@@ -250,27 +275,27 @@    where      compkinds = renderComponentKind Plural (componentKind cname) -renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) =+renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) =     "Cannot " ++ verb ++ " the "  ++ (case ecname of-      Left ucname -> "component " ++ display ucname+      Left ucname -> "component " ++ prettyShow ucname       Right cname -> renderComponentName pkgname cname)- ++ " from the package " ++ display pkgname+ ++ " from the package " ++ prettyShow pkgname  ++ ", because the package does not contain a "  ++ (case ecname of       Left  _     -> "component"       Right cname -> renderComponentKind Singular (componentKind cname))  ++ " with that name." -renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) =+renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) =     "Internal error when trying to " ++ verb ++ " the package "-  ++ display pkgid ++ ". The package is not in the set of available targets "+  ++ prettyShow pkgid ++ ". The package is not in the set of available targets "   ++ "for the project plan, which would suggest an inconsistency "   ++ "between readTargetSelectors and resolveTargets." -renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) =+renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =     "Internal error when trying to " ++ verb ++ " the "-  ++ showComponentName cname ++ " from the package " ++ display pkgid+  ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid   ++ ". The package,component pair is not in the set of available targets "   ++ "for the project plan, which would suggest an inconsistency "   ++ "between readTargetSelectors and resolveTargets."@@ -385,9 +410,9 @@       "Cannot select only the dependencies (as requested by the "    ++ "'--only-dependencies' flag), "    ++ (case pkgids of-          [pkgid] -> "the package " ++ display pkgid ++ " is "+          [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "           _       -> "the packages "-                     ++ renderListCommaAnd (map display pkgids) ++ " are ")+                     ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ")    ++ "required by a dependency of one of the other targets."   where     -- throw away the details and just list the deps that are needed
Distribution/Client/CmdExec.hs view
@@ -21,13 +21,12 @@   ( GenericPlanPackage(..)   , toGraph   )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-  ( ConfigExFlags-  , ConfigFlags(configVerbosity)+  ( ConfigFlags(configVerbosity)   , GlobalFlags-  , InstallFlags   )-import qualified Distribution.Client.Setup as Client import Distribution.Client.ProjectOrchestration   ( ProjectBuildContext(..)   , runProjectPreBuildPhase@@ -49,7 +48,7 @@   , ElaboratedSharedConfig(..)   ) import Distribution.Simple.Command-  ( CommandUI(..)+  ( CommandUI(..), optionName   ) import Distribution.Simple.Program.Db   ( modifyProgramSearchPath@@ -73,11 +72,8 @@ import Distribution.Simple.GHC   ( getImplInfo   , GhcImplInfo(supportsPkgEnvFiles) )-import Distribution.Simple.Setup-  ( HaddockFlags-  , TestFlags-  , BenchmarkFlags-  , fromFlagOrDefault+import Distribution.Simple.Flag+  ( fromFlagOrDefault   ) import Distribution.Simple.Utils   ( die'@@ -87,8 +83,7 @@   , wrapText   ) import Distribution.Verbosity-  ( Verbosity-  , normal+  ( normal   )  import Prelude ()@@ -97,9 +92,7 @@ import qualified Data.Set as S import qualified Data.Map as M -execCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                         , HaddockFlags, TestFlags, BenchmarkFlags-                         )+execCommand :: CommandUI (NixStyleFlags ()) execCommand = CommandUI   { commandName = "v2-exec"   , commandSynopsis = "Give a command access to the store."@@ -120,16 +113,13 @@     ++ " to choose an appropriate version of ghc and to include any"     ++ " ghc-specific flags requested."   , commandNotes = Nothing-  , commandOptions = commandOptions Client.installCommand-  , commandDefaultFlags = commandDefaultFlags Client.installCommand+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (const [])+  , commandDefaultFlags = defaultNixStyleFlags ()   } -execAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-              , HaddockFlags, TestFlags, BenchmarkFlags )-           -> [String] -> GlobalFlags -> IO ()-execAction ( configFlags, configExFlags, installFlags-           , haddockFlags, testFlags, benchmarkFlags )-           extraArgs globalFlags = do+execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+execAction flags@NixStyleFlags {..} extraArgs globalFlags = do    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -198,11 +188,8 @@         runProgramInvocation verbosity invocation   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags                   mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags     withOverrides env args program = program       { programOverrideEnv = programOverrideEnv program ++ env       , programDefaultArgs = programDefaultArgs program ++ args}
Distribution/Client/CmdFreeze.hs view
@@ -7,11 +7,17 @@     freezeAction,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectConfig          ( ProjectConfig(..), ProjectConfigShared(..)          , writeProjectLocalFreezeConfig )+import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos) import Distribution.Client.Targets          ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) import Distribution.Solver.Types.PackageConstraint@@ -31,28 +37,22 @@ import Distribution.PackageDescription          ( FlagAssignment, nullFlagAssignment ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Simple.Flag (Flag (..)) import Distribution.Simple.Utils          ( die', notice, wrapText ) import Distribution.Verbosity          ( normal ) -import Data.Monoid as Monoid import qualified Data.Map as Map-import Data.Map (Map)-import Control.Monad (unless)  import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives )-import qualified Distribution.Client.Setup as Client --freezeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                           , HaddockFlags, TestFlags, BenchmarkFlags-                           )-freezeCommand = Client.installCommand {+freezeCommand :: CommandUI (NixStyleFlags ())+freezeCommand = CommandUI {   commandName         = "v2-freeze",   commandSynopsis     = "Freeze dependencies.",   commandUsage        = usageAlternatives "v2-freeze" [ "[FLAGS]" ],@@ -74,6 +74,7 @@      ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "      ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "      ++ "with the same set of flags.",+   commandNotes        = Just $ \pname ->         "Examples:\n"      ++ "  " ++ pname ++ " v2-freeze\n"@@ -81,17 +82,10 @@      ++ "  " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"      ++ "    Check what a solution with the given constraints would look like\n"      ++ "  " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n"-     ++ "    Freeze a solution using the given constraints\n\n"+     ++ "    Freeze a solution using the given constraints\n" -     ++ "Note: this command is part of the new project-based system (aka "-     ++ "nix-style\nlocal builds). These features are currently in beta. "-     ++ "Please see\n"-     ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "-     ++ "for\ndetails and advice on what you can expect to work. If you "-     ++ "encounter problems\nplease file issues at "-     ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "-     ++ "to get involved and help with testing, fixing bugs etc then\nthat "-     ++ "is very much appreciated.\n"+   , commandDefaultFlags = defaultNixStyleFlags ()+   , commandOptions      = nixStyleOptions (const [])    }  -- | To a first approximation, the @freeze@ command runs the first phase of@@ -101,12 +95,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---freezeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-                , HaddockFlags, TestFlags, BenchmarkFlags )-             -> [String] -> GlobalFlags -> IO ()-freezeAction ( configFlags, configExFlags, installFlags-             , haddockFlags, testFlags, benchmarkFlags )-             extraArgs globalFlags = do+freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do      unless (null extraArgs) $       die' verbosity $ "'freeze' doesn't take any extra arguments: "@@ -119,38 +109,43 @@       localPackages     } <- establishProjectBaseContext verbosity cliConfig OtherCommand -    (_, elaboratedPlan, _) <-+    (_, elaboratedPlan, _, totalIndexState, activeRepos) <-       rebuildInstallPlan verbosity                          distDirLayout cabalDirLayout                          projectConfig                          localPackages -    let freezeConfig = projectFreezeConfig elaboratedPlan+    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos     writeProjectLocalFreezeConfig distDirLayout freezeConfig     notice verbosity $       "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"    where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags                   mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags    -- | Given the install plan, produce a config value with constraints that -- freezes the versions of packages used in the plan. ---projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig-projectFreezeConfig elaboratedPlan =-    Monoid.mempty {-      projectConfigShared = Monoid.mempty {-        projectConfigConstraints =+projectFreezeConfig+    :: ElaboratedInstallPlan+    -> TotalIndexState+    -> ActiveRepos+    -> ProjectConfig+projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty+    { projectConfigShared = mempty+        { projectConfigConstraints =           concat (Map.elems (projectFreezeConstraints elaboratedPlan))-      }+        , projectConfigIndexState  = Flag totalIndexState+        , projectConfigActiveRepos = Flag activeRepos+        }     }+  where+    activeRepos :: ActiveRepos+    activeRepos = filterSkippedActiveRepos activeRepos0  -- | Given the install plan, produce solver constraints that will ensure the -- solver picks the same solution again in future in different environments.
Distribution/Client/CmdHaddock.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}  -- | cabal-install CLI command: haddock --@@ -8,33 +8,32 @@     haddockAction,      -- * Internals exposed for testing-    TargetProblem(..),     selectPackageTargets,     selectComponentTarget   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages-+import Distribution.Client.TargetProblem+         ( TargetProblem (..), TargetProblem' )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )-import qualified Distribution.Client.Setup as Client+         ( GlobalFlags, ConfigFlags(..) ) import Distribution.Simple.Setup-         ( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault )+         ( HaddockFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Utils          ( wrapText, die' ) -import Control.Monad (when)---haddockCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                            , HaddockFlags, TestFlags, BenchmarkFlags-                            )-haddockCommand = Client.installCommand {+haddockCommand :: CommandUI (NixStyleFlags ())+haddockCommand = CommandUI {   commandName         = "v2-haddock",   commandSynopsis     = "Build Haddock documentation",   commandUsage        = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],@@ -58,10 +57,10 @@   commandNotes        = Just $ \pname ->         "Examples:\n"      ++ "  " ++ pname ++ " v2-haddock pkgname"-     ++ "    Build documentation for the package named pkgname\n\n"--     ++ cmdCommonHelpTextNewBuildBeta-   }+     ++ "    Build documentation for the package named pkgname\n"+  , commandOptions      = nixStyleOptions (const [])+  , commandDefaultFlags = defaultNixStyleFlags ()+  }    --TODO: [nice to have] support haddock on specific components, not just    -- whole packages and the silly --executables etc modifiers. @@ -70,13 +69,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-                 , HaddockFlags, TestFlags, BenchmarkFlags )-                 -> [String] -> GlobalFlags -> IO ()-haddockAction ( configFlags, configExFlags, installFlags-              , haddockFlags, testFlags, benchmarkFlags )-                targetStrings globalFlags = do-+haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do     baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand      targetSelectors <- either (reportTargetSelectorProblems verbosity) return@@ -91,11 +85,10 @@                -- When we interpret the targets on the command line, interpret them as               -- haddock targets-            targets <- either (reportTargetProblems verbosity) return+            targets <- either (reportBuildDocumentationTargetProblems verbosity) return                      $ resolveTargets                          (selectPackageTargets haddockFlags)                          selectComponentTarget-                         TargetProblemCommon                          elaboratedPlan                          Nothing                          targetSelectors@@ -112,11 +105,7 @@     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags-                  mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here  -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,@@ -127,7 +116,7 @@ -- We do similarly for test-suites, benchmarks and foreign libs. -- selectPackageTargets  :: HaddockFlags -> TargetSelector-                      -> [AvailableTarget k] -> Either TargetProblem [k]+                      -> [AvailableTarget k] -> Either TargetProblem' [k] selectPackageTargets haddockFlags targetSelector targets      -- If there are any buildable targets then we select those@@ -177,35 +166,9 @@ -- etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget subtarget =-    either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic subtarget----- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @haddock@ command.----data TargetProblem =-     TargetProblemCommon       TargetProblemCommon--     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector-  deriving (Eq, Show)--reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem--renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "build documentation for" problem--renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "build documentation for" targetSelector targets+                      -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic -renderTargetProblem(TargetProblemNoTargets targetSelector) =-    renderTargetProblemNoTargets "build documentation for" targetSelector+reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildDocumentationTargetProblems verbosity problems =+  reportTargetProblems verbosity "build documentation for" problems
Distribution/Client/CmdInstall.hs view
@@ -12,9 +12,10 @@     installAction,      -- * Internals exposed for testing-    TargetProblem(..),     selectPackageTargets,     selectComponentTarget,+    -- * Internals exposed for CmdRepl + CmdRun+    establishDummyDistDirLayout,     establishDummyProjectBaseContext   ) where @@ -26,15 +27,14 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdSdist+import Distribution.Client.TargetProblem+         ( TargetProblem', TargetProblem (..) )  import Distribution.Client.CmdInstall.ClientInstallFlags+import Distribution.Client.CmdInstall.ClientInstallTargetSelector  import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)-         , configureExOptions, haddockOptions, installOptions, testOptions-         , benchmarkOptions, configureOptions, liftOptions )-import Distribution.Solver.Types.ConstraintSource-         ( ConstraintSource(..) )+         ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Client.Types          ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage          , SourcePackageDb(..) )@@ -43,12 +43,19 @@          ( Package(..), PackageName, mkPackageName, unPackageName ) import Distribution.Types.PackageId          ( PackageIdentifier(..) )+import Distribution.Client.ProjectConfig+         ( ProjectPackageLocation(..)+         , fetchAndReadSourcePackages+         )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Client.ProjectConfig.Types          ( ProjectConfig(..), ProjectConfigShared(..)          , ProjectConfigBuildOnly(..), PackageConfig(..)          , getMapLast, getMapMappend, projectConfigLogsDir          , projectConfigStoreDir, projectConfigBuildOnly-         , projectConfigDistDir, projectConfigConfigFile )+         , projectConfigConfigFile ) import Distribution.Simple.Program.Db          ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb          , modifyProgramSearchPath, ProgramDb )@@ -57,14 +64,14 @@ import Distribution.Simple.Program.Find          ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config-         ( getCabalDir, loadConfig, SavedConfig(..) )+         ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) import qualified Distribution.Simple.PackageIndex as PI import Distribution.Solver.Types.PackageIndex          ( lookupPackageName, searchByName ) import Distribution.Types.InstalledPackageInfo          ( InstalledPackageInfo(..) ) import Distribution.Types.Version-         ( nullVersion )+         ( Version, nullVersion ) import Distribution.Types.VersionRange          ( thisVersion ) import Distribution.Solver.Types.PackageConstraint@@ -72,80 +79,71 @@ import Distribution.Client.IndexUtils          ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig-         ( readGlobalConfig, projectConfigWithBuilderRepoContext-         , resolveBuildTimeSettings, withProjectOrGlobalConfigIgn )+         ( projectConfigWithBuilderRepoContext+         , resolveBuildTimeSettings, withProjectOrGlobalConfig ) import Distribution.Client.ProjectPlanning          ( storePackageInstallDirs' )+import Distribution.Client.ProjectPlanning.Types+         ( ElaboratedInstallPlan ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Client.DistDirLayout-         ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout-         , ProjectRoot(ProjectRootImplicit)+         ( DistDirLayout(..), mkCabalDirLayout          , cabalStoreDirLayout          , CabalDirLayout(..), StoreDirLayout(..) ) import Distribution.Client.RebuildMonad          ( runRebuild ) import Distribution.Client.InstallSymlink-         ( OverwritePolicy(..), symlinkBinary )+         ( symlinkBinary, trySymlink )+import Distribution.Client.Types.OverwritePolicy+         ( OverwritePolicy (..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault, flagToMaybe, flagElim ) import Distribution.Simple.Setup-         ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags-         , fromFlagOrDefault, flagToMaybe )+         ( Flag(..) ) import Distribution.Solver.Types.SourcePackage          ( SourcePackage(..) ) import Distribution.Simple.Command-         ( CommandUI(..), OptionField(..), usageAlternatives )+         ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Configure          ( configCompilerEx ) import Distribution.Simple.Compiler          ( Compiler(..), CompilerId(..), CompilerFlavor(..)          , PackageDBStack ) import Distribution.Simple.GHC-         ( ghcPlatformAndVersionString+         ( ghcPlatformAndVersionString, getGhcAppDir          , GhcImplInfo(..), getImplInfo          , GhcEnvironmentFileEntry(..)          , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) import Distribution.System-         ( Platform )+         ( Platform , buildOS, OS (Windows) ) import Distribution.Types.UnitId          ( UnitId ) import Distribution.Types.UnqualComponentName          ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity-         ( Verbosity, normal, lessVerbose )+         ( normal, lessVerbose ) import Distribution.Simple.Utils          ( wrapText, die', notice, warn          , withTempDirectory, createDirectoryIfMissingVerbose          , ordNub ) import Distribution.Utils.Generic          ( safeHead, writeFileAtomic )-import Distribution.Deprecated.Text-         ( simpleParse )-import Distribution.Pretty-         ( prettyShow ) -import Control.Exception-         ( catch )-import Control.Monad-         ( mapM, forM_ ) import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Either-         ( partitionEithers ) import Data.Ord-         ( comparing, Down(..) )+         ( Down(..) ) import qualified Data.Map as Map import Distribution.Utils.NubList          ( fromNubList )+import Network.URI (URI) import System.Directory-         ( getHomeDirectory, doesFileExist, createDirectoryIfMissing+         ( doesFileExist, createDirectoryIfMissing          , getTemporaryDirectory, makeAbsolute, doesDirectoryExist          , removeFile, removeDirectory, copyFile ) import System.FilePath          ( (</>), (<.>), takeDirectory, takeBaseName ) --installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                            , HaddockFlags, TestFlags, BenchmarkFlags-                            , ClientInstallFlags-                            )+installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) installCommand = CommandUI   { commandName         = "v2-install"   , commandSynopsis     = "Install packages."@@ -171,46 +169,10 @@       ++ "  " ++ pname ++ " v2-install ./pkgfoo\n"       ++ "    Install the package in the ./pkgfoo directory\n" -      ++ cmdCommonHelpTextNewBuildBeta-  , commandOptions      = \showOrParseArgs ->-        liftOptions get1 set1-        -- Note: [Hidden Flags]-        -- hide "constraint", "dependency", and-        -- "exact-configuration" from the configure options.-        (filter ((`notElem` ["constraint", "dependency"-                            , "exact-configuration"])-                 . optionName) $ configureOptions showOrParseArgs)-     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs-                               ConstraintSourceCommandlineFlag)-     ++ liftOptions get3 set3-        -- hide "target-package-db" and "symlink-bindir" flags from the-        -- install options.-        -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags-        (filter ((`notElem` ["target-package-db", "symlink-bindir"])-                 . optionName) $-                               installOptions showOrParseArgs)-       ++ liftOptions get4 set4-          -- hide "verbose" and "builddir" flags from the-          -- haddock options.-          (filter ((`notElem` ["v", "verbose", "builddir"])-                  . optionName) $-                                haddockOptions showOrParseArgs)-     ++ liftOptions get5 set5 (testOptions showOrParseArgs)-     ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)-     ++ liftOptions get7 set7 (clientInstallOptions showOrParseArgs)-  , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty, mempty-                          , defaultClientInstallFlags )+  , commandOptions      = nixStyleOptions clientInstallOptions+  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags   }-  where-    get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)-    get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)-    get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)-    get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)-    get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)-    get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)-    get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) - -- | The @install@ command actually serves four different needs. It installs: -- * exes: --   For example a program from hackage. The behavior is similar to the old@@ -228,55 +190,37 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---installAction-  :: ( ConfigFlags, ConfigExFlags, InstallFlags-     , HaddockFlags, TestFlags, BenchmarkFlags-     , ClientInstallFlags)-  -> [String] -> GlobalFlags-  -> IO ()-installAction ( configFlags, configExFlags, installFlags-              , haddockFlags, testFlags, benchmarkFlags-              , clientInstallFlags' )-              targetStrings globalFlags = do-  -- We never try to build tests/benchmarks for remote packages.-  -- So we set them as disabled by default and error if they are explicitly-  -- enabled.-  when (configTests configFlags' == Flag True) $-    die' verbosity $ "--enable-tests was specified, but tests can't "-                  ++ "be enabled in a remote package"-  when (configBenchmarks configFlags' == Flag True) $-    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "-                  ++ "be enabled in a remote package"+installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()+installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do+  -- Ensure there were no invalid configuration options specified.+  verifyPreconditionsOrDie verbosity configFlags'    -- We cannot use establishDummyProjectBaseContext to get these flags, since   -- it requires one of them as an argument. Normal establishProjectBaseContext   -- does not, and this is why this is done only for the install command-  clientInstallFlags <- do-    let configFileFlag = globalConfigFile globalFlags-    savedConfig <- loadConfig verbosity configFileFlag-    pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags'+  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'    let     installLibs    = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)     targetFilter   = if installLibs then Just LibKind else Just ExeKind     targetStrings' = if null targetStrings then ["."] else targetStrings -    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig)+    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)     withProject = do-      let verbosity' = lessVerbose verbosity+      let reducedVerbosity = lessVerbose verbosity        -- First, we need to learn about what's available to be installed.-      localBaseCtx <- establishProjectBaseContext verbosity'-                      cliConfig InstallCommand+      localBaseCtx <-+        establishProjectBaseContext reducedVerbosity cliConfig InstallCommand       let localDistDirLayout = distDirLayout localBaseCtx-      pkgDb <- projectConfigWithBuilderRepoContext verbosity'+      pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity                (buildSettings localBaseCtx) (getSourcePackages verbosity)        let         (targetStrings'', packageIds) =           partitionEithers .           flip fmap targetStrings' $-          \str -> case simpleParse str of+          \str -> case simpleParsec str of             Just (pkgId :: PackageId)               | pkgVersion pkgId /= nullVersion -> Right pkgId             _                                   -> Left str@@ -291,7 +235,7 @@           flip TargetPackageNamed targetFilter . pkgName <$> packageIds        if null targetStrings'-        then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx)+        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)         else do           targetSelectors <-             either (reportTargetSelectorProblems verbosity) return@@ -299,113 +243,17 @@                                     Nothing targetStrings''            (specs, selectors) <--            withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do-            -- Split into known targets and hackage packages.-            (targets, hackageNames) <- case-              resolveTargets-                selectPackageTargets-                selectComponentTarget-                TargetProblemCommon-                elaboratedPlan-                (Just pkgDb)-                targetSelectors of-              Right targets ->-                -- Everything is a local dependency.-                return (targets, [])-              Left errs     -> do-                -- Not everything is local.-                let-                  (errs', hackageNames) = partitionEithers . flip fmap errs $ \case-                    TargetProblemCommon (TargetAvailableInIndex name) -> Right name-                    err -> Left err--                -- report incorrect case for known package.-                for_ errs' $ \case-                  TargetProblemCommon (TargetNotInProject hn) ->-                    case searchByName (packageIndex pkgDb) (unPackageName hn) of-                      [] -> return ()-                      xs -> die' verbosity . concat $-                        [ "Unknown package \"", unPackageName hn, "\". "-                        , "Did you mean any of the following?\n"-                        , unlines (("- " ++) . unPackageName . fst <$> xs)-                        ]-                  _ -> return ()--                when (not . null $ errs') $ reportTargetProblems verbosity errs'--                let-                  targetSelectors' = flip filter targetSelectors $ \case-                    TargetComponentUnknown name _ _-                      | name `elem` hackageNames -> False-                    TargetPackageNamed name _-                      | name `elem` hackageNames -> False-                    _                            -> True--                -- This can't fail, because all of the errors are-                -- removed (or we've given up).-                targets <--                  either (reportTargetProblems verbosity) return $-                  resolveTargets-                    selectPackageTargets-                    selectComponentTarget-                    TargetProblemCommon-                    elaboratedPlan-                    Nothing-                    targetSelectors'--                return (targets, hackageNames)--            let-              planMap = InstallPlan.toMap elaboratedPlan-              targetIds = Map.keys targets--              sdistize (SpecificSourcePackage spkg@SourcePackage{..}) =-                SpecificSourcePackage spkg'-                where-                  sdistPath = distSdistFile localDistDirLayout packageInfoId-                  spkg' = spkg { packageSource = LocalTarballPackage sdistPath }-              sdistize named = named--              local = sdistize <$> localPackages localBaseCtx--              gatherTargets :: UnitId -> TargetSelector-              gatherTargets targetId = TargetPackageNamed pkgName targetFilter-                where-                  targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap-                  PackageIdentifier{..} = packageId targetUnit--              targets' = fmap gatherTargets targetIds--              hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]-              hackagePkgs = flip NamedPackage [] <$> hackageNames--              hackageTargets :: [TargetSelector]-              hackageTargets =-                flip TargetPackageNamed targetFilter <$> hackageNames--            createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)--            unless (Map.null targets) $ forM_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of-                SpecificSourcePackage pkg -> packageToSdist verbosity-                  (distProjectRootDirectory localDistDirLayout) TarGzArchive-                  (distSdistFile localDistDirLayout (packageId pkg)) pkg-                NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName--            if null targets-              then return (hackagePkgs, hackageTargets)-              else return (local ++ hackagePkgs, targets' ++ hackageTargets)+            getSpecsAndTargetSelectors+              verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter            return ( specs ++ packageSpecifiers+                 , []                  , selectors ++ packageTargets                  , projectConfig localBaseCtx ) -    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [TargetSelector], ProjectConfig)+    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)     withoutProject globalConfig = do-      let-        parsePkg pkgName-          | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg-          | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName)-      packageIds <- mapM parsePkg targetStrings'+      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'        cabalDir <- getCabalDir       let@@ -431,34 +279,27 @@                                             verbosity buildSettings                                             (getSourcePackages verbosity) -      for_ targetStrings' $ \case-            name-              | null (lookupPackageName packageIndex (mkPackageName name))-              , xs@(_:_) <- searchByName packageIndex name ->-                die' verbosity . concat $-                            [ "Unknown package \"", name, "\". "-                            , "Did you mean any of the following?\n"-                            , unlines (("- " ++) . unPackageName . fst <$> xs)-                            ]-            _ -> return ()+      for_ (concatMap woPackageNames tss) $ \name -> do+        when (null (lookupPackageName packageIndex name)) $ do+          let xs = searchByName packageIndex (unPackageName name)+          let emptyIf True  _  = []+              emptyIf False zs = zs+          die' verbosity $ concat $+            [ "Unknown package \"", unPackageName name, "\". "+            ] ++ emptyIf (null xs)+            [ "Did you mean any of the following?\n"+            , unlines (("- " ++) . unPackageName . fst <$> xs)+            ]        let-        packageSpecifiers = flip fmap packageIds $ \case-          PackageIdentifier{..}-            | pkgVersion == nullVersion -> NamedPackage pkgName []-            | otherwise                 -> NamedPackage pkgName-                                           [PackagePropertyVersion-                                            (thisVersion pkgVersion)]-        packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds-      return (packageSpecifiers, packageTargets, projectConfig)+        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss+        packageTargets            = map woPackageTargets tss -  let-    ignoreProject = fromFlagOrDefault False (cinstIgnoreProject clientInstallFlags)+      return (packageSpecifiers, uris, packageTargets, projectConfig) -  (specs, selectors, config) <--     withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject+  (specs, uris, targetSelectors, config) <-+     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject -  home <- getHomeDirectory   let     ProjectConfig {       projectConfigBuildOnly = ProjectConfigBuildOnly {@@ -496,105 +337,41 @@       configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity    let-    globalEnv name =-      home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion-           </> "environments" </> name-    localEnv dir =-      dir </>-      ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion-     GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler-    -- Why? We know what the first part will be, we only care about the packages.-    filterEnvEntries = filter $ \case-      GhcEnvFilePackageId _ -> True-      _                     -> False -  envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of-    Just spec-      -- Is spec a bare word without any "pathy" content, then it refers to-      -- a named global environment.-      | takeBaseName spec == spec -> return (globalEnv spec)-      | otherwise                 -> do-        spec' <- makeAbsolute spec-        isDir <- doesDirectoryExist spec'-        if isDir-          -- If spec is a directory, then make an ambient environment inside-          -- that directory.-          then return (localEnv spec')-          -- Otherwise, treat it like a literal file path.-          else return spec'-    Nothing                       -> return (globalEnv "default")--  envFileExists <- doesFileExist envFile-  envEntries <- filterEnvEntries <$> if-    (compilerFlavor == GHC || compilerFlavor == GHCJS)-      && supportsPkgEnvFiles && envFileExists-    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->-      warn verbosity ("The environment file " ++ envFile ++-        " is unparsable. Libraries cannot be installed.") >> return []-    else return []--  cabalDir  <- getCabalDir-  mstoreDir <--    sequenceA $ makeAbsolute <$> flagToMaybe projectConfigStoreDir-  let-    mlogsDir    = flagToMaybe projectConfigLogsDir-    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir-    packageDbs  = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId-+  envFile <- getEnvFile clientInstallFlags platform compilerVersion+  existingEnvEntries <-+    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile+  packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir   installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb -  let (envSpecs, envEntries') =-        environmentFileToSpecifiers installedIndex envEntries+  let+    (envSpecs, nonGlobalEnvEntries) =+      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs    -- Second, we need to use a fake project to let Cabal build the   -- installables correctly. For that, we need a place to put a   -- temporary dist directory.   globalTmp <- getTemporaryDirectory -  -- if we are installing executables, we shouldn't take into account-  -- environment specifiers.-  let envSpecs' :: [PackageSpecifier a]-      envSpecs' | installLibs = envSpecs-                | otherwise   = []+  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do+    distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir -  withTempDirectory-    verbosity-    globalTmp-    "cabal-install."-    $ \tmpDir -> do+    uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages+      verbosity+      distDirLayout+      (projectConfigShared config)+      (projectConfigBuildOnly config)+      [ ProjectPackageRemoteTarball uri | uri <- uris ]+     baseCtx <- establishDummyProjectBaseContext                  verbosity                  config-                 tmpDir-                 (envSpecs' ++ specs)+                 distDirLayout+                 (envSpecs ++ specs ++ uriSpecs)                  InstallCommand -    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do--            -- Interpret the targets on the command line as build targets-            targets <- either (reportTargetProblems verbosity) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         TargetProblemCommon-                         elaboratedPlan-                         Nothing-                         selectors--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionBuild-                                    targets-                                    elaboratedPlan-            elaboratedPlan'' <--              if buildSettingOnlyDeps (buildSettings baseCtx)-                then either (reportCannotPruneDependencies verbosity) return $-                     pruneInstallPlanToDependencies (Map.keysSet targets)-                                                    elaboratedPlan'-                else return elaboratedPlan'--            return (elaboratedPlan'', targets)+    buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors      printPlan verbosity baseCtx buildCtx @@ -610,18 +387,188 @@     when (not dryRun) $       if installLibs       then installLibraries verbosity-           buildCtx compiler packageDbs progDb envFile envEntries'+           buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries       else installExes verbosity            baseCtx buildCtx platform compiler configFlags clientInstallFlags   where     configFlags' = disableTestsBenchsByDefault configFlags     verbosity = fromFlagOrDefault normal (configVerbosity configFlags')+    ignoreProject = flagIgnoreProject projectFlags     cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags' configExFlags-                  installFlags clientInstallFlags'-                  haddockFlags testFlags benchmarkFlags+                  globalFlags+                  flags { configFlags = configFlags' }+                  clientInstallFlags'     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) +-- | Verify that invalid config options were not passed to the install command.+--+-- If an invalid configuration is found the command will @die'@.+verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()+verifyPreconditionsOrDie verbosity configFlags = do+  -- We never try to build tests/benchmarks for remote packages.+  -- So we set them as disabled by default and error if they are explicitly+  -- enabled.+  when (configTests configFlags == Flag True) $+    die' verbosity $ "--enable-tests was specified, but tests can't "+                  ++ "be enabled in a remote package"+  when (configBenchmarks configFlags == Flag True) $+    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "+                  ++ "be enabled in a remote package"++getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags+getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do+  let configFileFlag = globalConfigFile globalFlags+  savedConfig <- loadConfig verbosity configFileFlag+  pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags+++getSpecsAndTargetSelectors+  :: Verbosity+  -> Verbosity+  -> SourcePackageDb+  -> [TargetSelector]+  -> DistDirLayout+  -> ProjectBaseContext+  -> Maybe ComponentKindFilter+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])+getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =+  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do+  -- Split into known targets and hackage packages.+  (targets, hackageNames) <-+    partitionToKnownTargetsAndHackagePackages+      verbosity pkgDb elaboratedPlan targetSelectors++  let+    planMap = InstallPlan.toMap elaboratedPlan+    targetIds = Map.keys targets++    sdistize (SpecificSourcePackage spkg) =+      SpecificSourcePackage spkg'+      where+        sdistPath = distSdistFile localDistDirLayout (packageId spkg)+        spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }+    sdistize named = named++    local = sdistize <$> localPackages localBaseCtx++    gatherTargets :: UnitId -> TargetSelector+    gatherTargets targetId = TargetPackageNamed pkgName targetFilter+      where+        targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap+        PackageIdentifier{..} = packageId targetUnit++    targets' = fmap gatherTargets targetIds++    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]+    hackagePkgs = flip NamedPackage [] <$> hackageNames++    hackageTargets :: [TargetSelector]+    hackageTargets =+      flip TargetPackageNamed targetFilter <$> hackageNames++  createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)++  unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of+      SpecificSourcePackage pkg -> packageToSdist verbosity+        (distProjectRootDirectory localDistDirLayout) TarGzArchive+        (distSdistFile localDistDirLayout (packageId pkg)) pkg+      NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName++  if null targets+    then return (hackagePkgs, hackageTargets)+    else return (local ++ hackagePkgs, targets' ++ hackageTargets)++-- | Partitions the target selectors into known local targets and hackage packages.+partitionToKnownTargetsAndHackagePackages+  :: Verbosity+  -> SourcePackageDb+  -> ElaboratedInstallPlan+  -> [TargetSelector]+  -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName])+partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do+  let mTargets = resolveTargets+        selectPackageTargets+        selectComponentTarget+        elaboratedPlan+        (Just pkgDb)+        targetSelectors+  case mTargets of+    Right targets ->+      -- Everything is a local dependency.+      return (targets, [])+    Left errs     -> do+      -- Not everything is local.+      let+        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case+          TargetAvailableInIndex name -> Right name+          err                         -> Left err++      -- report incorrect case for known package.+      for_ errs' $ \case+        TargetNotInProject hn ->+          case searchByName (packageIndex pkgDb) (unPackageName hn) of+            [] -> return ()+            xs -> die' verbosity . concat $+              [ "Unknown package \"", unPackageName hn, "\". "+              , "Did you mean any of the following?\n"+              , unlines (("- " ++) . unPackageName . fst <$> xs)+              ]+        _ -> return ()++      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'++      let+        targetSelectors' = flip filter targetSelectors $ \case+          TargetComponentUnknown name _ _+            | name `elem` hackageNames -> False+          TargetPackageNamed name _+            | name `elem` hackageNames -> False+          _                            -> True++      -- This can't fail, because all of the errors are+      -- removed (or we've given up).+      targets <-+        either (reportBuildTargetProblems verbosity) return $+        resolveTargets+          selectPackageTargets+          selectComponentTarget+          elaboratedPlan+          Nothing+          targetSelectors'++      return (targets, hackageNames)++++constructProjectBuildContext+  :: Verbosity+  -> ProjectBaseContext+     -- ^ The synthetic base context to use to produce the full build context.+  -> [TargetSelector]+  -> IO ProjectBuildContext+constructProjectBuildContext verbosity baseCtx targetSelectors = do+  runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do+    -- Interpret the targets on the command line as build targets+    targets <- either (reportBuildTargetProblems verbosity) return $+      resolveTargets+        selectPackageTargets+        selectComponentTarget+        elaboratedPlan+        Nothing+        targetSelectors++    let prunedToTargetsElaboratedPlan =+          pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan+    prunedElaboratedPlan <-+      if buildSettingOnlyDeps (buildSettings baseCtx)+      then either (reportCannotPruneDependencies verbosity) return $+           pruneInstallPlanToDependencies (Map.keysSet targets)+                                          prunedToTargetsElaboratedPlan+      else return prunedToTargetsElaboratedPlan++    return (prunedElaboratedPlan, targets)++ -- | Install any built exe by symlinking/copying it -- we don't use BuildOutcomes because we also need the component names installExes@@ -635,6 +582,7 @@   -> IO () installExes verbosity baseCtx buildCtx platform compiler             configFlags clientInstallFlags = do+  installPath <- defaultInstallPath   let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx        prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))@@ -652,12 +600,17 @@       mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform       installdirUnknown =         "installdir is not defined. Set it in your cabal config file "-        ++ "or use --installdir=<path>"+        ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath -  installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) $+  installdir <- fromFlagOrDefault+                (warn verbosity installdirUnknown >> pure installPath) $                 pure <$> cinstInstalldir clientInstallFlags   createDirectoryIfMissingVerbose verbosity False installdir   warnIfNoExes verbosity buildCtx++  installMethod <- flagElim defaultMethod return $+    cinstInstallMethod clientInstallFlags+   let     doInstall = installUnitExes                   verbosity@@ -668,9 +621,19 @@   where     overwritePolicy = fromFlagOrDefault NeverOverwrite $                       cinstOverwritePolicy clientInstallFlags-    installMethod   = fromFlagOrDefault InstallMethodSymlink $-                      cinstInstallMethod clientInstallFlags+    isWindows = buildOS == Windows +    -- This is in IO as we will make environment checks,+    -- to decide which method is best+    defaultMethod :: IO InstallMethod+    defaultMethod+      -- Try symlinking in temporary directory, if it works default to+      -- symlinking even on windows+      | isWindows = do+        symlinks <- trySymlink verbosity+        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy+      | otherwise = return InstallMethodSymlink+ -- | Install any built library by adding it to the default ghc environment installLibraries   :: Verbosity@@ -714,10 +677,14 @@ warnIfNoExes verbosity buildCtx =   when noExes $     warn verbosity $-    "You asked to install executables, but there are no executables in "-    <> plural (listPlural selectors) "target" "targets" <> ": "-    <> intercalate ", " (showTargetSelector <$> selectors) <> ". "-    <> "Perhaps you want to use --lib to install libraries instead."+    "\n" <>+    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>+    "@ WARNING: Installation might not be completed as desired! @\n" <>+    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>+    "Without flags, the command \"cabal install\" doesn't expose" <>+    " libraries in a usable manner.  You might have wanted to run" <>+    " \"cabal install --lib " <>+    unwords (showTargetSelector <$> selectors) <> "\". "   where     targets    = concat $ Map.elems $ targetsMap buildCtx     components = fst <$> targets@@ -736,6 +703,19 @@   , "bin-package-db"   ] +-- | Return the package specifiers and non-global environment file entries.+getEnvSpecsAndNonGlobalEntries+  :: PI.InstalledPackageIndex+  -> [GhcEnvironmentFileEntry]+  -> Bool+  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])+getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =+  if installLibs+  then (envSpecs, envEntries')+  else ([], envEntries')+  where+    (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries+ environmentFileToSpecifiers   :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]   -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])@@ -814,24 +794,26 @@ installBuiltExe verbosity overwritePolicy                 sourceDir exeName finalExeName                 installdir InstallMethodSymlink = do-  notice verbosity $ "Symlinking '" <> exeName <> "'"+  notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"   symlinkBinary     overwritePolicy     installdir     sourceDir     finalExeName     exeName+  where+    destination = installdir </> finalExeName installBuiltExe verbosity overwritePolicy                 sourceDir exeName finalExeName                 installdir InstallMethodCopy = do-  notice verbosity $ "Copying '" <> exeName <> "'"+  notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"   exists <- doesPathExist destination   case (exists, overwritePolicy) of     (True , NeverOverwrite ) -> pure False     (True , AlwaysOverwrite) -> remove >> copy     (False, _              ) -> copy   where-    source = sourceDir </> exeName+    source      = sourceDir </> exeName     destination = installdir </> finalExeName     remove = do       isDir <- doesDirectoryExist destination@@ -855,63 +837,73 @@       | any hasLib targets = [GhcEnvFilePackageId unitId]       | otherwise          = [] --- | Create a dummy project context, without a .cabal or a .cabal.project file--- (a place where to put a temporary dist directory is still needed)-establishDummyProjectBaseContext-  :: Verbosity-  -> ProjectConfig-  -> FilePath-     -- ^ Where to put the dist directory-  -> [PackageSpecifier UnresolvedSourcePackage]-     -- ^ The packages to be included in the project-  -> CurrentCommand-  -> IO ProjectBaseContext-establishDummyProjectBaseContext verbosity cliConfig tmpDir-                                 localPackages currentCommand = do-    cabalDir <- getCabalDir -    -- Create the dist directories-    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout-    createDirectoryIfMissingVerbose verbosity True $-      distProjectCacheDirectory distDirLayout--    globalConfig <- runRebuild ""-                  $ readGlobalConfig verbosity-                  $ projectConfigConfigFile-                  $ projectConfigShared cliConfig-    let projectConfig = globalConfig <> cliConfig--    let ProjectConfigBuildOnly {-          projectConfigLogsDir-        } = projectConfigBuildOnly projectConfig+-- | Gets the file path to the request environment file.+getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath+getEnvFile clientInstallFlags platform compilerVersion = do+  appDir <- getGhcAppDir+  case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of+    Just spec+      -- Is spec a bare word without any "pathy" content, then it refers to+      -- a named global environment.+      | takeBaseName spec == spec ->+          return (getGlobalEnv appDir platform compilerVersion spec)+      | otherwise                 -> do+        spec' <- makeAbsolute spec+        isDir <- doesDirectoryExist spec'+        if isDir+          -- If spec is a directory, then make an ambient environment inside+          -- that directory.+          then return (getLocalEnv spec' platform compilerVersion)+          -- Otherwise, treat it like a literal file path.+          else return spec'+    Nothing                       ->+      return (getGlobalEnv appDir platform compilerVersion "default") -        ProjectConfigShared {-          projectConfigStoreDir-        } = projectConfigShared projectConfig+-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the+--   environment being operated on.+getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]+getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do+  envFileExists <- doesFileExist envFile+  filterEnvEntries <$> if+    (compilerFlavor == GHC || compilerFlavor == GHCJS)+      && supportsPkgEnvFiles && envFileExists+    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->+      warn verbosity ("The environment file " ++ envFile +++        " is unparsable. Libraries cannot be installed.") >> return []+    else return []+  where+    -- Why? We know what the first part will be, we only care about the packages.+    filterEnvEntries = filter $ \case+      GhcEnvFilePackageId _ -> True+      _                     -> False -        mlogsDir = flagToMaybe projectConfigLogsDir-        mstoreDir = flagToMaybe projectConfigStoreDir-        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir+-- | Constructs the path to the global GHC environment file.+--+-- TODO(m-renaud): Create PkgEnvName newtype wrapper.+getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath+getGlobalEnv appDir platform compilerVersion name =+  appDir </> ghcPlatformAndVersionString platform compilerVersion+  </> "environments" </> name -        buildSettings = resolveBuildTimeSettings-                          verbosity cabalDirLayout-                          projectConfig+-- | Constructs the path to a local GHC environment file.+getLocalEnv :: FilePath -> Platform -> Version -> FilePath+getLocalEnv dir platform compilerVersion  =+  dir </>+  ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion -    return ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages,-      buildSettings,-      currentCommand-    }-  where-    mdistDirectory = flagToMaybe-                   $ projectConfigDistDir-                   $ projectConfigShared cliConfig-    projectRoot = ProjectRootImplicit tmpDir-    distDirLayout = defaultDistDirLayout projectRoot-                                         mdistDirectory+getPackageDbStack+  :: CompilerId+  -> Flag FilePath+  -> Flag FilePath+  -> IO PackageDBStack+getPackageDbStack compilerId storeDirFlag logsDirFlag = do+  cabalDir <- getCabalDir+  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag+  let+    mlogsDir    = flagToMaybe logsDirFlag+    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir+  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId  -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,@@ -923,7 +915,7 @@ -- selectPackageTargets   :: TargetSelector-  -> [AvailableTarget k] -> Either TargetProblem [k]+  -> [AvailableTarget k] -> Either TargetProblem' [k] selectPackageTargets targetSelector targets      -- If there are any buildable targets then we select those@@ -957,36 +949,11 @@ -- selectComponentTarget   :: SubComponentTarget-  -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget subtarget =-    either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic subtarget----- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @build@ command.----data TargetProblem =-     TargetProblemCommon       TargetProblemCommon--     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector-  deriving (Eq, Show)--reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem+  -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "build" problem-renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "build" targetSelector targets-renderTargetProblem(TargetProblemNoTargets targetSelector) =-    renderTargetProblemNoTargets "build" targetSelector+reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems  reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity =
Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -8,28 +8,24 @@ ) where  import Distribution.Client.Compat.Prelude+import Prelude ()  import Distribution.ReadE-         ( ReadE(..), succeedReadE )+         ( succeedReadE, parsecToReadE ) import Distribution.Simple.Command          ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) import Distribution.Simple.Setup          ( Flag(..), trueArg, flagToList, toFlag ) -import Distribution.Client.InstallSymlink+import Distribution.Client.Types.InstallMethod+         ( InstallMethod (..) )+import Distribution.Client.Types.OverwritePolicy          ( OverwritePolicy(..) ) --data InstallMethod = InstallMethodCopy-                   | InstallMethodSymlink-  deriving (Eq, Show, Generic, Bounded, Enum)--instance Binary InstallMethod-instance Structured InstallMethod+import qualified Distribution.Compat.CharParsing as P  data ClientInstallFlags = ClientInstallFlags   { cinstInstallLibs     :: Flag Bool-  , cinstIgnoreProject   :: Flag Bool   , cinstEnvironmentPath :: Flag FilePath   , cinstOverwritePolicy :: Flag OverwritePolicy   , cinstInstallMethod   :: Flag InstallMethod@@ -49,7 +45,6 @@ defaultClientInstallFlags :: ClientInstallFlags defaultClientInstallFlags = ClientInstallFlags   { cinstInstallLibs     = toFlag False-  , cinstIgnoreProject   = toFlag False   , cinstEnvironmentPath = mempty   , cinstOverwritePolicy = mempty   , cinstInstallMethod   = mempty@@ -62,10 +57,6 @@     "Install libraries rather than executables from the target package."     cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })     trueArg-  , option "z" ["ignore-project"]-    "Ignore local project configuration"-    cinstIgnoreProject (\v flags -> flags { cinstIgnoreProject = v })-    trueArg   , option [] ["package-env", "env"]     "Set the environment file that may be modified."     cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })@@ -73,41 +64,26 @@   , option [] ["overwrite-policy"]     "How to handle already existing symlinks."     cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })-    $ reqArg-        "always|never"-        readOverwritePolicyFlag-        showOverwritePolicyFlag+    $ reqArg "always|never"+        (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) +        (map prettyShow . flagToList)   , option [] ["install-method"]     "How to install the executables."     cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })     $ reqArg-        "copy|symlink"-        readInstallMethodFlag-        showInstallMethodFlag+        "default|copy|symlink"+        (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod))+        (map prettyShow . flagToList)   , option [] ["installdir"]     "Where to install (by symlinking or copying) the executables in."     cinstInstalldir (\v flags -> flags { cinstInstalldir = v })     $ reqArg "DIR" (succeedReadE Flag) flagToList   ] -readOverwritePolicyFlag :: ReadE (Flag OverwritePolicy)-readOverwritePolicyFlag = ReadE $ \case-  "always" -> Right $ Flag AlwaysOverwrite-  "never"  -> Right $ Flag NeverOverwrite-  policy   -> Left  $ "'" <> policy <> "' isn't a valid overwrite policy"--showOverwritePolicyFlag :: Flag OverwritePolicy -> [String]-showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"]-showOverwritePolicyFlag (Flag NeverOverwrite)  = ["never"]-showOverwritePolicyFlag NoFlag                 = []--readInstallMethodFlag :: ReadE (Flag InstallMethod)-readInstallMethodFlag = ReadE $ \case-  "copy"    -> Right $ Flag InstallMethodCopy-  "symlink" -> Right $ Flag InstallMethodSymlink-  method    -> Left  $ "'" <> method <> "' isn't a valid install-method"--showInstallMethodFlag :: Flag InstallMethod -> [String]-showInstallMethodFlag (Flag InstallMethodCopy)    = ["copy"]-showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"]-showInstallMethodFlag NoFlag                      = []+parsecInstallMethod :: CabalParsing m => m InstallMethod+parsecInstallMethod = do+    name <- P.munch1 isAlpha+    case name of+        "copy"    -> pure InstallMethodCopy+        "symlink" -> pure InstallMethodSymlink+        _         -> P.unexpected $ "InstallMethod: " ++ name
+ Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs view
@@ -0,0 +1,68 @@+module Distribution.Client.CmdInstall.ClientInstallTargetSelector (+    WithoutProjectTargetSelector (..),+    parseWithoutProjectTargetSelector,+    woPackageNames,+    woPackageTargets,+    woPackageSpecifiers,+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI, parseURI)++import Distribution.Client.TargetSelector+import Distribution.Client.Types+import Distribution.Compat.CharParsing             (char, optional)+import Distribution.Package+import Distribution.Simple.LocalBuildInfo          (ComponentName (CExeName))+import Distribution.Simple.Utils                   (die')+import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))+import Distribution.Version++data WithoutProjectTargetSelector+    = WoPackageId PackageId+    | WoPackageComponent PackageId ComponentName+    | WoURI URI+  deriving (Show)++parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector+parseWithoutProjectTargetSelector verbosity input =+    case explicitEitherParsec parser input of+        Right ts -> return ts+        Left err -> case parseURI input of+            Just uri -> return (WoURI uri)+            Nothing  -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err+  where+    parser :: CabalParsing m => m WithoutProjectTargetSelector+    parser = do+        pid <- parsec+        cn  <- optional (char ':' *> parsec)+        return $ case cn of+            Nothing -> WoPackageId pid+            Just cn' -> WoPackageComponent pid (CExeName cn')++woPackageNames  :: WithoutProjectTargetSelector -> [PackageName]+woPackageNames (WoPackageId pid)          = [pkgName pid]+woPackageNames (WoPackageComponent pid _) = [pkgName pid]+woPackageNames (WoURI _)                  = []++woPackageTargets  :: WithoutProjectTargetSelector -> TargetSelector+woPackageTargets (WoPackageId pid) =+    TargetPackageNamed (pkgName pid) Nothing+woPackageTargets (WoPackageComponent pid cn) =+    TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent+woPackageTargets (WoURI _) =+    TargetAllPackages (Just ExeKind)++woPackageSpecifiers  :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)+woPackageSpecifiers (WoPackageId pid)          = Right (pidPackageSpecifiers pid)+woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)+woPackageSpecifiers (WoURI uri)                = Left uri++pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg+pidPackageSpecifiers pid+    | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []+    | otherwise                     = NamedPackage (pkgName pid)+        [ PackagePropertyVersion (thisVersion (pkgVersion pid))+        ]
Distribution/Client/CmdLegacy.hs view
@@ -16,11 +16,11 @@ import Distribution.Simple.Command import Distribution.Simple.Utils     ( wrapText )-import Distribution.Verbosity -    ( Verbosity, normal )+import Distribution.Verbosity+    ( normal )  import Control.Exception-    ( SomeException(..), try )+    ( try ) import qualified Data.Text as T  -- Tweaked versions of code from Main.@@ -39,7 +39,7 @@     let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)      load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)-    let config = either (\(SomeException _) -> mempty) snd load+    let config = either (\(SomeException _) -> mempty) id load     distPref <- findSavedDistPref config (distPrefFlag flags)     let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } @@ -50,7 +50,7 @@  -- -class HasVerbosity a where +class HasVerbosity a where     verbosity :: a -> Verbosity  instance HasVerbosity (Setup.Flag Verbosity) where@@ -59,8 +59,8 @@ instance (HasVerbosity a) => HasVerbosity (a, b) where     verbosity (a, _) = verbosity a -instance (HasVerbosity b) => HasVerbosity (a, b, c) where-    verbosity (_ , b, _) = verbosity b+instance (HasVerbosity a) => HasVerbosity (a, b, c) where+    verbosity (a , _, _) = verbosity a  instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where     verbosity (a, _, _, _) = verbosity a@@ -95,12 +95,6 @@ instance HasVerbosity Setup.CleanFlags where     verbosity = verbosity . Setup.cleanVerbosity -instance HasVerbosity Client.SDistFlags where-    verbosity = verbosity . Client.sDistVerbosity--instance HasVerbosity Client.SandboxFlags where-    verbosity = verbosity . Client.sandboxVerbosity- instance HasVerbosity Setup.DoctestFlags where     verbosity = verbosity . Setup.doctestVerbosity @@ -140,17 +134,17 @@         cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand          newMsg = T.unpack . T.replace "v2-" "new-" . T.pack-        newUi = origUi +        newUi = origUi             { commandName = newMsg commandName             , commandUsage = newMsg . commandUsage             , commandDescription = (newMsg .) <$> commandDescription-            , commandNotes = (newMsg .) <$> commandDescription+            , commandNotes = (newMsg .) <$> commandNotes             }          defaultMsg = T.unpack . T.replace "v2-" "" . T.pack-        defaultUi = origUi +        defaultUi = origUi             { commandName = defaultMsg commandName             , commandUsage = defaultMsg . commandUsage             , commandDescription = (defaultMsg .) <$> commandDescription-            , commandNotes = (defaultMsg .) <$> commandDescription+            , commandNotes = (defaultMsg .) <$> commandNotes             }
+ Distribution/Client/CmdListBin.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-}+module Distribution.Client.CmdListBin (+    listbinCommand,+    listbinAction,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.CmdErrorMessages+       (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,+       renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)+import Distribution.Client.DistDirLayout         (DistDirLayout (..), ProjectRoot (..))+import Distribution.Client.NixStyleOptions+       (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)+import Distribution.Client.ProjectConfig+       (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig)+import Distribution.Client.ProjectFlags          (ProjectFlags (..))+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.Setup                 (GlobalFlags (..))+import Distribution.Client.TargetProblem         (TargetProblem (..))+import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)+import Distribution.Simple.Command               (CommandUI (..))+import Distribution.Simple.Setup                 (configVerbosity, fromFlagOrDefault)+import Distribution.Simple.Utils                 (die', ordNub, wrapText)+import Distribution.System                       (Platform)+import Distribution.Types.ComponentName          (showComponentName)+import Distribution.Types.UnitId                 (UnitId)+import Distribution.Types.UnqualComponentName    (UnqualComponentName)+import Distribution.Verbosity                    (silent, verboseStderr)+import System.Directory                          (getCurrentDirectory)+import System.FilePath                           ((<.>), (</>))++import qualified Data.Map                                as Map+import qualified Data.Set                                as Set+import qualified Distribution.Client.InstallPlan         as IP+import qualified Distribution.Simple.InstallDirs         as InstallDirs+import qualified Distribution.Solver.Types.ComponentDeps as CD++-------------------------------------------------------------------------------+-- Command+-------------------------------------------------------------------------------++listbinCommand :: CommandUI (NixStyleFlags ())+listbinCommand = CommandUI+    { commandName = "list-bin"+    , commandSynopsis = "list path to a single executable."+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"+    , commandDescription  = Just $ \_ -> wrapText+        "List path to a build product."+    , commandNotes = Nothing+    , commandDefaultFlags = defaultNixStyleFlags ()+    , commandOptions      = nixStyleOptions (const [])+    }++-------------------------------------------------------------------------------+-- Action+-------------------------------------------------------------------------------++listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+listbinAction flags@NixStyleFlags{..} args globalFlags = do+    -- fail early if multiple target selectors specified+    target <- case args of+        []  -> die' verbosity "One target is required, none provided"+        [x] -> return x+        _   -> die' verbosity "One target is required, given multiple"++    -- configure+    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject+    let localPkgs = localPackages baseCtx++    -- elaborate target selectors+    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+        =<< readTargetSelectors localPkgs Nothing [target]++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do+            -- Interpret the targets on the command line as build targets+            -- (as opposed to say repl or haddock targets).+            targets <- either (reportTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            -- Reject multiple targets, or at least targets in different+            -- components. It is ok to have two module/file targets in the+            -- same component, but not two that live in different components.+            --+            -- Note that we discard the target and return the whole 'TargetsMap',+            -- so this check will be repeated (and must succeed) after+            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.+            _ <- singleComponentOrElse+                   (reportTargetProblems+                      verbosity+                      [multipleTargetsProblem targets])+                   targets++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    (selectedUnitId, _selectedComponent) <-+      -- Slight duplication with 'runProjectPreBuildPhase'.+      singleComponentOrElse+        (die' verbosity $ "No or multiple targets given, but the run "+                       ++ "phase has been reached. This is a bug.")+        $ targetsMap buildCtx++    printPlan verbosity baseCtx buildCtx++    binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of+        Nothing  -> die' verbosity "No or multiple targets given..."+        Just gpp -> return $ IP.foldPlanPackage+            (const []) -- IPI don't have executables+            (elaboratedPackage distDirLayout (elaboratedShared buildCtx))+            gpp++    case binfiles of+        [exe] -> putStrLn exe+        _     -> die' verbosity "No or multiple targets given"+  where+    defaultVerbosity = verboseStderr silent+    verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)+    ignoreProject = flagIgnoreProject projectFlags+    prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here+    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)++    withProject :: IO (ProjectBaseContext, DistDirLayout)+    withProject = do+        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)+    withoutProject config = do+        cwd <- getCurrentDirectory+        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    -- this is copied from+    elaboratedPackage+        :: DistDirLayout+        -> ElaboratedSharedConfig+        -> ElaboratedConfiguredPackage+        -> [FilePath]+    elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of+        ElabPackage pkg ->+            [ bin+            | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg)+                                           (pkgExeDependencies pkg)+            , bin <- bin_file c+            ]+        ElabComponent comp -> bin_file (compSolverName comp)+      where+        dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)++        bin_file c = case c of+            CD.ComponentExe s   -> [bin_file' s]+            CD.ComponentTest s  -> [bin_file' s]+            CD.ComponentBench s -> [bin_file' s]+            CD.ComponentFLib s  -> [flib_file' s]+            _                -> []++        plat :: Platform+        plat = pkgConfigPlatform elaboratedSharedConfig++        -- here and in PlanOutput,+        -- use binDirectoryFor?+        bin_file' s =+            if elabBuildStyle elab == BuildInplaceOnly+            then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat+            else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat++        flib_file' s =+            if elabBuildStyle elab == BuildInplaceOnly+            then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat+            else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat++-------------------------------------------------------------------------------+-- Target Problem: the very similar to CmdRun+-------------------------------------------------------------------------------++singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)+singleComponentOrElse action targetsMap =+  case Set.toList . distinctTargetComponents $ targetsMap+  of [(unitId, CExeName component)] -> return (unitId, component)+     [(unitId, CTestName component)] -> return (unitId, component)+     [(unitId, CBenchName component)] -> return (unitId, component)+     [(unitId, CFLibName component)] -> return (unitId, component)+     _   -> action++-- | This defines what a 'TargetSelector' means for the @list-bin@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @list-bin@ command we select the exe or flib if there is only one+-- and it's buildable. Fail if there are no or multiple buildable exe components.+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either ListBinTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there is exactly one buildable executable then we select that+  | [target] <- targetsExesBuildable+  = Right [target]++    -- but fail if there are multiple buildable executables.+  | not (null targetsExesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')++    -- If there are executables but none are buildable then we report those+  | not (null targetsExes)+  = Left (TargetProblemNoneEnabled targetSelector targetsExes)++    -- If there are no executables but some other targets then we report that+  | not (null targets)+  = Left (noComponentsProblem targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    -- Targets that can be executed+    targetsExecutableLike =+      concatMap (\kind -> filterTargetsKind kind targets)+                [ExeKind, TestKind, BenchKind]+    (targetsExesBuildable,+     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike++    targetsExes             = forgetTargetsDetail targetsExecutableLike+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @run@ command we just need to check it is a executable-like+-- (an executable, a test, or a benchmark), in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either ListBinTargetProblem  k+selectComponentTarget subtarget@WholeComponent t+  = case availableTargetComponentName t+    of CExeName _ -> component+       CTestName _ -> component+       CBenchName _ -> component+       CFLibName _ -> component+       _ -> Left (componentNotRightKindProblem pkgid cname)+    where pkgid = availableTargetPackageId t+          cname = availableTargetComponentName t+          component = selectComponentTargetBasic subtarget t++selectComponentTarget subtarget t+  = Left (isSubComponentProblem (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.+--+data ListBinProblem =+     -- | The 'TargetSelector' matches targets but no executables+     TargetProblemNoRightComps      TargetSelector++     -- | A single 'TargetSelector' matches multiple targets+   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]++     -- | Multiple 'TargetSelector's match multiple targets+   | TargetProblemMultipleTargets TargetsMap++     -- | The 'TargetSelector' refers to a component that is not an executable+   | TargetProblemComponentNotRightKind PackageId ComponentName++     -- | Asking to run an individual file or module is not supported+   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget+  deriving (Eq, Show)++type ListBinTargetProblem = TargetProblem ListBinProblem++noComponentsProblem :: TargetSelector -> ListBinTargetProblem+noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps++matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem+matchesMultipleProblem selector targets = CustomTargetProblem $+    TargetProblemMatchesMultiple selector targets++multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets++componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem+componentNotRightKindProblem pkgid name = CustomTargetProblem $+    TargetProblemComponentNotRightKind pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem ListBinProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderListBinTargetProblem++renderListBinTargetProblem :: ListBinTargetProblem -> String+renderListBinTargetProblem (TargetProblemNoTargets targetSelector) =+    case targetSelectorFilter targetSelector of+      Just kind | kind /= ExeKind+        -> "The list-bin command is for finding binaries, but the target '"+           ++ showTargetSelector targetSelector ++ "' refers to "+           ++ renderTargetSelector targetSelector ++ "."++      _ -> renderTargetProblemNoTargets "list-bin" targetSelector+renderListBinTargetProblem problem =+    renderTargetProblem "list-bin" renderListBinProblem problem++renderListBinProblem :: ListBinProblem -> String+renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =+    "The list-bin command is for finding a single binary at once. The target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " which includes "+ ++ renderListCommaAnd ( ("the "++) <$>+                         showComponentName <$>+                         availableTargetComponentName <$>+                         foldMap+                           (\kind -> filterTargetsKind kind targets)+                           [ExeKind, TestKind, BenchKind] )+ ++ "."++renderListBinProblem (TargetProblemMultipleTargets selectorMap) =+    "The list-bin command is for finding a single binary at once. The targets "+ ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"+                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]+ ++ " refer to different executables."++renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =+    "The list-bin command is for finding binaries, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ prettyShow pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+    "The list-bin command can only find a binary as a whole, "+ ++ "not files or modules within them, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ "."+  where+    targetSelector = TargetComponent pkgid cname subtarget++renderListBinProblem (TargetProblemNoRightComps targetSelector) =+    "Cannot list-bin the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any executables or foreign libraries."
Distribution/Client/CmdRepl.hs view
@@ -12,7 +12,7 @@     replAction,      -- * Internals exposed for testing-    TargetProblem(..),+    matchesMultipleProblem,     selectPackageTargets,     selectComponentTarget   ) where@@ -23,31 +23,39 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L +import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.CmdErrorMessages-import Distribution.Client.CmdInstall-         ( establishDummyProjectBaseContext )+         ( renderTargetSelector, showTargetSelector,+           renderTargetProblem,+           targetSelectorRefersToPkgs,+           renderComponentKind, renderListCommaAnd, renderListSemiAnd,+           componentKind, sortGroupOn, Plural(..) )+import Distribution.Client.TargetProblem+         ( TargetProblem(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.ProjectBuilding          ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), withProjectOrGlobalConfigIgn+         ( ProjectConfig(..), withProjectOrGlobalConfig          , projectConfigConfigFile )+import Distribution.Client.ProjectFlags+         ( flagIgnoreProject ) import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning        ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types        ( elabOrderExeDependencies ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+         ( GlobalFlags, ConfigFlags(..) ) import qualified Distribution.Client.Setup as Client import Distribution.Client.Types          ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags-         , fromFlagOrDefault, replOptions-         , Flag(..), toFlag, trueArg, falseArg )+         ( fromFlagOrDefault, replOptions+         , Flag(..), toFlag, falseArg ) import Distribution.Simple.Command-         ( CommandUI(..), liftOption, usageAlternatives, option+         ( CommandUI(..), liftOptionL, usageAlternatives, option          , ShowOrParseArgs, OptionField, reqArg ) import Distribution.Compiler          ( CompilerFlavor(GHC) )@@ -57,9 +65,7 @@          ( Package(..), packageName, UnitId, installedUnitId ) import Distribution.PackageDescription.PrettyPrint import Distribution.Parsec-         ( Parsec(..), parsecCommaList )-import Distribution.Pretty-         ( prettyShow )+         ( parsecCommaList ) import Distribution.ReadE          ( ReadE, parsecToReadE ) import qualified Distribution.SPDX.License as SPDX@@ -72,11 +78,9 @@ import Distribution.Types.CondTree          ( CondTree(..), traverseCondTreeC ) import Distribution.Types.Dependency-         ( Dependency(..) )+         ( Dependency(..), mainLibSet ) import Distribution.Types.GenericPackageDescription          ( emptyGenericPackageDescription )-import Distribution.Types.LibraryName-         ( LibraryName(..) ) import Distribution.Types.PackageDescription          ( PackageDescription(..), emptyPackageDescription ) import Distribution.Types.PackageName.Magic@@ -87,16 +91,16 @@          ( mkVersion ) import Distribution.Types.VersionRange          ( anyVersion )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Utils.Generic          ( safeHead ) import Distribution.Verbosity-         ( Verbosity, normal, lessVerbose )+         ( normal, lessVerbose ) import Distribution.Simple.Utils          ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) import Language.Haskell.Extension          ( Language(..) )+import Distribution.CabalSpecVersion+         ( CabalSpecVersion (..) )  import Data.List          ( (\\) )@@ -109,45 +113,36 @@  type ReplFlags = [String] -data EnvFlags = EnvFlags +data EnvFlags = EnvFlags   { envPackages :: [Dependency]   , envIncludeTransitive :: Flag Bool-  , envIgnoreProject :: Flag Bool   }  defaultEnvFlags :: EnvFlags defaultEnvFlags = EnvFlags   { envPackages = []   , envIncludeTransitive = toFlag True-  , envIgnoreProject = toFlag False   }  envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] envOptions _ =   [ option ['b'] ["build-depends"]-    "Include an additional package in the environment presented to GHCi."+    "Include additional packages in the environment presented to GHCi."     envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })-    (reqArg "DEPENDENCY" dependencyReadE (fmap prettyShow :: [Dependency] -> [String]))+    (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String]))   , option [] ["no-transitive-deps"]     "Don't automatically include transitive dependencies of requested packages."     envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })     falseArg-  , option ['z'] ["ignore-project"]-    "Only include explicitly specified packages (and 'base')."-    envIgnoreProject (\p flags -> flags { envIgnoreProject = p })-    trueArg   ]   where-    dependencyReadE :: ReadE [Dependency]-    dependencyReadE =+    dependenciesReadE :: ReadE [Dependency]+    dependenciesReadE =       parsecToReadE-        ("couldn't parse dependency: " ++)+        ("couldn't parse dependencies: " ++)         (parsecCommaList parsec) -replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                         , HaddockFlags, TestFlags, BenchmarkFlags-                         , ReplFlags, EnvFlags-                         )+replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags)) replCommand = Client.installCommand {   commandName         = "v2-repl",   commandSynopsis     = "Open an interactive session for the given component.",@@ -182,34 +177,13 @@         ++ "(or no componentif there is no project present)\n"      ++ "  " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"      ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "-        ++ "to the default component (or no component if there is no project present)\n"--     ++ cmdCommonHelpTextNewBuildBeta,-  commandDefaultFlags = ( configFlags, configExFlags, installFlags-                        , haddockFlags, testFlags, benchmarkFlags-                        , [], defaultEnvFlags-                        ),-  commandOptions = \showOrParseArgs ->-        map liftOriginal (commandOptions Client.installCommand showOrParseArgs)-        ++ map liftReplOpts (replOptions showOrParseArgs)-        ++ map liftEnvOpts  (envOptions  showOrParseArgs)-   }-  where-    (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags)-      = commandDefaultFlags Client.installCommand--    liftOriginal = liftOption projectOriginal updateOriginal-    liftReplOpts = liftOption projectReplOpts updateReplOpts-    liftEnvOpts  = liftOption projectEnvOpts  updateEnvOpts--    projectOriginal              (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f)-    updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h)--    projectReplOpts  (_,_,_,_,_,_,g,_) = g-    updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h)+        ++ "to the default component (or no component if there is no project present)\n", -    projectEnvOpts  (_,_,_,_,_,_,_,h) = h-    updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h)+  commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags),+  commandOptions = nixStyleOptions $ \showOrParseArgs ->+    map (liftOptionL _1) (replOptions showOrParseArgs) +++    map (liftOptionL _2) (envOptions showOrParseArgs)+  }  -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit@@ -222,21 +196,14 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-              , HaddockFlags, TestFlags, BenchmarkFlags-              , ReplFlags, EnvFlags )-           -> [String] -> GlobalFlags -> IO ()-replAction ( configFlags, configExFlags, installFlags-           , haddockFlags, testFlags, benchmarkFlags-           , replFlags, envFlags )-           targetStrings globalFlags = do+replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()+replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do     let-      ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags)       with           = withProject    cliConfig             verbosity targetStrings       without config = withoutProject (config <> cliConfig) verbosity targetStrings-    +     (baseCtx, targetSelectors, finalizer, replType) <--      withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without+      withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without      when (buildSettingOnlyDeps (buildSettings baseCtx)) $       die' verbosity $ "The repl command does not support '--only-dependencies'. "@@ -252,38 +219,38 @@         withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do           -- targets should be non-empty map, but there's no NonEmptyMap yet.           targets <- validatedTargets elaboratedPlan targetSelectors-          +           let             (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets             originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId             oci = OriginalComponentInfo unitId originalDeps-            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId +            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId             baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx            return (Just oci, baseCtx')-          -    -- Now, we run the solver again with the added packages. While the graph ++    -- Now, we run the solver again with the added packages. While the graph     -- won't actually reflect the addition of transitive dependencies,     -- they're going to be available already and will be offered to the REPL     -- and that's good enough.     ---    -- In addition, to avoid a *third* trip through the solver, we are +    -- In addition, to avoid a *third* trip through the solver, we are     -- replicating the second half of 'runProjectPreBuildPhase' by hand     -- here.     (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $       \elaboratedPlan elaboratedShared' -> do         let ProjectBaseContext{..} = baseCtx'-          +         -- Recalculate with updated project.         targets <- validatedTargets elaboratedPlan targetSelectors -        let +        let           elaboratedPlan' = pruneInstallPlanToTargets                               TargetActionRepl                               targets                               elaboratedPlan           includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)-        +         pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'                                           elaboratedPlan' @@ -291,26 +258,26 @@                                 pkgsBuildStatus elaboratedPlan'         debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') -        let -          buildCtx = ProjectBuildContext +        let+          buildCtx = ProjectBuildContext             { elaboratedPlanOriginal = elaboratedPlan             , elaboratedPlanToExecute = elaboratedPlan''             , elaboratedShared = elaboratedShared'             , pkgsBuildStatus             , targetsMap = targets             }-          +           ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared'-          +           -- First version of GHC where GHCi supported the flag we need.           -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html           minGhciScriptVersion = mkVersion [7, 6] -          replFlags' = case originalComponent of +          replFlags' = case originalComponent of             Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci             Nothing  -> []           replFlags'' = case replType of-            GlobalRepl scriptPath +            GlobalRepl scriptPath               | Just version <- compilerCompatVersion GHC compiler               , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags'             _                                   -> replFlags'@@ -328,13 +295,10 @@     finalizer   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags-                  mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)-    +     validatedTargets elaboratedPlan targetSelectors = do       -- Interpret the targets on the command line as repl targets       -- (as opposed to say build or haddock targets).@@ -342,7 +306,6 @@           $ resolveTargets               selectPackageTargets               selectComponentTarget-              TargetProblemCommon               elaboratedPlan               Nothing               targetSelectors@@ -352,7 +315,7 @@       -- same component, but not two that live in different components.       when (Set.size (distinctTargetComponents targets) > 1) $         reportTargetProblems verbosity-          [TargetProblemMultipleTargets targets]+          [multipleTargetsProblem targets]        return targets @@ -363,7 +326,7 @@   deriving (Show)  -- | Tracks what type of GHCi instance we're creating.-data ReplType = ProjectRepl +data ReplType = ProjectRepl               | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi                                     --   script responsible for changing to the                                     --   correct directory. Only works on GHC geq@@ -392,17 +355,17 @@   -- We need to create a dummy package that lives in our dummy project.   let     sourcePackage = SourcePackage-      { packageInfoId        = pkgId-      , packageDescription   = genericPackageDescription-      , packageSource        = LocalUnpackedPackage tempDir-      , packageDescrOverride = Nothing+      { srcpkgPackageId     = pkgId+      , srcpkgDescription   = genericPackageDescription+      , srcpkgSource        = LocalUnpackedPackage tempDir+      , srcpkgDescrOverride = Nothing       }-    genericPackageDescription = emptyGenericPackageDescription +    genericPackageDescription = emptyGenericPackageDescription       & L.packageDescription .~ packageDescription       & L.condLibrary        .~ Just (CondNode library [baseDep] [])     packageDescription = emptyPackageDescription       { package = pkgId-      , specVersionRaw = Left (mkVersion [2, 2])+      , specVersion = CabalSpecV2_2       , licenseRaw = Left SPDX.NONE       }     library = emptyLibrary { libBuildInfo = buildInfo }@@ -410,20 +373,21 @@       { targetBuildDepends = [baseDep]       , defaultLanguage = Just Haskell2010       }-    baseDep = Dependency "base" anyVersion (Set.singleton LMainLibName)+    baseDep = Dependency "base" anyVersion mainLibSet     pkgId = fakePackageId    writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription-  +   let ghciScriptPath = tempDir </> "setcwd.ghci"   cwd <- getCurrentDirectory   writeFile ghciScriptPath (":cd " ++ cwd) -  baseCtx <- +  distDirLayout <- establishDummyDistDirLayout verbosity config tempDir+  baseCtx <-     establishDummyProjectBaseContext       verbosity       config-      tempDir+      distDirLayout       [SpecificSourcePackage sourcePackage]       OtherCommand @@ -437,7 +401,7 @@                        -> PackageId                        -> ProjectBaseContext                        -> ProjectBaseContext-addDepsToProjectTarget deps pkgId ctx = +addDepsToProjectTarget deps pkgId ctx =     (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx   where     addDeps :: PackageSpecifier UnresolvedSourcePackage@@ -445,8 +409,8 @@     addDeps (SpecificSourcePackage pkg)       | packageId pkg /= pkgId = SpecificSourcePackage pkg       | SourcePackage{..} <- pkg =-        SpecificSourcePackage $ pkg { packageDescription = -          packageDescription & (\f -> L.allCondTrees $ traverseCondTreeC f)+        SpecificSourcePackage $ pkg { srcpkgDescription =+          srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f)                             %~ (deps ++)         }     addDeps spec = spec@@ -455,8 +419,8 @@ generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags   where     exeDeps :: [UnitId]-    exeDeps = -      foldMap +    exeDeps =+      foldMap         (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)         (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) @@ -485,7 +449,7 @@ -- multiple libs or exes. -- selectPackageTargets  :: TargetSelector-                      -> [AvailableTarget k] -> Either TargetProblem [k]+                      -> [AvailableTarget k] -> Either ReplTargetProblem [k] selectPackageTargets targetSelector targets      -- If there is exactly one buildable library then we select that@@ -494,7 +458,7 @@      -- but fail if there are multiple buildable libraries.   | not (null targetsLibsBuildable)-  = Left (TargetProblemMatchesMultiple targetSelector targetsLibsBuildable')+  = Left (matchesMultipleProblem targetSelector targetsLibsBuildable')      -- If there is exactly one buildable executable then we select that   | [target] <- targetsExesBuildable@@ -502,7 +466,7 @@      -- but fail if there are multiple buildable executables.   | not (null targetsExesBuildable)-  = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable')+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')      -- If there is exactly one other target then we select that   | [target] <- targetsBuildable@@ -510,7 +474,7 @@      -- but fail if there are multiple such targets   | not (null targetsBuildable)-  = Left (TargetProblemMatchesMultiple targetSelector targetsBuildable')+  = Left (matchesMultipleProblem targetSelector targetsBuildable')      -- If there are targets but none are buildable then we report those   | not (null targets)@@ -547,40 +511,43 @@ -- For the @repl@ command we just need the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget subtarget =-    either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic subtarget+                      -> AvailableTarget k -> Either ReplTargetProblem k+selectComponentTarget = selectComponentTargetBasic  +data ReplProblem+  = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]++    -- | Multiple 'TargetSelector's match multiple targets+  | TargetProblemMultipleTargets TargetsMap+  deriving (Eq, Show)+ -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. ---data TargetProblem =-     TargetProblemCommon       TargetProblemCommon--     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector+type ReplTargetProblem = TargetProblem ReplProblem -     -- | A single 'TargetSelector' matches multiple targets-   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]+matchesMultipleProblem+  :: TargetSelector+  -> [AvailableTarget ()]+  -> ReplTargetProblem+matchesMultipleProblem targetSelector targetsExesBuildable =+  CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable -     -- | Multiple 'TargetSelector's match multiple targets-   | TargetProblemMultipleTargets TargetsMap-  deriving (Eq, Show)+multipleTargetsProblem+  :: TargetsMap+  -> ReplTargetProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets -reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem+    die' verbosity . unlines . map renderReplTargetProblem -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "open a repl for" problem+renderReplTargetProblem :: TargetProblem ReplProblem -> String+renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem -renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =+renderReplProblem :: ReplProblem -> String+renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) =     "Cannot open a repl for multiple components at once. The target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ " which "@@ -588,7 +555,7 @@  ++ renderListSemiAnd       [ "the " ++ renderComponentKind Plural ckind ++ " " ++         renderListCommaAnd-          [ maybe (display pkgname) display (componentNameString cname)+          [ maybe (prettyShow pkgname) prettyShow (componentNameString cname)           | t <- ts           , let cname   = availableTargetComponentName t                 pkgname = packageName (availableTargetPackageId t)@@ -600,7 +567,7 @@     availableTargetComponentKind = componentKind                                  . availableTargetComponentName -renderTargetProblem (TargetProblemMultipleTargets selectorMap) =+renderReplProblem (TargetProblemMultipleTargets selectorMap) =     "Cannot open a repl for multiple components at once. The targets "  ++ renderListCommaAnd       [ "'" ++ showTargetSelector ts ++ "'"@@ -608,16 +575,8 @@  ++ " refer to different components."  ++ ".\n\n" ++ explanationSingleComponentLimitation -renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "open a repl for" targetSelector targets--renderTargetProblem (TargetProblemNoTargets targetSelector) =-    renderTargetProblemNoTargets "open a repl for" targetSelector-- explanationSingleComponentLimitation :: String explanationSingleComponentLimitation =     "The reason for this limitation is that current versions of ghci do not "  ++ "support loading multiple components as source. Load just one component "  ++ "and when you make changes to a dependent component then quit and reload."-
Distribution/Client/CmdRun.hs view
@@ -12,7 +12,8 @@     handleShebang, validScript,      -- * Internals exposed for testing-    TargetProblem(..),+    matchesMultipleProblem,+    noExesProblem,     selectPackageTargets,     selectComponentTarget   ) where@@ -22,35 +23,36 @@  import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages--import Distribution.Client.CmdRun.ClientRunFlags+         ( renderTargetSelector, showTargetSelector,+           renderTargetProblem,+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,+           targetSelectorFilter, renderListCommaAnd )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) ) +import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)-         , configureExOptions, haddockOptions, installOptions, testOptions-         , benchmarkOptions, configureOptions, liftOptions )-import Distribution.Solver.Types.ConstraintSource-         ( ConstraintSource(..) )+         ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Client.GlobalFlags          ( defaultGlobalFlags )-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )+import Distribution.Simple.Flag+         ( fromFlagOrDefault ) import Distribution.Simple.Command-         ( CommandUI(..), OptionField (..), usageAlternatives )+         ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName          ( showComponentName )-import Distribution.Deprecated.Text-         ( display )+import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Utils          ( wrapText, warn, die', ordNub, info          , createTempDirectory, handleDoesNotExist )-import Distribution.Client.CmdInstall-         ( establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig          ( ProjectConfig(..), ProjectConfigShared(..)-         , withProjectOrGlobalConfigIgn )+         , withProjectOrGlobalConfig )+import Distribution.Client.ProjectFlags+         ( flagIgnoreProject ) import Distribution.Client.ProjectPlanning          ( ElaboratedConfiguredPackage(..)          , ElaboratedInstallPlan, binDirectoryFor )@@ -68,8 +70,6 @@ import Distribution.Types.UnitId          ( UnitId ) -import Distribution.CabalSpecVersion-         ( cabalSpecLatest ) import Distribution.Client.Types          ( PackageLocation(..), PackageSpecifier(..) ) import Distribution.FieldGrammar@@ -95,8 +95,6 @@          ( GenericPackageDescription(..), emptyGenericPackageDescription ) import Distribution.Types.PackageDescription          ( PackageDescription(..), emptyPackageDescription )-import Distribution.Types.Version-         ( mkVersion ) import Distribution.Types.PackageName.Magic          ( fakePackageId ) import Language.Haskell.Extension@@ -112,10 +110,7 @@          ( (</>), isValid, isPathSeparator, takeExtension )  -runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                        , HaddockFlags, TestFlags, BenchmarkFlags-                        , ClientRunFlags-                        )+runCommand :: CommandUI (NixStyleFlags ()) runCommand = CommandUI   { commandName         = "v2-run"   , commandSynopsis     = "Run an executable."@@ -148,41 +143,12 @@       ++ "  " ++ pname ++ " v2-run pkgfoo:foo-tool\n"       ++ "    Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"       ++ "  " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"-      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n\n"+      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n" -      ++ cmdCommonHelpTextNewBuildBeta-  , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty, mempty)-  , commandOptions      = \showOrParseArgs ->-          liftOptions get1 set1-          -- Note: [Hidden Flags]-          -- hide "constraint", "dependency", and-          -- "exact-configuration" from the configure options.-          (filter ((`notElem` ["constraint", "dependency"-                              , "exact-configuration"])-                   . optionName) $-                                 configureOptions   showOrParseArgs)-      ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)-      ++ liftOptions get3 set3-          -- hide "target-package-db" flag from the-          -- install options.-          (filter ((`notElem` ["target-package-db"])-                   . optionName) $-                                 installOptions     showOrParseArgs)-      ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)-      ++ liftOptions get5 set5 (testOptions        showOrParseArgs)-      ++ liftOptions get6 set6 (benchmarkOptions   showOrParseArgs)-      ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs)+  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = nixStyleOptions (const [])   }-  where-    get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)-    get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)-    get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)-    get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)-    get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)-    get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)-    get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) - -- | The @run@ command runs a specified executable-like component, building it -- first if necessary. The component can be either an executable, a test, -- or a benchmark. This is particularly useful for passing arguments to@@ -191,27 +157,19 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-             , HaddockFlags, TestFlags, BenchmarkFlags-             , ClientRunFlags )-          -> [String] -> GlobalFlags -> IO ()-runAction ( configFlags, configExFlags, installFlags-          , haddockFlags, testFlags, benchmarkFlags-          , clientRunFlags )-            targetStrings globalFlags = do+runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+runAction flags@NixStyleFlags {..} targetStrings globalFlags = do     globalTmp <- getTemporaryDirectory-    tempDir <- createTempDirectory globalTmp "cabal-repl."+    tmpDir <- createTempDirectory globalTmp "cabal-repl."      let       with =         establishProjectBaseContext verbosity cliConfig OtherCommand-      without config =-        establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand--    let-      ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags)+      without config = do+        distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir+        establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand -    baseCtx <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without+    baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without      let       scriptOrError script err = do@@ -219,7 +177,7 @@         let pol | takeExtension script == ".lhs" = LiterateHaskell                 | otherwise                      = PlainHaskell         if exists-          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tempDir+          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir           else reportTargetSelectorProblems verbosity err      (baseCtx', targetSelectors) <-@@ -249,7 +207,6 @@                      $ resolveTargets                          selectPackageTargets                          selectComponentTarget-                         TargetProblemCommon                          elaboratedPlan                          Nothing                          targetSelectors@@ -264,7 +221,7 @@             _ <- singleExeOrElse                    (reportTargetProblems                       verbosity-                      [TargetProblemMultipleTargets targets])+                      [multipleTargetsProblem targets])                    targets              let elaboratedPlan' = pruneInstallPlanToTargets@@ -310,17 +267,17 @@       [] -> die' verbosity $ "Unknown executable "                           ++ exeName                           ++ " in package "-                          ++ display selectedUnitId+                          ++ prettyShow selectedUnitId       [elabPkg] -> do         info verbosity $ "Selecting "-                       ++ display selectedUnitId+                       ++ prettyShow selectedUnitId                        ++ " to supply " ++ exeName         return elabPkg       elabPkgs -> die' verbosity         $ "Multiple matching executables found matching "         ++ exeName         ++ ":\n"-        ++ unlines (fmap (\p -> " - in package " ++ display (elabUnitId p)) elabPkgs)+        ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)     let exePath = binDirectoryFor (distDirLayout baseCtx)                                   (elaboratedShared buildCtx)                                   pkg@@ -337,14 +294,11 @@                             elaboratedPlan       } -    handleDoesNotExist () (removeDirectoryRecursive tempDir)+    handleDoesNotExist () (removeDirectoryRecursive tmpDir)   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags-                  mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)  -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was@@ -441,7 +395,7 @@   -> FilePath   -> BS.ByteString   -> IO (ProjectBaseContext, [TargetSelector])-handleScriptCase verbosity pol baseCtx tempDir scriptContents = do+handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do   (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents    -- We need to create a dummy package that lives in our dummy project.@@ -451,10 +405,10 @@       LiterateHaskell -> "Main.lhs"      sourcePackage = SourcePackage-      { packageInfoId         = pkgId-      , SP.packageDescription = genericPackageDescription-      , packageSource         = LocalUnpackedPackage tempDir-      , packageDescrOverride  = Nothing+      { srcpkgPackageId      = pkgId+      , srcpkgDescription    = genericPackageDescription+      , srcpkgSource         = LocalUnpackedPackage tmpDir+      , srcpkgDescrOverride  = Nothing       }     genericPackageDescription  = emptyGenericPackageDescription       { GPD.packageDescription = packageDescription@@ -472,13 +426,13 @@     binfo@BuildInfo{..} = buildInfo executable     packageDescription = emptyPackageDescription       { package = pkgId-      , specVersionRaw = Left (mkVersion [2, 2])+      , specVersion = CabalSpecV2_2       , licenseRaw = Left SPDX.NONE       }     pkgId = fakePackageId -  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription-  BS.writeFile (tempDir </> mainName) contents'+  writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription+  BS.writeFile (tmpDir </> mainName) contents'    let     baseCtx' = baseCtx@@ -518,7 +472,7 @@ -- buildable. Fail if there are no or multiple buildable exe components. -- selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either TargetProblem [k]+                     -> [AvailableTarget k] -> Either RunTargetProblem [k] selectPackageTargets targetSelector targets      -- If there is exactly one buildable executable then we select that@@ -527,7 +481,7 @@      -- but fail if there are multiple buildable executables.   | not (null targetsExesBuildable)-  = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable')+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')      -- If there are executables but none are buildable then we report those   | not (null targetsExes)@@ -535,7 +489,7 @@      -- If there are no executables but some other targets then we report that   | not (null targets)-  = Left (TargetProblemNoExes targetSelector)+  = Left (noExesProblem targetSelector)      -- If there are no targets at all then we report that   | otherwise@@ -559,36 +513,28 @@ -- to the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem  k+                      -> AvailableTarget k -> Either RunTargetProblem  k selectComponentTarget subtarget@WholeComponent t   = case availableTargetComponentName t     of CExeName _ -> component        CTestName _ -> component        CBenchName _ -> component-       _ -> Left (TargetProblemComponentNotExe pkgid cname)+       _ -> Left (componentNotExeProblem pkgid cname)     where pkgid = availableTargetPackageId t           cname = availableTargetComponentName t-          component = either (Left . TargetProblemCommon) return $-                        selectComponentTargetBasic subtarget t+          component = selectComponentTargetBasic subtarget t  selectComponentTarget subtarget t-  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)-                                      (availableTargetComponentName t)-                                       subtarget)+  = Left (isSubComponentProblem (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. ---data TargetProblem =-     TargetProblemCommon       TargetProblemCommon-     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector-+data RunProblem =      -- | The 'TargetSelector' matches targets but no executables-   | TargetProblemNoExes      TargetSelector+     TargetProblemNoExes      TargetSelector       -- | A single 'TargetSelector' matches multiple targets    | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]@@ -603,25 +549,36 @@    | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget   deriving (Eq, Show) -reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderTargetProblem+type RunTargetProblem = TargetProblem RunProblem -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "run" problem+noExesProblem :: TargetSelector -> RunTargetProblem+noExesProblem = CustomTargetProblem . TargetProblemNoExes -renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "run" targetSelector targets+matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem+matchesMultipleProblem selector targets = CustomTargetProblem $+    TargetProblemMatchesMultiple selector targets -renderTargetProblem (TargetProblemNoExes targetSelector) =-    "Cannot run the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any executables."+multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets -renderTargetProblem (TargetProblemNoTargets targetSelector) =+componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem+componentNotExeProblem pkgid name = CustomTargetProblem $+    TargetProblemComponentNotExe pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem RunProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderRunTargetProblem++renderRunTargetProblem :: RunTargetProblem -> String+renderRunTargetProblem (TargetProblemNoTargets targetSelector) =     case targetSelectorFilter targetSelector of       Just kind | kind /= ExeKind         -> "The run command is for running executables, but the target '"@@ -629,8 +586,11 @@            ++ renderTargetSelector targetSelector ++ "."        _ -> renderTargetProblemNoTargets "run" targetSelector+renderRunTargetProblem problem =+    renderTargetProblem "run" renderRunProblem problem -renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =+renderRunProblem :: RunProblem -> String+renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =     "The run command is for running a single executable at once. The target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ " which includes "@@ -642,24 +602,31 @@                            [ExeKind, TestKind, BenchKind] )  ++ "." -renderTargetProblem (TargetProblemMultipleTargets selectorMap) =+renderRunProblem (TargetProblemMultipleTargets selectorMap) =     "The run command is for running a single executable at once. The targets "  ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"                        | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]  ++ " refer to different executables." -renderTargetProblem (TargetProblemComponentNotExe pkgid cname) =+renderRunProblem (TargetProblemComponentNotExe pkgid cname) =     "The run command is for running executables, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ " from the package "- ++ display pkgid ++ "."+ ++ prettyShow pkgid ++ "."   where     targetSelector = TargetComponent pkgid cname WholeComponent -renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) =     "The run command can only run an executable as a whole, "  ++ "not files or modules within them, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ "."   where     targetSelector = TargetComponent pkgid cname subtarget++renderRunProblem (TargetProblemNoExes targetSelector) =+    "Cannot run the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any executables."
− Distribution/Client/CmdRun/ClientRunFlags.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase    #-}-module Distribution.Client.CmdRun.ClientRunFlags-( ClientRunFlags(..)-, defaultClientRunFlags-, clientRunOptions-) where--import Distribution.Client.Compat.Prelude--import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)-import Distribution.Simple.Setup   (Flag (..), toFlag, trueArg)--data ClientRunFlags = ClientRunFlags-  { crunIgnoreProject   :: Flag Bool-  } deriving (Eq, Show, Generic)--instance Monoid ClientRunFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ClientRunFlags where-  (<>) = gmappend--instance Binary ClientRunFlags-instance Structured ClientRunFlags--defaultClientRunFlags :: ClientRunFlags-defaultClientRunFlags = ClientRunFlags-  { crunIgnoreProject   = toFlag False-  }--clientRunOptions :: ShowOrParseArgs -> [OptionField ClientRunFlags]-clientRunOptions _ =-  [ option "z" ["ignore-project"]-    "Ignore local project configuration"-    crunIgnoreProject (\v flags -> flags { crunIgnoreProject = v })-    trueArg-  ]
Distribution/Client/CmdSdist.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE ViewPatterns      #-} module Distribution.Client.CmdSdist     ( sdistCommand, sdistAction, packageToSdist-    , SdistFlags(..), defaultSdistFlags     , OutputFormat(..)) where  import Prelude ()@@ -15,12 +14,12 @@ import Distribution.Client.CmdErrorMessages     ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration-    ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext )+    ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), defaultNixStyleFlags ) import Distribution.Client.TargetSelector     ( TargetSelector(..), ComponentKind     , readTargetSelectors, reportTargetSelectorProblems )-import Distribution.Client.RebuildMonad-    ( runRebuild ) import Distribution.Client.Setup     ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage@@ -28,28 +27,32 @@ import Distribution.Client.Types     ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) import Distribution.Client.DistDirLayout-    ( DistDirLayout(..), defaultDistDirLayout )+    ( DistDirLayout(..), ProjectRoot (..) ) import Distribution.Client.ProjectConfig-    ( findProjectRoot, readProjectConfig )+    ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )+import Distribution.Client.ProjectFlags+     ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) +import Distribution.Compat.Lens+    ( _1, _2 ) import Distribution.Package     ( Package(packageId) ) import Distribution.PackageDescription.Configuration     ( flattenPackageDescription )-import Distribution.Pretty-    ( prettyShow ) import Distribution.ReadE     ( succeedReadE ) import Distribution.Simple.Command-    ( CommandUI(..), option, reqArg )+    ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) import Distribution.Simple.PreProcess     ( knownSuffixHandlers ) import Distribution.Simple.Setup     ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe-    , optionVerbosity, optionDistPref, trueArg+    , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref     ) import Distribution.Simple.SrcDist     ( listPackageSources )+import Distribution.Client.SrcDist+    ( packageDirToSdist ) import Distribution.Simple.Utils     ( die', notice, withOutputMarker, wrapText ) import Distribution.Types.ComponentName@@ -57,33 +60,21 @@ import Distribution.Types.PackageName     ( PackageName, unPackageName ) import Distribution.Verbosity-    ( Verbosity, normal )+    ( normal ) -import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Compression.GZip  as GZip-import Control.Exception-    ( throwIO )-import Control.Monad.Trans-    ( liftIO )-import Control.Monad.State.Lazy-    ( StateT, modify, gets, evalStateT )-import Control.Monad.Writer.Lazy-    ( WriterT, tell, execWriterT )-import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Either-    ( partitionEithers )-import Data.List-    ( sortOn )-import qualified Data.Set as Set import System.Directory-    ( getCurrentDirectory, setCurrentDirectory-    , createDirectoryIfMissing, makeAbsolute )+    ( getCurrentDirectory+    , createDirectoryIfMissing, makeAbsolute+    ) import System.FilePath-    ( (</>), (<.>), makeRelative, normalise, takeDirectory )+    ( (</>), (<.>), makeRelative, normalise ) -sdistCommand :: CommandUI SdistFlags+-------------------------------------------------------------------------------+-- Command+-------------------------------------------------------------------------------++sdistCommand :: CommandUI (ProjectFlags, SdistFlags) sdistCommand = CommandUI     { commandName = "v2-sdist"     , commandSynopsis = "Generate a source distribution file (.tar.gz)."@@ -92,36 +83,19 @@     , commandDescription  = Just $ \_ -> wrapText         "Generates tarballs of project packages suitable for upload to Hackage."     , commandNotes = Nothing-    , commandDefaultFlags = defaultSdistFlags+    , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)     , commandOptions = \showOrParseArgs ->-        [ optionVerbosity-            sdistVerbosity (\v flags -> flags { sdistVerbosity = v })-        , optionDistPref-            sdistDistDir (\dd flags -> flags { sdistDistDir = dd })-            showOrParseArgs-        , option [] ["project-file"]-            "Set the name of the cabal.project file to search for in parent directories"-            sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf })-            (reqArg "FILE" (succeedReadE Flag) flagToList)-        , option ['l'] ["list-only"]-            "Just list the sources, do not make a tarball"-            sdistListSources (\v flags -> flags { sdistListSources = v })-            trueArg-        , option ['z'] ["null-sep"]-            "Separate the source files with NUL bytes rather than newlines."-            sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })-            trueArg-        , option ['o'] ["output-dir", "outputdir"]-            "Choose the output directory of this command. '-' sends all output to stdout"-            sdistOutputPath (\o flags -> flags { sdistOutputPath = o })-            (reqArg "PATH" (succeedReadE Flag) flagToList)-        ]+        map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) +++        map (liftOptionL _2) (sdistOptions showOrParseArgs)     } +-------------------------------------------------------------------------------+-- Flags+-------------------------------------------------------------------------------+ data SdistFlags = SdistFlags     { sdistVerbosity     :: Flag Verbosity     , sdistDistDir       :: Flag FilePath-    , sdistProjectFile   :: Flag FilePath     , sdistListSources   :: Flag Bool     , sdistNulSeparated  :: Flag Bool     , sdistOutputPath    :: Flag FilePath@@ -131,40 +105,57 @@ defaultSdistFlags = SdistFlags     { sdistVerbosity     = toFlag normal     , sdistDistDir       = mempty-    , sdistProjectFile   = mempty     , sdistListSources   = toFlag False     , sdistNulSeparated  = toFlag False     , sdistOutputPath    = mempty     } ---+sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]+sdistOptions showOrParseArgs =+    [ optionVerbosity+        sdistVerbosity (\v flags -> flags { sdistVerbosity = v })+    , optionDistPref+        sdistDistDir (\dd flags -> flags { sdistDistDir = dd })+        showOrParseArgs+    , option ['l'] ["list-only"]+        "Just list the sources, do not make a tarball"+        sdistListSources (\v flags -> flags { sdistListSources = v })+        trueArg+    , option [] ["null-sep"]+        "Separate the source files with NUL bytes rather than newlines."+        sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })+        trueArg+    , option ['o'] ["output-directory", "outputdir"]+        "Choose the output directory of this command. '-' sends all output to stdout"+        sdistOutputPath (\o flags -> flags { sdistOutputPath = o })+        (reqArg "PATH" (succeedReadE Flag) flagToList)+    ] -sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO ()-sdistAction SdistFlags{..} targetStrings globalFlags = do-    let verbosity = fromFlagOrDefault normal sdistVerbosity-        mDistDirectory = flagToMaybe sdistDistDir-        mProjectFile = flagToMaybe sdistProjectFile-        globalConfig = globalConfigFile globalFlags-        listSources = fromFlagOrDefault False sdistListSources-        nulSeparated = fromFlagOrDefault False sdistNulSeparated-        mOutputPath = flagToMaybe sdistOutputPath+-------------------------------------------------------------------------------+-- Action+------------------------------------------------------------------------------- -    projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile-    let distLayout = defaultDistDirLayout projectRoot mDistDirectory-    dir <- getCurrentDirectory-    projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout-    baseCtx <- establishProjectBaseContext verbosity projectConfig OtherCommand+sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()+sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do+    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject+     let localPkgs = localPackages baseCtx      targetSelectors <- either (reportTargetSelectorProblems verbosity) return         =<< readTargetSelectors localPkgs Nothing targetStrings +    -- elaborate path, create target directory     mOutputPath' <- case mOutputPath of         Just "-"  -> return (Just "-")-        Just path -> Just <$> makeAbsolute path-        Nothing   -> return Nothing+        Just path -> do+            abspath <- makeAbsolute path+            createDirectoryIfMissing True abspath+            return (Just abspath)+        Nothing   -> do+            createDirectoryIfMissing True (distSdistDirectory distDirLayout)+            return Nothing -    let+    let format :: OutputFormat         format =             if | listSources, nulSeparated -> SourceList '\0'                | listSources               -> SourceList '\n'@@ -180,9 +171,8 @@                 | otherwise   -> path </> prettyShow (packageId pkg) <.> ext             Nothing                 | listSources -> "-"-                | otherwise   -> distSdistFile distLayout (packageId pkg)+                | otherwise   -> distSdistFile distDirLayout (packageId pkg) -    createDirectoryIfMissing True (distSdistDirectory distLayout)      case reifyTargetSelectors localPkgs targetSelectors of         Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs@@ -190,11 +180,38 @@             | length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->                 die' verbosity "Can't write multiple tarballs to standard output!"             | otherwise ->-                traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs+                traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs+  where+    verbosity      = fromFlagOrDefault normal sdistVerbosity+    listSources    = fromFlagOrDefault False sdistListSources+    nulSeparated   = fromFlagOrDefault False sdistNulSeparated+    mOutputPath    = flagToMaybe sdistOutputPath+    ignoreProject  = flagIgnoreProject -data IsExec = Exec | NoExec-            deriving (Show, Eq)+    prjConfig :: ProjectConfig+    prjConfig = commandLineFlagsToProjectConfig+        globalFlags+        (defaultNixStyleFlags ())+          { configFlags = (configFlags $ defaultNixStyleFlags ())+            { configVerbosity = sdistVerbosity+            , configDistPref = sdistDistDir+            }+          }+        mempty +    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)++    withProject :: IO (ProjectBaseContext, DistDirLayout)+    withProject = do+        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)+    withoutProject config = do+        cwd <- getCurrentDirectory+        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand+        return (baseCtx, distDirLayout baseCtx)+ data OutputFormat = SourceList Char                   | TarGzArchive                   deriving (Show, Eq)@@ -202,9 +219,9 @@ packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () packageToSdist verbosity projectRootDir format outputFile pkg = do     let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))-    dir0 <- case packageSource pkg of+    dir0 <- case srcpkgSource pkg of              LocalUnpackedPackage path             -> pure (Right path)-             RemoteSourceRepoPackage _ (Just path) -> pure (Right path)+             RemoteSourceRepoPackage _ (Just tgz)  -> pure (Left tgz)              RemoteSourceRepoPackage {}            -> death              LocalTarballPackage tgz               -> pure (Left tgz)              RemoteTarballPackage _ (Just tgz)     -> pure (Left tgz)@@ -212,83 +229,34 @@              RepoTarballPackage {}                 -> death      let -- Write String to stdout or file, using the default TextEncoding.-        write-          | outputFile == "-" = putStr . withOutputMarker verbosity-          | otherwise = writeFile outputFile+        write str+          | outputFile == "-" = putStr (withOutputMarker verbosity str)+          | otherwise = do+            writeFile outputFile str+            notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"         -- Write raw ByteString to stdout or file as it is, without encoding.-        writeLBS-          | outputFile == "-" = BSL.putStr-          | otherwise = BSL.writeFile outputFile+        writeLBS lbs+          | outputFile == "-" = BSL.putStr lbs+          | otherwise = do+            BSL.writeFile outputFile lbs+            notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"      case dir0 of       Left tgz -> do         case format of           TarGzArchive -> do             writeLBS =<< BSL.readFile tgz-            when (outputFile /= "-") $-              notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"           _ -> die' verbosity ("cannot convert tarball package to " ++ show format) -      Right dir -> do-        oldPwd <- getCurrentDirectory-        setCurrentDirectory dir--        let norm flag = fmap ((flag, ) . normalise)-        (norm NoExec -> nonexec, norm Exec -> exec) <--           listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers--        let files =  nub . sortOn snd $ nonexec ++ exec--        case format of-            SourceList nulSep -> do-                let prefix = makeRelative projectRootDir dir-                write $ concat [prefix </> i ++ [nulSep] | (_, i) <- files]-                when (outputFile /= "-") $-                    notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"-            TarGzArchive -> do-                let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()-                    entriesM = do-                        let prefix = prettyShow (packageId pkg)-                        modify (Set.insert prefix)-                        case Tar.toTarPath True prefix of-                            Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                            Right path -> tell [Tar.directoryEntry path]--                        for_ files $ \(perm, file) -> do-                            let fileDir = takeDirectory (prefix </> file)-                                perm' = case perm of-                                    Exec -> Tar.executableFilePermissions-                                    NoExec -> Tar.ordinaryFilePermissions-                            needsEntry <- gets (Set.notMember fileDir)--                            when needsEntry $ do-                                modify (Set.insert fileDir)-                                case Tar.toTarPath True fileDir of-                                    Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                                    Right path -> tell [Tar.directoryEntry path]--                            contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ file-                            case Tar.toTarPath False (prefix </> file) of-                                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                                Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }]--                entries <- execWriterT (evalStateT entriesM mempty)-                let -- Pretend our GZip file is made on Unix.-                    normalize bs = BSL.concat [pfx, "\x03", rest']-                        where-                            (pfx, rest) = BSL.splitAt 9 bs-                            rest' = BSL.tail rest-                    -- The Unix epoch, which is the default value, is-                    -- unsuitable because it causes unpacking problems on-                    -- Windows; we need a post-1980 date. One gigasecond-                    -- after the epoch is during 2001-09-09, so that does-                    -- nicely. See #5596.-                    setModTime entry = entry { Tar.entryTime = 1000000000 }-                writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries-                when (outputFile /= "-") $-                    notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"+      Right dir -> case format of+        SourceList nulSep -> do+          files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers+          let files = nub $ sort $ map normalise files'+          let prefix = makeRelative projectRootDir dir+          write $ concat [prefix </> i ++ [nulSep] | i <- files] -        setCurrentDirectory oldPwd+        TarGzArchive -> do+          packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS  --
Distribution/Client/CmdTest.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}  -- | cabal-install CLI command: test --@@ -8,38 +8,43 @@     testAction,      -- * Internals exposed for testing-    TargetProblem(..),+    isSubComponentProblem,+    notTestProblem,+    noTestsProblem,     selectPackageTargets,     selectComponentTarget   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages-+         ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural,+           renderTargetProblem,+           renderTargetProblemNoTargets, targetSelectorPluralPkgs )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags )-import qualified Distribution.Client.Setup as Client+         ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags(..), BenchmarkFlags(..), fromFlagOrDefault )+         ( TestFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Flag          ( Flag(..) )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Utils          ( notice, wrapText, die' ) -import Control.Monad (when) import qualified System.Exit (exitSuccess)  -testCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                         , HaddockFlags, TestFlags, BenchmarkFlags-                         )-testCommand = Client.installCommand+testCommand :: CommandUI (NixStyleFlags ())+testCommand = CommandUI   { commandName         = "v2-test"   , commandSynopsis     = "Run test-suites"   , commandUsage        = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]@@ -68,10 +73,10 @@      ++ "  " ++ pname ++ " v2-test cname\n"      ++ "    Run the test-suite named cname\n"      ++ "  " ++ pname ++ " v2-test cname --enable-coverage\n"-     ++ "    Run the test-suite built with code coverage (including local libs used)\n\n"--     ++ cmdCommonHelpTextNewBuildBeta+     ++ "    Run the test-suite built with code coverage (including local libs used)\n" +  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = nixStyleOptions (const [])   }  @@ -86,12 +91,8 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---testAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-              , HaddockFlags, TestFlags, BenchmarkFlags )-           -> [String] -> GlobalFlags -> IO ()-testAction ( configFlags, configExFlags, installFlags-           , haddockFlags, testFlags, benchmarkFlags )-           targetStrings globalFlags = do+testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+testAction flags@NixStyleFlags {..} targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -113,7 +114,6 @@                      $ resolveTargets                          selectPackageTargets                          selectComponentTarget-                         TargetProblemCommon                          elaboratedPlan                          Nothing                          targetSelectors@@ -131,11 +131,7 @@   where     failWhenNoTestSuites = testFailWhenNoTestSuites testFlags     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags-                  mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags  -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,@@ -145,7 +141,7 @@ -- or fail if there are no test-suites or no buildable test-suites. -- selectPackageTargets  :: TargetSelector-                      -> [AvailableTarget k] -> Either TargetProblem [k]+                      -> [AvailableTarget k] -> Either TestTargetProblem [k] selectPackageTargets targetSelector targets      -- If there are any buildable test-suite targets then we select those@@ -158,7 +154,7 @@      -- If there are no test-suite but some other targets then we report that   | not (null targets)-  = Left (TargetProblemNoTests targetSelector)+  = Left (noTestsProblem targetSelector)      -- If there are no targets at all then we report that   | otherwise@@ -180,34 +176,28 @@ -- to the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem k+                      -> AvailableTarget k -> Either TestTargetProblem k selectComponentTarget subtarget@WholeComponent t   | CTestName _ <- availableTargetComponentName t-  = either (Left . TargetProblemCommon) return $+  = either Left return $            selectComponentTargetBasic subtarget t   | otherwise-  = Left (TargetProblemComponentNotTest (availableTargetPackageId t)-                                        (availableTargetComponentName t))+  = Left (notTestProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t))  selectComponentTarget subtarget t-  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)-                                      (availableTargetComponentName t)-                                       subtarget)+  = Left (isSubComponentProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command. ---data TargetProblem =-     TargetProblemCommon       TargetProblemCommon--     -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]--     -- | There are no targets at all-   | TargetProblemNoTargets   TargetSelector-+data TestProblem =      -- | The 'TargetSelector' matches targets but no test-suites-   | TargetProblemNoTests     TargetSelector+     TargetProblemNoTests     TargetSelector       -- | The 'TargetSelector' refers to a component that is not a test-suite    | TargetProblemComponentNotTest PackageId ComponentName@@ -216,17 +206,35 @@    | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget   deriving (Eq, Show) -reportTargetProblems :: Verbosity -> Flag Bool -> [TargetProblem] -> IO a++type TestTargetProblem = TargetProblem TestProblem+++noTestsProblem :: TargetSelector -> TargetProblem TestProblem+noTestsProblem = CustomTargetProblem . TargetProblemNoTests++notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem+notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem TestProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+  TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a reportTargetProblems verbosity failWhenNoTestSuites problems =   case (failWhenNoTestSuites, problems) of-    (Flag True, [TargetProblemNoTests _]) ->+    (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->       die' verbosity problemsMessage-    (_, [TargetProblemNoTests selector]) -> do+    (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do       notice verbosity (renderAllowedNoTestsProblem selector)       System.Exit.exitSuccess     (_, _) -> die' verbosity problemsMessage     where-      problemsMessage = unlines . map renderTargetProblem $ problems+      problemsMessage = unlines . map renderTestTargetProblem $ problems  -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't --   @die@ when the target problem is 'TargetProblemNoTests'.@@ -236,21 +244,8 @@ renderAllowedNoTestsProblem selector =     "No tests to run for " ++ renderTargetSelector selector -renderTargetProblem :: TargetProblem -> String-renderTargetProblem (TargetProblemCommon problem) =-    renderTargetProblemCommon "run" problem--renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled "test" targetSelector targets--renderTargetProblem (TargetProblemNoTests targetSelector) =-    "Cannot run tests for the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any test suites."--renderTargetProblem (TargetProblemNoTargets targetSelector) =+renderTestTargetProblem :: TestTargetProblem -> String+renderTestTargetProblem (TargetProblemNoTargets targetSelector) =     case targetSelectorFilter targetSelector of       Just kind | kind /= TestKind         -> "The test command is for running test suites, but the target '"@@ -259,16 +254,27 @@            ++ "\n" ++ show targetSelector        _ -> renderTargetProblemNoTargets "test" targetSelector+renderTestTargetProblem problem =+    renderTargetProblem "test" renderTestProblem problem -renderTargetProblem (TargetProblemComponentNotTest pkgid cname) =++renderTestProblem :: TestProblem -> String+renderTestProblem (TargetProblemNoTests targetSelector) =+    "Cannot run tests for the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any test suites."++renderTestProblem (TargetProblemComponentNotTest pkgid cname) =     "The test command is for running test suites, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "  ++ renderTargetSelector targetSelector ++ " from the package "- ++ display pkgid ++ "."+ ++ prettyShow pkgid ++ "."   where     targetSelector = TargetComponent pkgid cname WholeComponent -renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =     "The test command can only run test suites as a whole, "  ++ "not files or modules within them, but the target '"  ++ showTargetSelector targetSelector ++ "' refers to "
Distribution/Client/CmdUpdate.hs view
@@ -15,6 +15,8 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Compat.Directory          ( setModificationTime ) import Distribution.Client.ProjectOrchestration@@ -23,8 +25,10 @@          , ProjectConfigShared(projectConfigConfigFile)          , projectConfigWithSolverRepoContext          , withProjectOrGlobalConfig )+import Distribution.Client.ProjectFlags+         ( ProjectFlags (..) ) import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), isRepoRemote )+         ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName ) import Distribution.Client.HttpUtils          ( DownloadResult(..) ) import Distribution.Client.FetchUtils@@ -32,48 +36,43 @@ import Distribution.Client.JobControl          ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         ( GlobalFlags, ConfigFlags(..)          , UpdateFlags, defaultUpdateFlags          , RepoContext(..) )-import Distribution.Simple.Setup-         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )+import Distribution.Simple.Flag+         ( fromFlagOrDefault ) import Distribution.Simple.Utils          ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity-         ( Verbosity, normal, lessVerbose )+         ( normal, lessVerbose ) import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils          ( updateRepoIndexCache, Index(..), writeIndexTimestamp-         , currentIndexTimestamp, indexBaseName )-import Distribution.Deprecated.Text-         ( Text(..), display, simpleParse )+         , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile ) -import Data.Maybe (fromJust)-import qualified Distribution.Deprecated.ReadP  as ReadP-import qualified Text.PrettyPrint           as Disp+import qualified Data.Maybe as Unsafe (fromJust)+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp -import Control.Monad (mapM, mapM_) import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((<.>), dropExtension) import Data.Time (getCurrentTime) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives )-import qualified Distribution.Client.Setup as Client  import qualified Hackage.Security.Client as Sec -updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags-                           , InstallFlags, HaddockFlags-                           , TestFlags, BenchmarkFlags-                           )-updateCommand = Client.installCommand {-  commandName         = "v2-update",-  commandSynopsis     = "Updates list of known packages.",-  commandUsage        = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "For all known remote repositories, download the package list.",-  commandNotes        = Just $ \pname ->+updateCommand :: CommandUI (NixStyleFlags ())+updateCommand = CommandUI+  { commandName         = "v2-update"+  , commandSynopsis     = "Updates list of known packages."+  , commandUsage        = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]+  , commandDescription  = Just $ \_ -> wrapText $+          "For all known remote repositories, download the package list."++  , commandNotes        = Just $ \pname ->         "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"      ++ "the same format and syntax that is supported by the --index-state flag.\n\n"      ++ "Examples:\n"@@ -87,107 +86,99 @@      ++ "  " ++ pname ++ " new update hackage.haskell.org head.hackage\n"      ++ "    Download hackage.haskell.org and head.hackage\n"      ++ "    head.hackage must be a known repo-id. E.g. from\n"-     ++ "    your cabal.project(.local) file.\n\n"-     ++ "Note: this command is part of the new project-based system (aka "-     ++ "nix-style\nlocal builds). These features are currently in beta. "-     ++ "Please see\n"-     ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "-     ++ "for\ndetails and advice on what you can expect to work. If you "-     ++ "encounter problems\nplease file issues at "-     ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "-     ++ "to get involved and help with testing, fixing bugs etc then\nthat "-     ++ "is very much appreciated.\n"+     ++ "    your cabal.project(.local) file.\n"++  , commandOptions      = nixStyleOptions $ const []+  , commandDefaultFlags = defaultNixStyleFlags ()   }  data UpdateRequest = UpdateRequest-  { _updateRequestRepoName :: String-  , _updateRequestRepoState :: IndexState+  { _updateRequestRepoName  :: RepoName+  , _updateRequestRepoState :: RepoIndexState   } deriving (Show) -instance Text UpdateRequest where-  disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s-  parse = parseWithState ReadP.+++ parseHEAD-    where parseWithState = do-            name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ','))-            _ <- ReadP.char ','-            state <- parse-            return (UpdateRequest name state)-          parseHEAD = do-            name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof-            return (UpdateRequest name IndexStateHead)+instance Pretty UpdateRequest where+    pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s -updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-                , HaddockFlags, TestFlags, BenchmarkFlags )-             -> [String] -> GlobalFlags -> IO ()-updateAction ( configFlags, configExFlags, installFlags-             , haddockFlags, testFlags, benchmarkFlags )-             extraArgs globalFlags = do-  projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag+instance Parsec UpdateRequest where+  parsec = do+      name <- parsec+      state <- P.char ',' *> parsec <|> pure IndexStateHead+      return (UpdateRequest name state)++updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do+  let ignoreProject = flagIgnoreProject projectFlags++  projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag     (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)     (\globalConfig -> return $ globalConfig <> cliConfig)    projectConfigWithSolverRepoContext verbosity     (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)     $ \repoCtxt -> do-    let repos       = filter isRepoRemote $ repoContextRepos repoCtxt-        repoName    = remoteRepoName . repoRemote++    let repos :: [Repo]+        repos = repoContextRepos repoCtxt+         parseArg :: String -> IO UpdateRequest-        parseArg s = case simpleParse s of+        parseArg s = case simpleParsec s of           Just r -> return r           Nothing -> die' verbosity $                      "'v2-update' unable to parse repo: \"" ++ s ++ "\""-    updateRepoRequests <- mapM parseArg extraArgs +    updateRepoRequests <- traverse parseArg extraArgs+     unless (null updateRepoRequests) $ do       let remoteRepoNames = map repoName repos           unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests                             , not (r `elem` remoteRepoNames)]       unless (null unknownRepos) $         die' verbosity $ "'v2-update' repo(s): \""-                         ++ intercalate "\", \"" unknownRepos+                         ++ intercalate "\", \"" (map unRepoName unknownRepos)                          ++ "\" can not be found in known remote repo(s): "-                         ++ intercalate ", " remoteRepoNames+                         ++ intercalate ", " (map unRepoName remoteRepoNames) -    let reposToUpdate :: [(Repo, IndexState)]+    let reposToUpdate :: [(Repo, RepoIndexState)]         reposToUpdate = case updateRepoRequests of           -- If we are not given any specific repository, update all           -- repositories to HEAD.           [] -> map (,IndexStateHead) repos           updateRequests -> let repoMap = [(repoName r, r) | r <- repos]-                                lookup' k = fromJust (lookup k repoMap)+                                lookup' k = Unsafe.fromJust (lookup k repoMap)                             in [ (lookup' name, state)                                | (UpdateRequest name state) <- updateRequests ]      case reposToUpdate of-      [] -> return ()+      [] ->+        notice verbosity "No remote repositories configured"       [(remoteRepo, _)] ->         notice verbosity $ "Downloading the latest package list from "-                        ++ repoName remoteRepo+                        ++ unRepoName (repoName remoteRepo)       _ -> notice verbosity . unlines               $ "Downloading the latest package lists from: "-              : map (("- " ++) . repoName . fst) reposToUpdate+              : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate -    jobCtrl <- newParallelJobControl (length reposToUpdate)-    mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)-      reposToUpdate-    mapM_ (\_ -> collectJob jobCtrl) reposToUpdate+    unless (null reposToUpdate) $ do+      jobCtrl <- newParallelJobControl (length reposToUpdate)+      traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)+        reposToUpdate+      traverse_ (\_ -> collectJob jobCtrl) reposToUpdate    where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags configFlags configExFlags-                  installFlags-                  mempty -- ClientInstallFlags, not needed here-                  haddockFlags testFlags benchmarkFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState)+updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)            -> IO () updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do   transport <- repoContextGetTransport repoCtxt   case repo of-    RepoLocal{} -> return ()-    RepoLocalNoIndex{} -> return ()+    RepoLocalNoIndex{} -> do+      let index = RepoIndex repoCtxt repo+      updatePackageIndexCacheFile verbosity index+     RepoRemote{..} -> do       downloadResult <- downloadIndex transport verbosity                         repoRemote repoLocalDir@@ -210,19 +201,30 @@               then Just `fmap` getCurrentTime               else return Nothing       updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce++      let rname = remoteRepoName (repoRemote repo)+       -- Update cabal's internal index as well so that it's not out of sync       -- (If all access to the cache goes through hackage-security this can go)       case updated of-        Sec.NoUpdates  ->-          setModificationTime (indexBaseName repo <.> "tar")-          =<< getCurrentTime-        Sec.HasUpdates ->+        Sec.NoUpdates  -> do+          now <- getCurrentTime+          setModificationTime (indexBaseName repo <.> "tar") now+          noticeNoWrap verbosity $+            "Package list of " ++ prettyShow rname +++            " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts)++        Sec.HasUpdates -> do           updateRepoIndexCache verbosity index-      -- TODO: This will print multiple times if there are multiple-      -- repositories: main problem is we don't have a way of updating-      -- a specific repo.  Once we implement that, update this.-      when (current_ts /= nullTimestamp) $-        noticeNoWrap verbosity $-          "To revert to previous state run:\n" ++-          "    cabal v2-update '" ++ remoteRepoName (repoRemote repo)-          ++ "," ++ display current_ts ++ "'\n"+          new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+          noticeNoWrap verbosity $+            "Updated package list of " ++ prettyShow rname +++            " to the index-state " ++ prettyShow (IndexStateTime new_ts)++          -- TODO: This will print multiple times if there are multiple+          -- repositories: main problem is we don't have a way of updating+          -- a specific repo.  Once we implement that, update this.+          when (current_ts /= nullTimestamp) $+            noticeNoWrap verbosity $+              "To revert to previous state run:\n" +++              "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
Distribution/Client/Compat/Directory.hs view
@@ -1,13 +1,58 @@ {-# LANGUAGE CPP #-}-module Distribution.Client.Compat.Directory (setModificationTime) where+module Distribution.Client.Compat.Directory (+    setModificationTime,+    createFileLink,+    pathIsSymbolicLink,+    getSymbolicLinkTarget,+    ) where  #if MIN_VERSION_directory(1,2,3) import System.Directory (setModificationTime) #else- import Data.Time.Clock (UTCTime)+#endif +#if MIN_VERSION_directory(1,3,1)+import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)+#elif defined(MIN_VERSION_unix)+import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink)+#endif++-------------------------------------------------------------------------------+-- setModificationTime+-------------------------------------------------------------------------------++#if !MIN_VERSION_directory(1,2,3)+ setModificationTime :: FilePath -> UTCTime -> IO () setModificationTime _fp _t = return () +#endif++-------------------------------------------------------------------------------+-- Symlink+-------------------------------------------------------------------------------++#if MIN_VERSION_directory(1,3,1)+#elif defined(MIN_VERSION_unix)+createFileLink :: FilePath -> FilePath -> IO ()+createFileLink = createSymbolicLink++pathIsSymbolicLink :: FilePath -> IO Bool+pathIsSymbolicLink fp = do+    status <- getSymbolicLinkStatus fp+    return (isSymbolicLink status)++getSymbolicLinkTarget :: FilePath -> IO FilePath+getSymbolicLinkTarget = readSymbolicLink++#else+createFileLink :: FilePath -> FilePath -> IO ()+createFileLink _ _ = fail "Symlinking feature not available"++pathIsSymbolicLink :: FilePath -> IO Bool+pathIsSymbolicLink _ = fail "Symlinking feature not available"++getSymbolicLinkTarget :: FilePath -> IO FilePath+getSymbolicLinkTarget _ = fail "Symlinking feature not available" #endif
Distribution/Client/Compat/ExecutablePath.hs view
@@ -7,6 +7,8 @@  module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where +import Prelude+ -- The imports are purposely kept completely disjoint to prevent edits -- to one OS implementation from breaking another.
Distribution/Client/Compat/FilePerms.hs view
@@ -6,6 +6,8 @@   setFileHidden,   ) where +import Prelude (FilePath, IO, return, ($))+ #ifndef mingw32_HOST_OS import System.Posix.Types          ( FileMode )
Distribution/Client/Compat/Orphans.hs view
@@ -7,6 +7,7 @@ import Distribution.Compat.Typeable  (typeRep) import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) import Network.URI                   (URI (..), URIAuth (..))+import Prelude                       (error, return)  ------------------------------------------------------------------------------- -- network-uri@@ -34,7 +35,7 @@ --Added in 46aa019ec85e313e257d122a3549cce01996c566 instance Binary SomeException where     put _ = return ()-    get = fail "cannot serialise exceptions"+    get = error "cannot serialise exceptions"  instance Structured SomeException where     structure p = Nominal (typeRep p) 0 "SomeException" []
Distribution/Client/Compat/Prelude.hs view
@@ -12,9 +12,13 @@ -- module Distribution.Client.Compat.Prelude   ( module Distribution.Compat.Prelude.Internal-  , Prelude.IO+  , module X   ) where -import Prelude (IO)-import Distribution.Compat.Prelude.Internal hiding (IO) import Distribution.Client.Compat.Orphans ()+import Distribution.Compat.Prelude.Internal+import Prelude ()++import Distribution.Parsec    as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec)+import Distribution.Pretty    as X (Pretty (..), prettyShow)+import Distribution.Verbosity as X (Verbosity)
Distribution/Client/Compat/Process.hs view
@@ -16,6 +16,8 @@   readProcessWithExitCode ) where +import Prelude (FilePath, IO, String, return, (||))+ import           Control.Exception (catch, throw) import           System.Exit       (ExitCode (ExitFailure)) import           System.IO.Error   (isDoesNotExistError, isPermissionError)@@ -35,6 +37,9 @@ --   exception.  This variant catches \"does not exist\" and --   \"permission denied\" exceptions and turns them into --   @ExitFailure@s.+--+-- TODO: this doesn't use 'Distrubution.Compat.Process'.+-- readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) readProcessWithExitCode cmd args input =   P.readProcessWithExitCode cmd args input
Distribution/Client/Compat/Semaphore.hs view
@@ -7,6 +7,8 @@     , signalQSem     ) where +import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip)+ import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,                                writeTVar) import Control.Exception (mask_, onException)
Distribution/Client/Config.hs view
@@ -26,6 +26,7 @@     defaultConfigFile,     defaultCacheDir,     defaultCompiler,+    defaultInstallPath,     defaultLogsDir,     defaultUserInstall, @@ -45,35 +46,38 @@     postProcessRepo,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Language.Haskell.Extension ( Language(Haskell2010) )  import Distribution.Deprecated.ViewAsFieldDescr          ( viewAsFieldDescr )  import Distribution.Client.Types-         ( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo+         ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo          , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps+         , RepoName (..), unRepoName          )+import Distribution.Client.Types.Credentials (Username (..), Password (..)) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..) )+import qualified Distribution.Client.Init.Defaults as IT import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand, defaultGlobalFlags          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags          , initOptions          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand-         , ReportFlags(..), reportCommand-         , showRemoteRepo, parseRemoteRepo, readRemoteRepo )+         , ReportFlags(..), reportCommand ) import Distribution.Client.CmdInstall.ClientInstallFlags          ( ClientInstallFlags(..), defaultClientInstallFlags          , clientInstallOptions ) import Distribution.Utils.NubList          ( NubList, fromNubList, toNubList, overNubList ) -import Distribution.License-         ( License(BSD3) ) import Distribution.Simple.Compiler          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup@@ -93,41 +97,36 @@          , locatedErrorMsg, showPWarning          , readFields, warning, lineNo          , simpleField, listField, spaceListField-         , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError)+         , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError+         , simpleFieldParsec, listFieldParsec+         ) import Distribution.Client.ParseUtils          ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils          ( isOldHackageURI ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils          ( Field(..) )-import qualified Distribution.Deprecated.Text as Text-         ( Text(..), display ) import Distribution.Simple.Command          ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) import Distribution.Simple.Program          ( defaultProgramDb ) import Distribution.Simple.Utils          ( die', notice, warn, lowercase, cabalVersion )+import Distribution.Client.Utils+         ( cabalInstallVersion ) import Distribution.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity-         ( Verbosity, normal )-import Distribution.Version-         ( mkVersion )-+         ( normal )+import qualified Distribution.Compat.CharParsing as P+import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Solver.Types.ConstraintSource -import Data.List-         ( partition, find, foldl', nubBy )-import Data.Maybe-         ( fromMaybe )-import Control.Monad-         ( when, unless, foldM, liftM ) import qualified Distribution.Deprecated.ReadP as Parse          ( (<++), option )-import Distribution.Compat.Semigroup import qualified Text.PrettyPrint as Disp          ( render, text, empty )+import Distribution.Parsec (parsecOptCommaList) import Text.PrettyPrint          ( ($+$) ) import Text.PrettyPrint.HughesPJ@@ -142,38 +141,28 @@          ( isDoesNotExistError ) import Distribution.Compat.Environment          ( getEnvironment, lookupEnv )-import Distribution.Compat.Exception-         ( catchIO )-import qualified Paths_cabal_install-         ( version )-import Data.Version-         ( showVersion )-import Data.Char-         ( isSpace ) import qualified Data.Map as M-import Data.Function-         ( on )-import GHC.Generics ( Generic )  -- -- * Configuration saved in the config file -- -data SavedConfig = SavedConfig {-    savedGlobalFlags       :: GlobalFlags,-    savedInitFlags         :: IT.InitFlags,-    savedInstallFlags      :: InstallFlags,-    savedClientInstallFlags :: ClientInstallFlags,-    savedConfigureFlags    :: ConfigFlags,-    savedConfigureExFlags  :: ConfigExFlags,-    savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),-    savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),-    savedUploadFlags       :: UploadFlags,-    savedReportFlags       :: ReportFlags,-    savedHaddockFlags      :: HaddockFlags,-    savedTestFlags         :: TestFlags,-    savedBenchmarkFlags    :: BenchmarkFlags-  } deriving Generic+data SavedConfig = SavedConfig+    { savedGlobalFlags        :: GlobalFlags+    , savedInitFlags          :: IT.InitFlags+    , savedInstallFlags       :: InstallFlags+    , savedClientInstallFlags :: ClientInstallFlags+    , savedConfigureFlags     :: ConfigFlags+    , savedConfigureExFlags   :: ConfigExFlags+    , savedUserInstallDirs    :: InstallDirs (Flag PathTemplate)+    , savedGlobalInstallDirs  :: InstallDirs (Flag PathTemplate)+    , savedUploadFlags        :: UploadFlags+    , savedReportFlags        :: ReportFlags+    , savedHaddockFlags       :: HaddockFlags+    , savedTestFlags          :: TestFlags+    , savedBenchmarkFlags     :: BenchmarkFlags+    , savedProjectFlags       :: ProjectFlags+    } deriving Generic  instance Monoid SavedConfig where   mempty = gmempty@@ -193,7 +182,8 @@     savedReportFlags       = combinedSavedReportFlags,     savedHaddockFlags      = combinedSavedHaddockFlags,     savedTestFlags         = combinedSavedTestFlags,-    savedBenchmarkFlags    = combinedSavedBenchmarkFlags+    savedBenchmarkFlags    = combinedSavedBenchmarkFlags,+    savedProjectFlags      = combinedSavedProjectFlags   }     where       -- This is ugly, but necessary. If we're mappending two config files, we@@ -248,16 +238,13 @@         globalVersion           = combine globalVersion,         globalNumericVersion    = combine globalNumericVersion,         globalConfigFile        = combine globalConfigFile,-        globalSandboxConfigFile = combine globalSandboxConfigFile,         globalConstraintsFile   = combine globalConstraintsFile,         globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,         globalCacheDir          = combine globalCacheDir,-        globalLocalRepos        = lastNonEmptyNL globalLocalRepos,         globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,+        globalActiveRepos       = combine globalActiveRepos,         globalLogsDir           = combine globalLogsDir,         globalWorldFile         = combine globalWorldFile,-        globalRequireSandbox    = combine globalRequireSandbox,-        globalIgnoreSandbox     = combine globalIgnoreSandbox,         globalIgnoreExpiry      = combine globalIgnoreExpiry,         globalHttpTransport     = combine globalHttpTransport,         globalNix               = combine globalNix,@@ -337,8 +324,7 @@         installNumJobs               = combine installNumJobs,         installKeepGoing             = combine installKeepGoing,         installRunTests              = combine installRunTests,-        installOfflineMode           = combine installOfflineMode,-        installProjectFileName       = combine installProjectFileName+        installOfflineMode           = combine installOfflineMode         }         where           combine        = combine'        savedInstallFlags@@ -346,7 +332,6 @@        combinedSavedClientInstallFlags = ClientInstallFlags         { cinstInstallLibs     = combine cinstInstallLibs-        , cinstIgnoreProject   = combine cinstIgnoreProject         , cinstEnvironmentPath = combine cinstEnvironmentPath         , cinstOverwritePolicy = combine cinstOverwritePolicy         , cinstInstallMethod   = combine cinstInstallMethod@@ -529,6 +514,12 @@           combine      = combine'        savedBenchmarkFlags           lastNonEmpty = lastNonEmpty'   savedBenchmarkFlags +      combinedSavedProjectFlags = ProjectFlags+        { flagProjectFileName = combine flagProjectFileName+        , flagIgnoreProject   = combine flagIgnoreProject+        }+        where+          combine      = combine'        savedProjectFlags  -- -- * Default config@@ -561,7 +552,7 @@     }   } --- | This is the initial configuration that we write out to to the config file+-- | This is the initial configuration that we write out to the config file -- if the file does not exist (or the config we use if the file cannot be read -- for some other reason). When the config gets loaded it gets layered on top -- of 'baseSavedConfig' so we do not need to include it into the initial@@ -585,7 +576,7 @@     },     savedInstallFlags    = mempty {       installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],-      installBuildReports= toFlag AnonymousReports,+      installBuildReports= toFlag NoReports,       installNumJobs     = toFlag Nothing     },     savedClientInstallFlags = mempty {@@ -645,8 +636,9 @@ defaultRemoteRepo :: RemoteRepo defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False   where-    name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""+    str  = "hackage.haskell.org"+    name = RepoName str+    uri  = URI "http:" (Just (URIAuth "" str "")) "/" "" ""     -- Note that lots of old ~/.cabal/config files will have the old url     -- http://hackage.haskell.org/packages/archive     -- but new config files can use the new url (without the /packages/archive)@@ -826,8 +818,8 @@       ,"--"       ,"-- This config file was generated using the following versions"       ,"-- of Cabal and cabal-install:"-      ,"-- Cabal library version: " ++ Text.display cabalVersion-      ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version+      ,"-- Cabal library version: " ++ prettyShow cabalVersion+      ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion       ,"",""       ] @@ -846,11 +838,11 @@             },         savedInitFlags       = mempty {             IT.interactive     = toFlag False,-            IT.cabalVersion    = toFlag (mkVersion [1,10]),+            IT.cabalVersion    = toFlag IT.defaultCabalVersion,             IT.language        = toFlag Haskell2010,-            IT.license         = toFlag BSD3,-            IT.sourceDirs      = Nothing,-            IT.applicationDirs = Nothing+            IT.license         = NoFlag,+            IT.sourceDirs      = Just [IT.defaultSourceDir],+            IT.applicationDirs = Just [IT.defaultApplicationDir]             },         savedInstallFlags      = defaultInstallFlags,         savedClientInstallFlags= defaultClientInstallFlags,@@ -890,7 +882,7 @@       toSavedConfig liftGlobalFlag        (commandOptions (globalCommand []) ParseArgs)-       ["version", "numeric-version", "config-file", "sandbox-config-file"] []+       ["version", "numeric-version", "config-file"] []    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)@@ -900,8 +892,8 @@         -- This is only here because viewAsFieldDescr gives us a parser         -- that only recognises 'ghc' etc, the case-sensitive flag names, not         -- what the normal case-insensitive parser gives us.-       [simpleField "compiler"-          (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)+       [simpleFieldParsec "compiler"+          (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag)           configHcFlavor (\v flags -> flags { configHcFlavor = v })          -- TODO: The following is a temporary fix. The "optimization"@@ -963,16 +955,16 @@        (configureExOptions ParseArgs src)        []        [let pkgs            = (Just . AllowOlder . RelaxDepsSome)-                              `fmap` parseOptCommaList Text.parse+                              `fmap` parsecOptCommaList parsec             parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)-                               `fmap` Text.parse) Parse.<++ pkgs+                               `fmap` parsec) Parse.<++ pkgs          in simpleField "allow-older"             (showRelaxDeps . fmap unAllowOlder) parseAllowOlder             configAllowOlder (\v flags -> flags { configAllowOlder = v })        ,let pkgs            = (Just . AllowNewer . RelaxDepsSome)-                              `fmap` parseOptCommaList Text.parse+                              `fmap` parsecOptCommaList parsec             parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)-                               `fmap` Text.parse) Parse.<++ pkgs+                               `fmap` parsec) Parse.<++ pkgs          in simpleField "allow-newer"             (showRelaxDeps . fmap unAllowNewer) parseAllowNewer             configAllowNewer (\v flags -> flags { configAllowNewer = v })@@ -1020,9 +1012,7 @@             name        = fieldName field             replacement = find ((== name) . fieldName) replacements       , name `notElem` exclusions ]-    optional = Parse.option mempty . fmap toFlag -     showRelaxDeps Nothing                     = mempty     showRelaxDeps (Just rd) | isRelaxDeps rd  = Disp.text "True"                             | otherwise       = Disp.text "False"@@ -1036,8 +1026,8 @@ deprecatedFieldDescriptions :: [FieldDescr SavedConfig] deprecatedFieldDescriptions =   [ liftGlobalFlag $-    listField "repos"-      (Disp.text . showRemoteRepo) parseRemoteRepo+    listFieldParsec "repos"+      pretty parsec       (fromNubList . globalRemoteRepos)       (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })   , liftGlobalFlag $@@ -1196,7 +1186,9 @@      parseSections (rs, ls, h, i, u, g, p, a)                  (ParseUtils.Section lineno "repository" name fs) = do-      r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs+      name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $+          simpleParsec name+      r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs       r'' <- postProcessRepo lineno name r'       case r'' of           Left local   -> return (rs,        local:ls, h, i, u, g, p, a)@@ -1204,7 +1196,7 @@      parseSections (rs, ls, h, i, u, g, p, a)                  (ParseUtils.F lno "remote-repo" raw) = do-      let mr' = readRemoteRepo raw+      let mr' = simpleParsec raw       r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'       return (r':rs, ls, h, i, u, g, p, a) @@ -1253,11 +1245,14 @@       return accum  postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)-postProcessRepo lineno reponame repo0 = do-    when (null reponame) $+postProcessRepo lineno reponameStr repo0 = do+    when (null reponameStr) $         syntaxError lineno $ "a 'repository' section requires the "                           ++ "repository name as an argument" +    reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $+        simpleParsec reponameStr+     case uriScheme (remoteRepoURI repo0) of         -- TODO: check that there are no authority, query or fragment         -- Note: the trailing colon is important@@ -1329,7 +1324,7 @@ installDirsFields = map viewAsFieldDescr installDirsOptions  ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc-ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)+ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))     remoteRepoFields (Just def) vals  remoteRepoFields :: [FieldDescr RemoteRepo]@@ -1337,14 +1332,14 @@   [ simpleField "url"     (text . show)            (parseTokenQ >>= parseURI')     remoteRepoURI            (\x repo -> repo { remoteRepoURI = x })-  , simpleField "secure"-    showSecure               (Just `fmap` Text.parse)+  , simpleFieldParsec "secure"+    showSecure               (Just `fmap` parsec)     remoteRepoSecure         (\x repo -> repo { remoteRepoSecure = x })   , listField "root-keys"     text                     parseTokenQ     remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })-  , simpleField "key-threshold"-    showThreshold            Text.parse+  , simpleFieldParsec "key-threshold"+    showThreshold            P.integral     remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })   ]   where
Distribution/Client/Configure.hs view
@@ -63,12 +63,10 @@          ( InstalledPackageIndex, lookupPackageName ) import Distribution.Package          ( Package(..), packageName, PackageId )-import Distribution.Types.Dependency-         ( thisPackageVersion ) import Distribution.Types.GivenComponent          ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..) )+         ( PackageVersionConstraint(..), thisPackageVersionConstraint ) import qualified Distribution.PackageDescription as PkgDesc import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )@@ -82,12 +80,7 @@          , defaultPackageDesc ) import Distribution.System          ( Platform )-import Distribution.Deprecated.Text ( display )-import Distribution.Verbosity as Verbosity-         ( Verbosity ) -import Data.Foldable-         ( forM_ ) import System.FilePath ( (</>) )  -- | Choose the Cabal version such that the setup scripts compiled against this@@ -245,7 +238,7 @@     maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo     maybeSetupBuildInfo = do       ReadyPackage cpkg <- mpkg-      let gpkg = packageDescription (confPkgSource cpkg)+      let gpkg = srcpkgDescription (confPkgSource cpkg)       PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)      -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If@@ -275,12 +268,12 @@                    -> ConfigExFlags                    -> IO () checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do-  forM_ (safeHead unknownConstraints) $ \h ->+  for_ (safeHead unknownConstraints) $ \h ->     warn verbosity $ "Constraint refers to an unknown package: "           ++ showConstraint h-  forM_ (safeHead unknownPreferences) $ \h ->+  for_ (safeHead unknownPreferences) $ \h ->     warn verbosity $ "Preference refers to an unknown package: "-          ++ display h+          ++ prettyShow h   where     unknownConstraints = filter (unknown . userConstraintPackageName . fst) $                          configExConstraints flags@@ -289,7 +282,7 @@     unknown pkg = null (lookupPackageName installedPkgIndex pkg)                && not (elemByPackageName sourcePkgIndex pkg)     showConstraint (uc, src) =-        display uc ++ " (" ++ showConstraintSource src ++ ")"+        prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"  -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies.@@ -312,10 +305,10 @@    let -- We create a local package and ask to resolve a dependency on it       localPkg = SourcePackage {-        packageInfoId             = packageId pkg,-        packageDescription        = pkg,-        packageSource             = LocalUnpackedPackage ".",-        packageDescrOverride      = Nothing+        srcpkgPackageId          = packageId pkg,+        srcpkgDescription        = pkg,+        srcpkgSource             = LocalUnpackedPackage ".",+        srcpkgDescrOverride      = Nothing       }        testsEnabled = fromFlagOrDefault False $ configTests configFlags@@ -399,17 +392,17 @@     scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)    where-    gpkg = packageDescription spkg+    gpkg = srcpkgDescription spkg     configureFlags   = filterConfigureFlags configFlags {       configIPID = if isJust (flagToMaybe (configIPID configFlags))                     -- Make sure cabal configure --ipid works.                     then configIPID configFlags-                    else toFlag (display ipid),+                    else toFlag (prettyShow ipid),       configConfigurationsFlags = flags,       -- We generate the legacy constraints as well as the new style precise       -- deps.  In the end only one set gets passed to Setup.hs configure,       -- depending on the Cabal version we are talking to.-      configConstraints  = [ thisPackageVersion srcid+      configConstraints  = [ thisPackageVersionConstraint srcid                            | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid                                <- CD.nonSetupDeps deps ],       configDependencies = [ GivenComponent (packageName srcid) cname uid
Distribution/Client/Dependency.hs view
@@ -34,9 +34,6 @@     standardInstallPolicy,     PackageSpecifier(..), -    -- ** Sandbox policy-    applySandboxInstallPolicy,-     -- ** Extra policy options     upgradeDependencies,     reinstallTargets,@@ -67,6 +64,9 @@     addSetupCabalMaxVersionConstraint,   ) where +import Distribution.Client.Compat.Prelude+import qualified Prelude as Unsafe (head)+ import Distribution.Solver.Modular          ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex)@@ -83,8 +83,6 @@ import Distribution.Client.Dependency.Types          ( PreSolver(..), Solver(..)          , PackagesPreferenceDefault(..) )-import Distribution.Client.Sandbox.Types-         ( SandboxPackageInfo(..) ) import Distribution.Package          ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId          , Package(..), packageName, packageVersion )@@ -93,22 +91,16 @@ import qualified Distribution.PackageDescription.Configuration as PD import Distribution.PackageDescription.Configuration          ( finalizePD )-import Distribution.Client.PackageUtils-         ( externalBuildDepends ) import Distribution.Compiler          ( CompilerInfo(..) ) import Distribution.System          ( Platform ) import Distribution.Client.Utils          ( duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Utils-         ( comparing ) import Distribution.Simple.Setup          ( asBool )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Verbosity-         ( normal, Verbosity )+         ( normal  ) import Distribution.Version import qualified Distribution.Compat.Graph as Graph @@ -133,12 +125,9 @@ import           Distribution.Solver.Types.Variable  import Data.List-         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )-import Data.Function (on)-import Data.Maybe (fromMaybe, mapMaybe)+         ( maximumBy ) import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Set (Set) import Control.Exception          ( assert ) @@ -189,7 +178,7 @@  showDepResolverParams :: DepResolverParams -> String showDepResolverParams p =-     "targets: " ++ intercalate ", " (map display $ Set.toList (depResolverTargets p))+     "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))   ++ "\nconstraints: "   ++   concatMap (("\n  " ++) . showLabeledConstraint)        (depResolverConstraints p)@@ -238,11 +227,11 @@ -- showPackagePreference :: PackagePreference -> String showPackagePreference (PackageVersionPreference   pn vr) =-  display pn ++ " " ++ display (simplifyVersionRange vr)+  prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) showPackagePreference (PackageInstalledPreference pn ip) =-  display pn ++ " " ++ show ip+  prettyShow pn ++ " " ++ show ip showPackagePreference (PackageStanzasPreference pn st) =-  display pn ++ " " ++ show st+  prettyShow pn ++ " " ++ show st  basicDepResolverParams :: InstalledPackageIndex                        -> PackageIndex.PackageIndex UnresolvedSourcePackage@@ -408,6 +397,7 @@       -- If you change this enumeration, make sure to update the list in       -- "Distribution.Solver.Modular.Solver" as well       , pkgname <- [ mkPackageName "base"+                   , mkPackageName "ghc-bignum"                    , mkPackageName "ghc-prim"                    , mkPackageName "integer-gmp"                    , mkPackageName "integer-simple"@@ -477,9 +467,8 @@     sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params      relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage-    relaxDeps srcPkg = srcPkg {-      packageDescription = relaxPackageDeps relKind relDeps-                           (packageDescription srcPkg)+    relaxDeps srcPkg = srcPkg+      { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)       }  -- | Relax the dependencies of this package if needed.@@ -554,7 +543,7 @@     applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage     applyDefaultSetupDeps srcpkg =         srcpkg {-          packageDescription = gpkgdesc {+          srcpkgDescription = gpkgdesc {             PD.packageDescription = pkgdesc {               PD.setupBuildInfo =                 case PD.setupBuildInfo pkgdesc of@@ -571,7 +560,7 @@         }       where         isCustom = PD.buildType pkgdesc == PD.Custom-        gpkgdesc = packageDescription srcpkg+        gpkgdesc = srcpkgDescription srcpkg         pkgdesc  = PD.packageDescription gpkgdesc  -- | If a package has a custom setup then we need to add a setup-depends@@ -664,11 +653,10 @@       -- Force Cabal >= 1.24 dep when the package is affected by #3199.       mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]       mkDefaultSetupDeps srcpkg | affected        =-        Just [Dependency (mkPackageName "Cabal")-              (orLaterVersion $ mkVersion [1,24]) (Set.singleton PD.LMainLibName)]+        Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet]                                 | otherwise       = Nothing         where-          gpkgdesc = packageDescription srcpkg+          gpkgdesc = srcpkgDescription srcpkg           pkgdesc  = PD.packageDescription gpkgdesc           bt       = PD.buildType pkgdesc           affected = bt == PD.Custom && hasBuildableFalse gpkgdesc@@ -686,48 +674,6 @@           alwaysTrue (PD.Lit True) = True           alwaysTrue _             = False --applySandboxInstallPolicy :: SandboxPackageInfo-                             -> DepResolverParams-                             -> DepResolverParams-applySandboxInstallPolicy-  (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)-  params--  = addPreferences [ PackageInstalledPreference n PreferInstalled-                   | n <- installedNotModified ]--  . addTargets installedNotModified--  . addPreferences-      [ PackageVersionPreference (packageName pkg)-        (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]--  . addConstraints-      [ let pc = PackageConstraint-                 (scopeToplevel $ packageName pkg)-                 (PackagePropertyVersion $ thisVersion (packageVersion pkg))-        in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep-      | pkg <- modifiedDeps ]--  . addTargets [ packageName pkg | pkg <- modifiedDeps ]--  . hideInstalledPackagesSpecificBySourcePackageId-      [ packageId pkg | pkg <- modifiedDeps ]--  -- We don't need to add source packages for add-source deps to the-  -- 'installedPkgIndex' since 'getSourcePackages' did that for us.--  $ params--  where-    installedPkgIds =-      map fst . InstalledPackageIndex.allPackagesBySourcePackageId-      $ allSandboxPkgs-    modifiedPkgIds       = map packageId modifiedDeps-    installedNotModified = [ packageName pkg | pkg <- installedPkgIds,-                             pkg `notElem` modifiedPkgIds ]- -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------@@ -773,7 +719,7 @@                      pkgConfigDB preferences constraints targets   where -    finalparams @ (DepResolverParams+    finalparams@(DepResolverParams       targets constraints       prefs defpref       installedPkgIndex@@ -880,12 +826,12 @@  showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =-     "Package " ++ display (packageId pkg)+     "Package " ++ prettyShow (packageId pkg)   ++ " has an invalid configuration, in particular:\n"   ++ unlines [ "  " ++ showPackageProblem problem              | problem <- packageProblems ] showPlanPackageProblem (DuplicatePackageSolverId pid dups) =-     "Package " ++ display (packageId pid) ++ " has "+     "Package " ++ prettyShow (packageId pid) ++ " has "   ++ show (length dups) ++ " duplicate instances."  planPackagesProblems :: Platform -> CompilerInfo@@ -896,7 +842,7 @@      | Configured pkg <- pkgs      , let packageProblems = configuredPackageProblems platform cinfo pkg      , not (null packageProblems) ]-  ++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups+  ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups      | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]  data PackageProblem = DuplicateFlag PD.FlagName@@ -919,20 +865,20 @@  showPackageProblem (DuplicateDeps pkgids) =      "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map display pkgids)+  ++ intercalate ", " (map prettyShow pkgids)  showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ display dep+     "the package has a dependency " ++ prettyShow dep   ++ " but no package has been selected to satisfy it."  showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ display pkgid+     "the package configuration specifies " ++ prettyShow pkgid   ++ " but (with the given flag assignment) the package does not actually"   ++ " depend on any version of that package."  showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ display dep-  ++ " but the configuration specifies " ++ display pkgid+     "the package depends on " ++ prettyShow dep+  ++ " but the configuration specifies " ++ prettyShow pkgid   ++ " which does not satisfy the dependency."  -- | A 'ConfiguredPackage' is valid if the flag assignment is total and if@@ -942,25 +888,30 @@ configuredPackageProblems :: Platform -> CompilerInfo                           -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo-  (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =+  (SolverPackage pkg specifiedFlags stanzas specifiedDeps0  _specifiedExeDeps') =      [ DuplicateFlag flag      | flag <- PD.findDuplicateFlagAssignments specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]   ++ [ DuplicateDeps pkgs      | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))-                                specifiedDeps) ]+                                specifiedDeps1) ]   ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]   ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]   ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps                             , not (packageSatisfiesDependency pkgid dep) ]   -- TODO: sanity tests on executable deps   where-    specifiedDeps :: ComponentDeps [PackageId]-    specifiedDeps = fmap (map solverSrcId) specifiedDeps'+    thisPkgName = packageName (srcpkgDescription pkg) +    specifiedDeps1 :: ComponentDeps [PackageId]+    specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0++    specifiedDeps :: [PackageId]+    specifiedDeps = CD.flatDeps specifiedDeps1+     mergedFlags = mergeBy compare-      (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))+      (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))       (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO      packageSatisfiesDependency@@ -971,7 +922,7 @@     dependencyName (Dependency name _ _) = name      mergedDeps :: [MergeResult Dependency PackageId]-    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)+    mergedDeps = mergeDeps requiredDeps specifiedDeps      mergeDeps :: [Dependency] -> [PackageId]               -> [MergeResult Dependency PackageId]@@ -997,9 +948,17 @@          (const True)          platform cinfo          []-         (packageDescription pkg) of+         (srcpkgDescription pkg) of         Right (resolvedPkg, _) ->-             externalBuildDepends resolvedPkg compSpec+            -- we filter self/internal dependencies. They are still there.+            -- This is INCORRECT.+            --+            -- If we had per-component solver, it would make this unnecessary,+            -- but no finalizePDs picks components we are not building, eg. exes.+            -- See #3775+            --+            filter ((/= thisPkgName) . dependencyName)+                (PD.enabledBuildDepends resolvedPkg compSpec)           ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)         Left  _ ->           error "configuredPackageInvalidDeps internal error"@@ -1078,11 +1037,6 @@   where     collect ([], xs) = Right xs     collect (errs,_) = Left errs-    partitionEithers :: [Either a b] -> ([a],[b])-    partitionEithers = foldr (either left right) ([],[])-     where-       left  a (l, r) = (a:l, r)-       right a (l, r) = (l, a:r)  -- | Errors for 'resolveWithoutDependencies'. --@@ -1095,5 +1049,5 @@  instance Show ResolveNoDepsError where   show (ResolveUnsatisfiable name ver) =-       "There is no available version of " ++ display name-    ++ " that satisfies " ++ display (simplifyVersionRange ver)+       "There is no available version of " ++ prettyShow name+    ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver)
Distribution/Client/Dependency/Types.hs view
@@ -8,10 +8,9 @@ import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Deprecated.Text (Text (..))-import Text.PrettyPrint             (text)+import Text.PrettyPrint (text) -import qualified Distribution.Deprecated.ReadP as Parse (munch1, pfail)+import qualified Distribution.Compat.CharParsing as P   -- | All the solvers that can be selected.@@ -28,13 +27,15 @@ instance Structured PreSolver instance Structured Solver -instance Text PreSolver where-  disp AlwaysModular = text "modular"-  parse = do-    name <- Parse.munch1 isAlpha-    case map toLower name of-      "modular" -> return AlwaysModular-      _         -> Parse.pfail+instance Pretty PreSolver where+    pretty AlwaysModular = text "modular"++instance Parsec PreSolver where+    parsec = do+        name <- P.munch1 isAlpha+        case map toLower name of+            "modular" -> return AlwaysModular+            _         -> P.unexpected $ "PreSolver: " ++ name  -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available.
Distribution/Client/DistDirLayout.hs view
@@ -22,7 +22,9 @@     defaultCabalDirLayout ) where -import Data.Maybe (fromMaybe)+import Distribution.Client.Compat.Prelude+import Prelude ()+ import System.FilePath  import Distribution.Package@@ -30,9 +32,6 @@ import Distribution.Compiler import Distribution.Simple.Compiler          ( PackageDB(..), PackageDBStack, OptimisationLevel(..) )-import Distribution.Deprecated.Text-import Distribution.Pretty-         ( prettyShow ) import Distribution.Types.ComponentName import Distribution.Types.LibraryName import Distribution.System@@ -193,29 +192,29 @@     distBuildRootDirectory   = distDirectory </> "build"     distBuildDirectory params =         distBuildRootDirectory </>-        display (distParamPlatform params) </>-        display (distParamCompilerId params) </>-        display (distParamPackageId params) </>+        prettyShow (distParamPlatform params) </>+        prettyShow (distParamCompilerId params) </>+        prettyShow (distParamPackageId params) </>         (case distParamComponentName params of             Nothing                  -> ""             Just (CLibName LMainLibName) -> ""-            Just (CLibName (LSubLibName name)) -> "l" </> display name-            Just (CFLibName name)    -> "f" </> display name-            Just (CExeName name)     -> "x" </> display name-            Just (CTestName name)    -> "t" </> display name-            Just (CBenchName name)   -> "b" </> display name) </>+            Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name+            Just (CFLibName name)    -> "f" </> prettyShow name+            Just (CExeName name)     -> "x" </> prettyShow name+            Just (CTestName name)    -> "t" </> prettyShow name+            Just (CBenchName name)   -> "b" </> prettyShow name) </>         (case distParamOptimization params of             NoOptimisation -> "noopt"             NormalOptimisation -> ""             MaximumOptimisation -> "opt") </>-        (let uid_str = display (distParamUnitId params)-         in if uid_str == display (distParamComponentId params)+        (let uid_str = prettyShow (distParamUnitId params)+         in if uid_str == prettyShow (distParamComponentId params)                 then ""                 else uid_str)      distUnpackedSrcRootDirectory   = distDirectory </> "src"     distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory-                                      </> display pkgid+                                      </> prettyShow pkgid     -- we shouldn't get name clashes so this should be fine:     distDownloadSrcDirectory       = distUnpackedSrcRootDirectory @@ -233,7 +232,7 @@      distBinDirectory = distDirectory </> "bin" -    distPackageDBPath compid = distDirectory </> "packagedb" </> display compid+    distPackageDBPath compid = distDirectory </> "packagedb" </> prettyShow compid     distPackageDB = SpecificPackageDB . distPackageDBPath  @@ -242,10 +241,10 @@     StoreDirLayout {..}   where     storeDirectory compid =-      storeRoot </> display compid+      storeRoot </> prettyShow compid      storePackageDirectory compid ipkgid =-      storeDirectory compid </> display ipkgid+      storeDirectory compid </> prettyShow ipkgid      storePackageDBPath compid =       storeDirectory compid </> "package.db"@@ -260,7 +259,7 @@       storeDirectory compid </> "incoming"      storeIncomingLock compid unitid =-      storeIncomingDirectory compid </> display unitid <.> "lock"+      storeIncomingDirectory compid </> prettyShow unitid <.> "lock"   defaultCabalDirLayout :: FilePath -> CabalDirLayout
Distribution/Client/Exec.hs view
@@ -14,44 +14,28 @@ import Prelude () import Distribution.Client.Compat.Prelude -import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS--import Distribution.Client.Sandbox (getSandboxConfigFilePath)-import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath)-import Distribution.Client.Sandbox.Types              (UseSandbox (..))--import Distribution.Simple.Compiler    (Compiler, CompilerFlavor(..), compilerFlavor)-import Distribution.Simple.Program     (ghcProgram, ghcjsProgram, lookupProgram)+import Distribution.Simple.Compiler    (Compiler) import Distribution.Simple.Program.Db  (ProgramDb, requireProgram, modifyProgramSearchPath)-import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )-import Distribution.Simple.Utils       (die', warn)--import Distribution.System    (Platform(..), OS(..), buildOS)-import Distribution.Verbosity (Verbosity)--import System.Directory ( doesDirectoryExist )-import System.Environment (lookupEnv)-import System.FilePath (searchPathSeparator, (</>))+import Distribution.Simple.Utils       (die') +import Distribution.System    (Platform(..))  -- | Execute the given command in the package's environment. -- -- The given command is executed with GHC configured to use the correct -- package database and with the sandbox bin directory added to the PATH. exec :: Verbosity-     -> UseSandbox      -> Compiler      -> Platform      -> ProgramDb      -> [String]      -> IO ()-exec verbosity useSandbox comp platform programDb extraArgs =+exec verbosity _comp _platform programDb extraArgs =     case extraArgs of         (exe:args) -> do-            program <- requireProgram' verbosity useSandbox programDb exe+            program <- requireProgram' verbosity programDb exe             env <- environmentOverrides (programOverrideEnv program)             let invocation = programInvocation                                  program { programOverrideEnv = env }@@ -60,113 +44,15 @@          [] -> die' verbosity "Please specify an executable to run"   where-    environmentOverrides env =-        case useSandbox of-            NoSandbox -> return env-            (UseSandbox sandboxDir) ->-                sandboxEnvironment verbosity sandboxDir comp platform programDb env----- | Return the package's sandbox environment.------ The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox.-sandboxEnvironment :: Verbosity-                   -> FilePath-                   -> Compiler-                   -> Platform-                   -> ProgramDb-                   -> [(String, Maybe String)] -- environment overrides so far-                   -> IO [(String, Maybe String)]-sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv =-    case compilerFlavor comp of-      GHC   -> env GHC.getGlobalPackageDB   ghcProgram   "GHC_PACKAGE_PATH"-      GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH"-      _     -> die' verbosity "exec only works with GHC and GHCJS"-  where-    (Platform _ os) = platform-    ldPath = case os of-               OSX     -> "DYLD_LIBRARY_PATH"-               Windows -> "PATH"-               _       -> "LD_LIBRARY_PATH"-    env getGlobalPackageDB hcProgram packagePathEnvVar = do-        let program = fromMaybe (error "failed to find hcProgram") $ lookupProgram hcProgram programDb-        gDb <- getGlobalPackageDB verbosity program-        sandboxConfigFilePath <- getSandboxConfigFilePath mempty-        let sandboxPackagePath   = sandboxPackageDBPath sandboxDir comp platform-            compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath-        -- Packages database must exist, otherwise things will start-        -- failing in mysterious ways.-        exists <- doesDirectoryExist sandboxPackagePath-        unless exists $ warn verbosity $ "Package database is not a directory: "-                                           ++ sandboxPackagePath-        -- MASSIVE HACK.  We need this to be synchronized with installLibDir-        -- in defaultInstallDirs' in Distribution.Simple.InstallDirs,-        -- which has a special case for Windows (WHY? Who knows; it's been-        -- around as long as Windows exists.)  The sane thing to do here-        -- would be to read out the actual install dirs that were associated-        -- with the package in question, but that's not a well-formed question-        -- here because there is not actually install directory for the-        -- "entire" sandbox.  Since we want to kill this code in favor of-        -- new-build, I decided it wasn't worth fixing this "properly."-        -- Also, this doesn't handle LHC correctly but I don't care -- ezyang-        let extraLibPath =-                case buildOS of-                    Windows -> sandboxDir-                    _ -> sandboxDir </> "lib"-        -- 2016-11-26 Apologies for the spaghetti code here.-        -- Essentially we just want to add the sandbox's lib/ dir to-        -- whatever the library search path environment variable is:-        -- this allows running existing executables against foreign-        -- libraries (meaning Haskell code with a bunch of foreign-        -- exports). However, on Windows this variable is equal to the-        -- executable search path env var. And we try to keep not only-        -- what was already set in the environment, but also the-        -- additional directories we add below in requireProgram'. So-        -- the strategy is that we first take the environment-        -- overrides from requireProgram' below. If the library search-        -- path env is overridden (e.g. because we're on windows), we-        -- prepend the lib/ dir to the relevant override. If not, we-        -- want to avoid wiping the user's own settings, so we first-        -- read the env var's current value, and then prefix ours if-        -- the user had any set.-        iEnv' <--          if any ((==ldPath) . fst) iEnv-            then return $ updateLdPath extraLibPath iEnv-            else do-              currentLibraryPath <- lookupEnv ldPath-              let updatedLdPath =-                    case currentLibraryPath of-                      Nothing -> Just extraLibPath-                      Just paths ->-                        Just $ extraLibPath ++ [searchPathSeparator] ++ paths-              return $ (ldPath, updatedLdPath) : iEnv--        -- Build the environment-        return $ [ (packagePathEnvVar, Just compilerPackagePaths)-                 , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)-                 , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)-                 ] ++ iEnv'--    prependToSearchPath path newValue =-        newValue ++ [searchPathSeparator] ++ path--    updateLdPath path = map update-      where-        update (name, Just current)-          | name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current)-        update (name, Nothing)-          | name == ldPath = (ldPath, Just path)-        update x = x-+    environmentOverrides env = return env  -- | Check that a program is configured and available to be run. If -- a sandbox is available check in the sandbox's directory. requireProgram' :: Verbosity-                -> UseSandbox                 -> ProgramDb                 -> String                 -> IO ConfiguredProgram-requireProgram' verbosity useSandbox programDb exe = do+requireProgram' verbosity programDb exe = do     (program, _) <- requireProgram                         verbosity                         (simpleProgram exe)@@ -174,8 +60,4 @@     return program   where     updateSearchPath =-        flip modifyProgramSearchPath programDb $ \searchPath ->-            case useSandbox of-                NoSandbox -> searchPath-                UseSandbox sandboxDir ->-                    ProgramSearchPathDir (sandboxDir </> "bin") : searchPath+        flip modifyProgramSearchPath programDb $ \searchPath -> searchPath
Distribution/Client/Fetch.hs view
@@ -14,6 +14,9 @@     fetch,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.FetchUtils hiding (fetchPackage)@@ -44,14 +47,7 @@          ( die', notice, debug ) import Distribution.System          ( Platform )-import Distribution.Deprecated.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity ) -import Control.Monad-         ( filterM )- -- ------------------------------------------------------------ -- * The fetch command -- ------------------------------------------------------------@@ -84,7 +80,7 @@ fetch verbosity packageDBs repoCtxt comp platform progdb       globalFlags fetchFlags userTargets = do -    mapM_ (checkTarget verbosity) userTargets+    traverse_ (checkTarget verbosity) userTargets      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt@@ -99,7 +95,7 @@                verbosity comp platform fetchFlags                installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers -    pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs+    pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs     if null pkgs'       --TODO: when we add support for remote tarballs then this message       -- will need to be changed because for remote tarballs we fetch them@@ -110,9 +106,9 @@       else if dryRun              then notice verbosity $ unlines $                      "The following packages would be fetched:"-                   : map (display . packageId) pkgs'+                   : map (prettyShow . packageId) pkgs' -             else mapM_ (fetchPackage verbosity repoCtxt . packageSource) pkgs'+             else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'    where     dryRun = fromFlag (fetchDryRun fetchFlags)
Distribution/Client/FetchUtils.hs view
@@ -32,6 +32,9 @@     downloadIndex,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.Types import Distribution.Client.HttpUtils          ( downloadURI, isOldHackageURI, DownloadResult(..)@@ -41,19 +44,14 @@          ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils          ( notice, info, debug, die' )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Verbosity-         ( Verbosity, verboseUnmarkOutput )+         ( verboseUnmarkOutput ) import Distribution.Client.GlobalFlags          ( RepoContext(..) ) import Distribution.Client.Utils          ( ProgressPhase(..), progressMessage ) -import Data.Maybe-import Data.Map (Map) import qualified Data.Map as Map-import Control.Monad import Control.Exception import Control.Concurrent.Async import Control.Concurrent.MVar@@ -84,8 +82,8 @@     RemoteTarballPackage _uri local -> return (isJust local)     RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)     RemoteSourceRepoPackage _ local -> return (isJust local)-     + -- | Checks if the package has already been fetched (or does not need -- fetching) and if so returns evidence in the form of a 'PackageLocation' -- with a resolved local file location.@@ -101,8 +99,8 @@       return (Just $ RemoteTarballPackage uri file)     RepoTarballPackage repo pkgid (Just file) ->       return (Just $ RepoTarballPackage repo pkgid file)-    RemoteSourceRepoPackage repo (Just dir) ->-      return (Just $ RemoteSourceRepoPackage repo dir)+    RemoteSourceRepoPackage repo (Just file) ->+      return (Just $ RemoteSourceRepoPackage repo file)      RemoteTarballPackage     _uri Nothing -> return Nothing     RemoteSourceRepoPackage _repo Nothing -> return Nothing@@ -165,19 +163,18 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do   fetched <- doesFileExist (packageFile repo pkgid)   if fetched-    then do info verbosity $ display pkgid ++ " has already been downloaded."+    then do info verbosity $ prettyShow pkgid ++ " has already been downloaded."             return (packageFile repo pkgid)-    else do progressMessage verbosity ProgressDownloading (display pkgid)+    else do progressMessage verbosity ProgressDownloading (prettyShow pkgid)             res <- downloadRepoPackage-            progressMessage verbosity ProgressDownloaded (display pkgid)+            progressMessage verbosity ProgressDownloaded (prettyShow pkgid)             return res   where     -- whether we download or not is non-deterministic     verbosity = verboseUnmarkOutput verbosity'      downloadRepoPackage = case repo of-      RepoLocal{..} -> return (packageFile repo pkgid)-      RepoLocalNoIndex{..} -> return (packageFile repo pkgid)+      RepoLocalNoIndex{} -> return (packageFile repo pkgid)        RepoRemote{..} -> do         transport <- repoContextGetTransport repoCtxt@@ -238,13 +235,15 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do     --TODO: [nice to have] use parallel downloads? -    asyncDownloadVars <- sequence [ do v <- newEmptyMVar-                                       return (pkgloc, v)-                                  | pkgloc <- pkglocs ]+    asyncDownloadVars <- sequenceA+        [ do v <- newEmptyMVar+             return (pkgloc, v)+        | pkgloc <- pkglocs+        ]      let fetchPackages :: IO ()         fetchPackages =-          forM_ asyncDownloadVars $ \(pkgloc, var) -> do+          for_ asyncDownloadVars $ \(pkgloc, var) -> do             -- Suppress marking here, because 'withAsync' means             -- that we get nondeterministic interleaving             result <- try $ fetchPackage (verboseUnmarkOutput verbosity)@@ -286,7 +285,7 @@ -- packageFile :: Repo -> PackageId -> FilePath packageFile repo pkgid = packageDir repo pkgid-                     </> display pkgid+                     </> prettyShow pkgid                      <.> "tar.gz"  -- | Generate the full path to the directory where the local cached copy of@@ -295,8 +294,8 @@ packageDir :: Repo -> PackageId -> FilePath packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir packageDir repo pkgid = repoLocalDir repo-                    </> display (packageName    pkgid)-                    </> display (packageVersion pkgid)+                    </> prettyShow (packageName    pkgid)+                    </> prettyShow (packageVersion pkgid)  -- | Generate the URI of the tarball for a given package. --@@ -305,14 +304,14 @@   (remoteRepoURI repo) {     uriPath = FilePath.Posix.joinPath       [uriPath (remoteRepoURI repo)-      ,display (packageName    pkgid)-      ,display (packageVersion pkgid)-      ,display pkgid <.> "tar.gz"]+      ,prettyShow (packageName    pkgid)+      ,prettyShow (packageVersion pkgid)+      ,prettyShow pkgid <.> "tar.gz"]   } packageURI repo pkgid =   (remoteRepoURI repo) {     uriPath = FilePath.Posix.joinPath       [uriPath (remoteRepoURI repo)       ,"package"-      ,display pkgid <.> "tar.gz"]+      ,prettyShow pkgid <.> "tar.gz"]   }
Distribution/Client/FileMonitor.hs view
@@ -652,7 +652,7 @@                  . filter (matchGlob glob)                =<< liftIO (getDirectoryContents (root </> dirName)) -        children' <- mapM probeMergeResult $+        children' <- traverse probeMergeResult $                           mergeBy (\(path1,_) path2 -> compare path1 path2)                                   children                                   (sort matches)@@ -717,14 +717,14 @@         matches <- return . filter (matchGlob glob)                =<< liftIO (getDirectoryContents (root </> dirName)) -        mapM_ probeMergeResult $+        traverse_ probeMergeResult $               mergeBy (\(path1,_) path2 -> compare path1 path2)                       children                       (sort matches)         return mtime'      -- Check that none of the children have changed-    forM_ children $ \(file, status) ->+    for_ children $ \(file, status) ->       probeMonitorStateFileStatus root (dirName </> file) status  @@ -928,7 +928,7 @@         subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))                  $ filter (matchGlob glob) dirEntries         subdirStates <--          forM (sort subdirs) $ \subdir -> do+          for (sort subdirs) $ \subdir -> do             fstate <- buildMonitorStateGlobRel                         mstartTime hashcache kindfile kinddir root                         (dir </> subdir) globPath'@@ -938,7 +938,7 @@       GlobFile glob -> do         let files = filter (matchGlob glob) dirEntries         filesStates <--          forM (sort files) $ \file -> do+          for (sort files) $ \file -> do             fstate <- buildMonitorStateFile                         mstartTime hashcache kindfile kinddir root                         (dir </> file)
Distribution/Client/Freeze.hs view
@@ -33,8 +33,6 @@ import Distribution.Client.Sandbox.PackageEnvironment          ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,            userPackageEnvironmentFile )-import Distribution.Client.Sandbox.Types-         ( SandboxPackageInfo(..) )  import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint@@ -52,15 +50,10 @@ import Distribution.Simple.Setup          ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils-         ( die', notice, debug, writeFileAtomic )+         ( die', notice, debug, writeFileAtomic, toUTF8LBS) import Distribution.System          ( Platform )-import Distribution.Deprecated.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity ) -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Distribution.Version          ( thisVersion ) @@ -77,15 +70,14 @@        -> Compiler        -> Platform        -> ProgramDb-       -> Maybe SandboxPackageInfo        -> GlobalFlags        -> FreezeFlags        -> IO ()-freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo+freeze verbosity packageDBs repoCtxt comp platform progdb       globalFlags freezeFlags = do      pkgs  <- getFreezePkgs-               verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo+               verbosity packageDBs repoCtxt comp platform progdb                globalFlags freezeFlags      if null pkgs@@ -109,11 +101,10 @@               -> Compiler               -> Platform               -> ProgramDb-              -> Maybe SandboxPackageInfo               -> GlobalFlags               -> FreezeFlags               -> IO [SolverPlanPackage]-getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo+getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb       globalFlags freezeFlags = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb@@ -127,7 +118,7 @@      sanityCheck pkgSpecifiers     planPackages-               verbosity comp platform mSandboxPkgInfo freezeFlags+               verbosity comp platform freezeFlags                installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers   where     sanityCheck pkgSpecifiers = do@@ -141,14 +132,13 @@ planPackages :: Verbosity              -> Compiler              -> Platform-             -> Maybe SandboxPackageInfo              -> FreezeFlags              -> InstalledPackageIndex              -> SourcePackageDb              -> PkgConfigDb              -> [PackageSpecifier UnresolvedSourcePackage]              -> IO [SolverPlanPackage]-planPackages verbosity comp platform mSandboxPkgInfo freezeFlags+planPackages verbosity comp platform freezeFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do    solver <- chooseSolver verbosity@@ -196,8 +186,6 @@             in LabeledPackageConstraint pc ConstraintSourceFreeze           | pkgSpecifier <- pkgSpecifiers ] -      . maybe id applySandboxInstallPolicy mSandboxPkgInfo-       $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers      logMsg message rest = debug verbosity message >> rest@@ -267,12 +255,12 @@             UserConstraint (UserQualified UserQualToplevel (packageName pkgId))                            (PackagePropertyVersion $ thisVersion (packageVersion pkgId))     createPkgEnv config = mempty { pkgEnvSavedConfig = config }-    showPkgEnv = BS.Char8.pack . showPackageEnvironment+    showPkgEnv = toUTF8LBS . showPackageEnvironment   formatPkgs :: Package pkg => [pkg] -> [String] formatPkgs = map $ showPkg . packageId   where     showPkg pid = name pid ++ " == " ++ version pid-    name = display . packageName-    version = display . packageVersion+    name = prettyShow . packageName+    version = prettyShow . packageVersion
Distribution/Client/GZipUtils.hs view
@@ -24,6 +24,10 @@ import Codec.Compression.Zlib.Internal import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) +#ifndef MIN_VERSION_zlib+#define MIN_VERSION_zlib(x,y,z) 1+#endif+ #if MIN_VERSION_zlib(0,6,0) import Control.Exception (throw) import Control.Monad.ST.Lazy (ST, runST)
Distribution/Client/GenBounds.hs view
@@ -23,8 +23,6 @@          ( incVersion ) import Distribution.Client.Freeze          ( getFreezePkgs )-import Distribution.Client.Sandbox.Types-         ( SandboxPackageInfo(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), FreezeFlags(..), RepoContext ) import Distribution.Package@@ -46,10 +44,6 @@          ( tryFindPackageDesc ) import Distribution.System          ( Platform )-import Distribution.Deprecated.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity ) import Distribution.Version          ( Version, alterVersion          , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals@@ -93,7 +87,7 @@     showInterval (LowerBound _ _, NoUpperBound) =       error "Error: expected upper bound...this should never happen!"     showInterval (LowerBound l _, UpperBound u _) =-      unwords [">=", display l, "&& <", display u]+      unwords [">=", prettyShow l, "&& <", prettyShow u]  -- | Entry point for the @gen-bounds@ command. genBounds@@ -103,13 +97,10 @@     -> Compiler     -> Platform     -> ProgramDb-    -> Maybe SandboxPackageInfo     -> GlobalFlags     -> FreezeFlags     -> IO ()-genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo-      globalFlags freezeFlags = do-+genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do      let cinfo = compilerInfo comp      cwd <- getCurrentDirectory@@ -133,7 +124,7 @@      go needBounds = do        pkgs  <- getFreezePkgs                   verbosity packageDBs repoCtxt comp platform progdb-                  mSandboxPkgInfo globalFlags freezeFlags+                  globalFlags freezeFlags         putStrLn boundsNeededMsg
Distribution/Client/Get.hs view
@@ -24,7 +24,6 @@  import Prelude () import Distribution.Client.Compat.Prelude hiding (get)-import Data.Ord (comparing) import Distribution.Compat.Directory          ( listDirectory ) import Distribution.Package@@ -33,15 +32,11 @@          ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils          ( notice, die', info, writeFileAtomic )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Pretty (prettyShow)-import Distribution.Deprecated.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program          ( programName ) import Distribution.Types.SourceRepo (RepoKind (..))-import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)  import Distribution.Client.Setup          ( GlobalFlags(..), GetFlags(..), RepoContext(..) )@@ -51,19 +46,13 @@ import Distribution.Client.VCS import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils as IndexUtils-        ( getSourcePackagesAtIndexState )+import Distribution.Client.IndexUtils+        ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) import Distribution.Solver.Types.SourcePackage -import Control.Exception-         ( Exception(..), catch, throwIO )-import Control.Monad-         ( mapM, forM_, mapM_ ) import qualified Data.Map as Map import System.Directory          ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )-import System.Exit-         ( ExitCode(..) ) import System.FilePath          ( (</>), (<.>), addTrailingPathSeparator ) @@ -84,12 +73,16 @@                         _      -> True    unless useSourceRepo $-    mapM_ (checkTarget verbosity) userTargets+    traverse_ (checkTarget verbosity) userTargets -  let idxState = flagToMaybe $ getIndexState getFlags+  let idxState :: Maybe TotalIndexState+      idxState = flagToMaybe $ getIndexState getFlags -  sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState+      activeRepos :: Maybe ActiveRepos+      activeRepos = flagToMaybe $ getActiveRepos getFlags +  (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos+   pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                    (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)@@ -121,15 +114,15 @@         packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]         packageSourceRepos = PD.sourceRepos                            . PD.packageDescription-                           . packageDescription+                           . srcpkgDescription      unpack :: [UnresolvedSourcePackage] -> IO ()     unpack pkgs = do-      forM_ pkgs $ \pkg -> do-        location <- fetchPackage verbosity repoCtxt (packageSource pkg)+      for_ pkgs $ \pkg -> do+        location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)         let pkgid = packageId pkg             descOverride | usePristine = Nothing-                         | otherwise   = packageDescrOverride pkg+                         | otherwise   = srcpkgDescrOverride pkg         case location of           LocalTarballPackage tarballPath ->             unpackPackage verbosity prefix pkgid descOverride tarballPath@@ -167,7 +160,7 @@               -> PackageDescriptionOverride               -> FilePath  -> IO () unpackPackage verbosity prefix pkgid descOverride pkgPath = do-    let pkgdirname               = display pkgid+    let pkgdirname               = prettyShow pkgid         pkgdir                   = prefix </> pkgdirname         pkgdir'                  = addTrailingPathSeparator pkgdir         emptyDirectory directory = null <$> listDirectory directory@@ -186,7 +179,7 @@     case descOverride of       Nothing     -> return ()       Just pkgtxt -> do-        let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"+        let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"         info verbosity $           "Updating " ++ descFilePath                       ++ " with the latest revision from the index."@@ -210,37 +203,37 @@  instance Exception ClonePackageException where   displayException (ClonePackageNoSourceRepos pkgid) =-       "Cannot fetch a source repository for package " ++ display pkgid+       "Cannot fetch a source repository for package " ++ prettyShow pkgid     ++ ". The package does not specify any source repositories."    displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =-       "Cannot fetch a source repository for package " ++ display pkgid+       "Cannot fetch a source repository for package " ++ prettyShow pkgid     ++ ". The package does not specify a source repository of the requested "-    ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind+    ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind    displayException (ClonePackageNoRepoType pkgid _repo) =-       "Cannot fetch the source repository for package " ++ display pkgid+       "Cannot fetch the source repository for package " ++ prettyShow pkgid     ++ ". The package's description specifies a source repository but does "     ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."    displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =-       "Cannot fetch the source repository for package " ++ display pkgid-    ++ ". The repository type '" ++ display repoType+       "Cannot fetch the source repository for package " ++ prettyShow pkgid+    ++ ". The repository type '" ++ prettyShow repoType     ++ "' is not yet supported."    displayException (ClonePackageNoRepoLocation pkgid _repo) =-       "Cannot fetch the source repository for package " ++ display pkgid+       "Cannot fetch the source repository for package " ++ prettyShow pkgid     ++ ". The package's description specifies a source repository but does "     ++ "not specify the repository 'location' field (i.e. the URL)."    displayException (ClonePackageDestinationExists pkgid dest isdir) =-       "Not fetching the source repository for package " ++ display pkgid ++ ". "+       "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "     ++ if isdir then "The destination directory " ++ dest ++ " already exists."                 else "A file " ++ dest ++ " is in the way."    displayException (ClonePackageFailedWithExitCode                       pkgid repo vcsprogname exitcode) =-       "Failed to fetch the source repository for package " ++ display pkgid+       "Failed to fetch the source repository for package " ++ prettyShow pkgid     ++ ", repository location " ++ srpLocation repo ++ " ("     ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." @@ -260,7 +253,7 @@                             preferredRepoKind pkgrepos = do      -- Do a bunch of checks and collect the required info-    pkgrepos' <- mapM preCloneChecks pkgrepos+    pkgrepos' <- traverse preCloneChecks pkgrepos      -- Configure the VCS drivers for all the repository types we may need     vcss <- configureVCSs verbosity $@@ -298,7 +291,7 @@         Left SourceRepoLocationUnspecified ->           throwIO (ClonePackageNoRepoLocation pkgid repo) -      let destDir = destDirPrefix </> display (packageName pkgid)+      let destDir = destDirPrefix </> prettyShow (packageName pkgid)       destDirExists  <- doesDirectoryExist destDir       destFileExists <- doesFileExist      destDir       when (destDirExists || destFileExists) $
Distribution/Client/Glob.hs view
@@ -15,19 +15,15 @@     , getFilePathRootDirectory     ) where -import Prelude () import Distribution.Client.Compat.Prelude--import           Data.List (stripPrefix)-import           Control.Monad (mapM)+import Prelude () -import           Distribution.Deprecated.Text-import           Distribution.Deprecated.ReadP (ReadP, (<++), (+++))-import qualified Distribution.Deprecated.ReadP as Parse-import qualified Text.PrettyPrint as Disp+import Data.List        (stripPrefix)+import System.Directory+import System.FilePath -import           System.FilePath-import           System.Directory+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp   -- | A file path specified by globbing@@ -131,7 +127,7 @@       subdirs <- filterM (\subdir -> doesDirectoryExist                                        (root </> dir </> subdir))                $ filter (matchGlob glob) entries-      concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs+      concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs      go GlobDirTrailing dir = return [dir] @@ -168,61 +164,50 @@ -- Parsing & printing -- -instance Text FilePathGlob where-  disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob-  parse =-    parse >>= \root ->-        (FilePathGlob root <$> parse)-    <++ (when (root == FilePathRelative) Parse.pfail >>-         return (FilePathGlob root GlobDirTrailing))--instance Text FilePathRoot where-  disp  FilePathRelative    = Disp.empty-  disp (FilePathRoot root)  = Disp.text root-  disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'+instance Pretty FilePathGlob where+  pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob -  parse =-        (     (Parse.char '/' >> return (FilePathRoot "/"))-          +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)-          +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')-                                             || (c >= 'A' && c <= 'Z'))-                  _ <- Parse.char ':'-                  _ <- Parse.char '/' +++ Parse.char '\\'-                  return (FilePathRoot (toUpper drive : ":\\")))-        )-    <++ return FilePathRelative+instance Parsec FilePathGlob where+    parsec = do+        root <- parsec+        case root of+            FilePathRelative -> FilePathGlob root <$> parsec+            _                -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) -instance Text FilePathGlobRel where-  disp (GlobDir  glob pathglob) = dispGlob glob-                          Disp.<> Disp.char '/'-                          Disp.<> disp pathglob-  disp (GlobFile glob)          = dispGlob glob-  disp  GlobDirTrailing         = Disp.empty+instance Pretty FilePathRoot where+    pretty  FilePathRelative    = Disp.empty+    pretty (FilePathRoot root)  = Disp.text root+    pretty FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/' -  parse = parsePath-    where-      parsePath :: ReadP r FilePathGlobRel-      parsePath =-        parseGlob >>= \globpieces ->-            asDir globpieces-        <++ asTDir globpieces-        <++ asFile globpieces+instance Parsec FilePathRoot where+    parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where+        root = FilePathRoot "/" <$ P.char '/'+        home = FilePathHomeDir <$ P.string "~/"+        drive = do+            dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+            _ <- P.char ':'+            _ <- P.char '/' <|> P.char '\\'+            return (FilePathRoot (toUpper dr : ":\\")) -      asDir  glob = do dirSep-                       globs <- parsePath-                       return (GlobDir glob globs)-      asTDir glob = do dirSep-                       return (GlobDir glob GlobDirTrailing)-      asFile glob = return (GlobFile glob)+instance Pretty FilePathGlobRel where+    pretty (GlobDir  glob pathglob) = dispGlob glob+                            Disp.<> Disp.char '/'+                            Disp.<> pretty pathglob+    pretty (GlobFile glob)          = dispGlob glob+    pretty GlobDirTrailing          = Disp.empty -      dirSep = (Parse.char '/' >> return ())-           +++ (do _ <- Parse.char '\\'-                   -- check this isn't an escape code-                   following <- Parse.look-                   case following of-                     (c:_) | isGlobEscapedChar c -> Parse.pfail-                     _                           -> return ())+instance Parsec FilePathGlobRel where+    parsec = parsecPath where+        parsecPath :: CabalParsing m => m FilePathGlobRel+        parsecPath = do+            glob <- parsecGlob+            dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) +        dirSep :: CabalParsing m => m ()+        dirSep = () <$ P.char '/' <|> P.try (do+            _ <- P.char '\\'+            -- check this isn't an escape code+            P.notFollowedBy (P.satisfy isGlobEscapedChar))  dispGlob :: Glob -> Disp.Doc dispGlob = Disp.hcat . map dispPiece@@ -238,29 +223,18 @@       | isGlobEscapedChar c = '\\' : c : escape cs       | otherwise           =        c : escape cs -parseGlob :: ReadP r Glob-parseGlob = Parse.many1 parsePiece-  where-    parsePiece = literal +++ wildcard +++ union--    wildcard = Parse.char '*' >> return WildCard--    union = Parse.between (Parse.char '{') (Parse.char '}') $-              fmap Union (Parse.sepBy1 parseGlob (Parse.char ','))--    literal = Literal `fmap` litchars1--    litchar = normal +++ escape+parsecGlob :: CabalParsing m => m Glob+parsecGlob = some parsecPiece where+    parsecPiece = P.choice [ literal, wildcard, union ] -    normal  = Parse.satisfy (\c -> not (isGlobEscapedChar c)-                                && c /= '/' && c /= '\\')-    escape  = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar+    wildcard = WildCard <$ P.char '*'+    union    = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))+    literal  = Literal <$> some litchar -    litchars1 :: ReadP r [Char]-    litchars1 = liftM2 (:) litchar litchars+    litchar = normal <|> escape -    litchars :: ReadP r [Char]-    litchars = litchars1 <++ return []+    normal  = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')+    escape  = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar  isGlobEscapedChar :: Char -> Bool isGlobEscapedChar '*'  = True
Distribution/Client/GlobalFlags.hs view
@@ -17,22 +17,21 @@ import Distribution.Client.Compat.Prelude  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey )+         ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) import Distribution.Simple.Setup          ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList          ( NubList, fromNubList ) import Distribution.Client.HttpUtils          ( HttpTransport, configureTransport )-import Distribution.Verbosity-         ( Verbosity ) import Distribution.Simple.Utils          ( info, warn ) +import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )+ import Control.Concurrent          ( MVar, newMVar, modifyMVar )-import Control.Exception-         ( throwIO ) import System.FilePath          ( (</>) ) import Network.URI@@ -55,55 +54,50 @@ -- ------------------------------------------------------------  -- | Flags that apply at the top level, not to any sub-command.-data GlobalFlags = GlobalFlags {-    globalVersion           :: Flag Bool,-    globalNumericVersion    :: Flag Bool,-    globalConfigFile        :: Flag FilePath,-    globalSandboxConfigFile :: Flag FilePath,-    globalConstraintsFile   :: Flag FilePath,-    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.-    globalCacheDir          :: Flag FilePath,-    globalLocalRepos        :: NubList FilePath,-    globalLocalNoIndexRepos :: NubList LocalRepo,-    globalLogsDir           :: Flag FilePath,-    globalWorldFile         :: Flag FilePath,-    globalRequireSandbox    :: Flag Bool,-    globalIgnoreSandbox     :: Flag Bool,-    globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates-    globalHttpTransport     :: Flag String,-    globalNix               :: Flag Bool,  -- ^ Integrate with Nix-    globalStoreDir          :: Flag FilePath,-    globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)-  } deriving Generic +data GlobalFlags = GlobalFlags+    { globalVersion           :: Flag Bool+    , globalNumericVersion    :: Flag Bool+    , globalConfigFile        :: Flag FilePath+    , globalConstraintsFile   :: Flag FilePath+    , globalRemoteRepos       :: NubList RemoteRepo     -- ^ Available Hackage servers.+    , globalCacheDir          :: Flag FilePath+    , globalLocalNoIndexRepos :: NubList LocalRepo+    , globalActiveRepos       :: Flag ActiveRepos+    , globalLogsDir           :: Flag FilePath+    , globalWorldFile         :: Flag FilePath+    , globalIgnoreExpiry      :: Flag Bool    -- ^ Ignore security expiry dates+    , globalHttpTransport     :: Flag String+    , globalNix               :: Flag Bool  -- ^ Integrate with Nix+    , globalStoreDir          :: Flag FilePath+    , globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)+    } deriving Generic+ defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion           = Flag False,-    globalNumericVersion    = Flag False,-    globalConfigFile        = mempty,-    globalSandboxConfigFile = mempty,-    globalConstraintsFile   = mempty,-    globalRemoteRepos       = mempty,-    globalCacheDir          = mempty,-    globalLocalRepos        = mempty,-    globalLocalNoIndexRepos = mempty,-    globalLogsDir           = mempty,-    globalWorldFile         = mempty,-    globalRequireSandbox    = Flag False,-    globalIgnoreSandbox     = Flag False,-    globalIgnoreExpiry      = Flag False,-    globalHttpTransport     = mempty,-    globalNix               = Flag False,-    globalStoreDir          = mempty,-    globalProgPathExtra     = mempty-  }+defaultGlobalFlags  = GlobalFlags+    { globalVersion           = Flag False+    , globalNumericVersion    = Flag False+    , globalConfigFile        = mempty+    , globalConstraintsFile   = mempty+    , globalRemoteRepos       = mempty+    , globalCacheDir          = mempty+    , globalLocalNoIndexRepos = mempty+    , globalActiveRepos       = mempty+    , globalLogsDir           = mempty+    , globalWorldFile         = mempty+    , globalIgnoreExpiry      = Flag False+    , globalHttpTransport     = mempty+    , globalNix               = Flag False+    , globalStoreDir          = mempty+    , globalProgPathExtra     = mempty+    }  instance Monoid GlobalFlags where-  mempty = gmempty-  mappend = (<>)+    mempty = gmempty+    mappend = (<>)  instance Semigroup GlobalFlags where-  (<>) = gmappend+    (<>) = gmappend  -- ------------------------------------------------------------ -- * Repo context@@ -146,23 +140,22 @@     withRepoContext'       verbosity       (fromNubList (globalRemoteRepos       globalFlags))-      (fromNubList (globalLocalRepos        globalFlags))       (fromNubList (globalLocalNoIndexRepos globalFlags))       (fromFlag    (globalCacheDir          globalFlags))       (flagToMaybe (globalHttpTransport     globalFlags))       (flagToMaybe (globalIgnoreExpiry      globalFlags))       (fromNubList (globalProgPathExtra     globalFlags)) -withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> [LocalRepo]+withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo]                  -> FilePath  -> Maybe String -> Maybe Bool                  -> [FilePath]                  -> (RepoContext -> IO a)                  -> IO a-withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos+withRepoContext' verbosity remoteRepos localNoIndexRepos                  sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do     for_ localNoIndexRepos $ \local ->         unless (FilePath.Posix.isAbsolute (localRepoPath local)) $-            warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended"+            warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"      transportRef <- newMVar Nothing     let httpLib = Sec.HTTP.transportAdapter@@ -172,7 +165,6 @@       callback RepoContext {           repoContextRepos          = allRemoteRepos                                    ++ allLocalNoIndexRepos-                                   ++ map RepoLocal localRepos         , repoContextGetTransport   = getTransport transportRef         , repoContextWithSecureRepo = withSecureRepo secureRepos'         , repoContextIgnoreExpiry   = fromMaybe False ignoreExpiry@@ -185,7 +177,7 @@     allRemoteRepos =       [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir       | remote <- remoteRepos-      , let cacheDir = sharedCacheDir </> remoteRepoName remote+      , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)             isSecure = remoteRepoSecure remote == Just True       ]
Distribution/Client/Haddock.hs view
@@ -16,8 +16,10 @@     )     where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Data.List (maximumBy)-import Data.Foldable (forM_) import System.Directory (createDirectoryIfMissing, renameFile) import System.FilePath ((</>), splitFileName) import Distribution.Package@@ -26,11 +28,10 @@ import Distribution.Simple.Program (haddockProgram, ProgramDb                                    , runProgram, requireProgramVersion) import Distribution.Version (mkVersion, orLaterVersion)-import Distribution.Verbosity (Verbosity) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, allPackagesByName ) import Distribution.Simple.Utils-         ( comparing, debug, installDirectoryContents, withTempDirectory )+         ( debug, installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo          ( InstalledPackageInfo(exposed) ) @@ -41,7 +42,7 @@ regenerateHaddockIndex verbosity pkgs progdb index = do       (paths, warns) <- haddockPackagePaths pkgs' Nothing       let paths' = [ (interface, html) | (interface, Just html, _) <- paths]-      forM_ warns (debug verbosity)+      for_ warns (debug verbosity)        (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram
Distribution/Client/HashValue.hs view
@@ -19,7 +19,6 @@ import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import Control.Exception (evaluate) import System.IO         (IOMode (..), withBinaryFile)  -----------------------------------------------
Distribution/Client/HttpUtils.hs view
@@ -28,23 +28,13 @@          ( browse, setOutHandler, setErrHandler, setProxy          , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) import qualified Control.Exception as Exception-import Control.Exception-         ( evaluate )-import Control.DeepSeq-         ( force )-import Control.Monad-         ( guard )-import qualified Data.ByteString.Lazy.Char8 as BS-import qualified Paths_cabal_install (version)-import Distribution.Verbosity (Verbosity)-import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils          ( die', info, warn, debug, notice          , copyFileVerbose,  withTempFile, IOData (..) ) import Distribution.Client.Utils-         ( withTempFileName )+         ( withTempFileName, cabalInstallVersion ) import Distribution.Client.Types-         ( RemoteRepo(..) )+         ( unRepoName, RemoteRepo(..) ) import Distribution.System          ( buildOS, buildArch ) import qualified System.FilePath.Posix as FilePath.Posix@@ -71,9 +61,14 @@          ( getProgramInvocationOutputAndErrors ) import Numeric (showHex) import System.Random (randomRIO)-import System.Exit (ExitCode(..))-import Data.Version (showVersion) +import qualified Crypto.Hash.SHA256         as SHA256+import qualified Data.ByteString.Base16     as Base16+import qualified Distribution.Compat.CharParsing as P+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Char8      as BS8+import qualified Data.ByteString.Lazy       as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8  ------------------------------------------------------------------------------ -- Downloading a URI, given an HttpTransport@@ -83,6 +78,12 @@                     | FileDownloaded FilePath   deriving (Eq) +data DownloadCheck+    = Downloaded                           -- ^ already downloaded and sha256 matches+    | CheckETag String                     -- ^ already downloaded and we have etag+    | NeedsDownload (Maybe BS.ByteString)  -- ^ needs download with optional hash check+  deriving Eq+ downloadURI :: HttpTransport             -> Verbosity             -> URI      -- ^ What to download@@ -96,14 +97,35 @@  downloadURI transport verbosity uri path = do -    let etagPath = path <.> "etag"-    targetExists   <- doesFileExist path-    etagPathExists <- doesFileExist etagPath-    -- In rare cases the target file doesn't exist, but the etag does.-    etag <- if targetExists && etagPathExists-              then Just <$> readFile etagPath-              else return Nothing+    targetExists <- doesFileExist path +    downloadCheck <-+      -- if we have uriFrag, then we expect there to be #sha256=...+      if not (null uriFrag)+      then case sha256parsed of+        -- we know the hash, and target exists+        Right expected | targetExists -> do+          contents <- LBS.readFile path+          let actual = SHA256.hashlazy contents+          if expected == actual+          then return Downloaded+          else return (NeedsDownload (Just expected))++        -- we known the hash, target doesn't exist+        Right expected -> return (NeedsDownload (Just expected))++        -- we failed to parse uriFragment+        Left err -> die' verbosity $+          "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err++      -- if there are no uri fragment, use ETag+      else do+        etagPathExists <- doesFileExist etagPath+        -- In rare cases the target file doesn't exist, but the etag does.+        if targetExists && etagPathExists+        then return (CheckETag etagPath)+        else return (NeedsDownload Nothing)+     -- Only use the external http transports if we actually have to     -- (or have been told to do so)     let transport'@@ -114,12 +136,29 @@           | otherwise           = transport -    withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do+    case downloadCheck of+      Downloaded         -> return FileAlreadyInCache+      CheckETag etag     -> makeDownload transport' Nothing (Just etag)+      NeedsDownload hash -> makeDownload transport' hash Nothing++  where+    makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do       result <- getHttp transport' verbosity uri etag tmpFile []        -- Only write the etag if we get a 200 response code.       -- A 304 still sends us an etag header.       case result of+        -- if we have hash, we don't care about etag.+        (200, _) | Just expected <- sha256 -> do+          contents <- LBS.readFile tmpFile+          let actual = SHA256.hashlazy contents+          unless (actual == expected) $+            die' verbosity $ unwords+              [ "Failed to download", show uri+              , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)+              , "actual:", BS8.unpack (Base16.encode actual)+              ]+         (200, Just newEtag) -> writeFile etagPath newEtag         _ -> return () @@ -131,9 +170,20 @@         304 -> do             notice verbosity "Skipping download: local and remote files match."             return FileAlreadyInCache-        errCode ->  die' verbosity $ "Failed to download " ++ show uri+        errCode ->  die' verbosity $ "failed to download " ++ show uri                        ++ " : HTTP code " ++ show errCode +    etagPath = path <.> "etag"+    uriFrag = uriFragment uri++    sha256parsed :: Either String BS.ByteString+    sha256parsed = explicitEitherParsec fragmentParser uriFrag++    fragmentParser = do+        _ <- P.string "#sha256="+        str <- some P.hexDigit+        return (fst (Base16.decode (BS8.pack str)))+ ------------------------------------------------------------------------------ -- Utilities for repo url management --@@ -142,8 +192,8 @@ remoteRepoCheckHttps verbosity transport repo   | uriScheme (remoteRepoURI repo) == "https:"   , not (transportSupportsHttps transport)-              = die' verbosity $ "The remote repository '" ++ remoteRepoName repo-                   ++ "' specifies a URL that " ++ requiresHttpsErrorMessage+  = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)+    ++ "' specifies a URL that " ++ requiresHttpsErrorMessage   | otherwise = return ()  transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()@@ -463,7 +513,7 @@         \responseFile responseHandle -> do           hClose responseHandle           (body, boundary) <- generateMultipartBody path-          BS.hPut tmpHandle body+          LBS.hPut tmpHandle body           hClose tmpHandle           let args = [ "--post-file=" ++ tmpFile                      , "--user-agent=" ++ userAgent@@ -586,7 +636,7 @@       withTempFile (takeDirectory path)                    (takeFileName path) $ \tmpFile tmpHandle -> do         (body, boundary) <- generateMultipartBody path-        BS.hPut tmpHandle body+        LBS.hPut tmpHandle body         hClose tmpHandle         fullPath <- canonicalizePath tmpFile @@ -736,7 +786,7 @@                   rqHeaders = [ Header HdrIfNoneMatch t                               | t <- maybeToList etag ]                            ++ reqHeaders,-                  rqBody    = BS.empty+                  rqBody    = LBS.empty                 }       (_, resp) <- cabalBrowse verbosity Nothing (request req)       let code  = convertRspCode (rspCode resp)@@ -752,7 +802,7 @@       (body, boundary) <- generateMultipartBody path       let headers = [ Header HdrContentType                              ("multipart/form-data; boundary="++boundary)-                    , Header HdrContentLength (show (BS.length body))+                    , Header HdrContentLength (show (LBS8.length body))                     , Header HdrAccept ("text/plain")                     ]           req = Request {@@ -765,11 +815,11 @@       return (convertRspCode (rspCode resp), rspErrorString resp)      puthttpfile verbosity uri path auth headers = do-      body <- BS.readFile path+      body <- LBS8.readFile path       let req = Request {                   rqURI     = uri,                   rqMethod  = PUT,-                  rqHeaders = Header HdrContentLength (show (BS.length body))+                  rqHeaders = Header HdrContentLength (show (LBS8.length body))                             : Header HdrAccept "text/plain"                             : headers,                   rqBody    = body@@ -783,7 +833,7 @@       case lookupHeader HdrContentType (rspHeaders resp) of         Just contenttype            | takeWhile (/= ';') contenttype == "text/plain"-          -> BS.unpack (rspBody resp)+          -> LBS8.unpack (rspBody resp)         _ -> rspReason resp      cabalBrowse verbosity auth act = do@@ -810,7 +860,7 @@ --  userAgent :: String-userAgent = concat [ "cabal-install/", showVersion Paths_cabal_install.version+userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion                    , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"                    ] @@ -829,17 +879,17 @@ -- Multipart stuff partially taken from cgi package. -- -generateMultipartBody :: FilePath -> IO (BS.ByteString, String)+generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) generateMultipartBody path = do-    content  <- BS.readFile path+    content  <- LBS.readFile path     boundary <- genBoundary-    let !body = formatBody content (BS.pack boundary)+    let !body = formatBody content (LBS8.pack boundary)     return (body, boundary)   where     formatBody content boundary =-        BS.concat $+        LBS8.concat $         [ crlf, dd, boundary, crlf ]-     ++ [ BS.pack (show header) | header <- headers ]+     ++ [ LBS8.pack (show header) | header <- headers ]      ++ [ crlf         , content         , crlf, dd, boundary, dd, crlf ]@@ -851,8 +901,8 @@       , Header HdrContentType "application/x-gzip"       ] -    crlf = BS.pack "\r\n"-    dd   = BS.pack "--"+    crlf = LBS8.pack "\r\n"+    dd   = LBS8.pack "--"  genBoundary :: IO String genBoundary = do
Distribution/Client/IndexUtils.hs view
@@ -26,17 +26,19 @@   getSourcePackages,   getSourcePackagesMonitorFiles, -  IndexState(..),+  TotalIndexState,   getSourcePackagesAtIndexState,+  ActiveRepos,+  filterSkippedActiveRepos,    Index(..),+  RepoIndexState (..),   PackageEntry(..),   parsePackageIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,   writeIndexTimestamp,   currentIndexTimestamp,-  readCacheStrict, -- only used by soon-to-be-obsolete sandbox code    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where@@ -48,11 +50,12 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar+import Distribution.Client.IndexUtils.ActiveRepos+import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types import Distribution.Verbosity-import Distribution.Pretty (prettyShow)-import Distribution.Parsec (simpleParsec)+import Distribution.Parsec (simpleParsecBS)  import Distribution.Package          ( PackageId, PackageIdentifier(..), mkPackageName@@ -68,10 +71,9 @@          ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure          ( getInstalledPackages, getInstalledPackagesMonitorFiles )+import Distribution.Types.PackageName (PackageName) import Distribution.Version-         ( Version, mkVersion, intersectVersionRanges )-import Distribution.Deprecated.Text-         ( display, simpleParse )+         ( Version, VersionRange, mkVersion, intersectVersionRanges ) import Distribution.Simple.Utils          ( die', warn, info, createDirectoryIfMissingVerbose ) import Distribution.Client.Setup@@ -87,8 +89,6 @@  import qualified Data.Map as Map import qualified Data.Set as Set-import Control.DeepSeq-import Control.Monad import Control.Exception import Data.List (stripPrefix) import qualified Data.ByteString.Lazy as BS@@ -99,7 +99,6 @@ import Distribution.Client.Utils ( byteStringToFilePath                                  , tryFindAddSourcePackageDesc ) import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)-import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath@@ -109,6 +108,7 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) import Distribution.Compat.Directory (listDirectory)+import Distribution.Utils.Generic (fstOf3)  import qualified Codec.Compression.GZip as GZip @@ -139,7 +139,6 @@     fn = case repo of            RepoSecure {}       -> "01-index"            RepoRemote {}       -> "00-index"-           RepoLocal  {}       -> "00-index"            RepoLocalNoIndex {} -> "noindex"  ------------------------------------------------------------------------@@ -176,7 +175,7 @@ -- resulting index cache. -- -- Note: 'filterCache' is idempotent in the 'Cache' value-filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo)+filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) filterCache IndexStateHead cache = (cache, IndexStateInfo{..})   where     isiMaxTime  = cacheHeadTs cache@@ -197,7 +196,7 @@ -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb getSourcePackages verbosity repoCtxt =-    getSourcePackagesAtIndexState verbosity repoCtxt Nothing+    fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing  -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'.@@ -205,37 +204,39 @@ -- Current choices are either the latest (aka HEAD), or the index as -- it was at a particular time. ----- TODO: Enhance to allow specifying per-repo 'IndexState's and also--- report back per-repo 'IndexStateInfo's (in order for @v2-freeze@--- to access it)-getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState-                           -> IO SourcePackageDb-getSourcePackagesAtIndexState verbosity repoCtxt _+-- Returns also the total index where repositories'+-- RepoIndexState's are not HEAD. This is used in v2-freeze.+--+getSourcePackagesAtIndexState+    :: Verbosity+    -> RepoContext+    -> Maybe TotalIndexState+    -> Maybe ActiveRepos+    -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)+getSourcePackagesAtIndexState verbosity repoCtxt _ _   | null (repoContextRepos repoCtxt) = do       -- In the test suite, we routinely don't have any remote package       -- servers, so don't bleat about it       warn (verboseUnmarkOutput verbosity) $         "No remote package servers have been specified. Usually " ++         "you would have one specified in the config file."-      return SourcePackageDb {+      return (SourcePackageDb {         packageIndex       = mempty,         packagePreferences = mempty-      }-getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do+      }, headTotalIndexState, ActiveRepos [])+getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do   let describeState IndexStateHead        = "most recent state"-      describeState (IndexStateTime time) = "historical state as of " ++ display time+      describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time -  pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do-      let rname =  case r of-              RepoRemote remote _      -> remoteRepoName remote-              RepoSecure remote _      -> remoteRepoName remote-              RepoLocalNoIndex local _ -> localRepoName local-              RepoLocal _              -> ""+  pkgss <- for (repoContextRepos repoCtxt) $ \r -> do+      let rname :: RepoName+          rname = repoName r -      info verbosity ("Reading available packages of " ++ rname ++ "...")+      info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")        idxState <- case mb_idxState of-        Just idxState -> do+        Just totalIdxState -> do+          let idxState = lookupIndexState rname totalIdxState           info verbosity $ "Using " ++ describeState idxState ++             " as explicitly requested (via command line / project configuration)"           return idxState@@ -252,9 +253,8 @@        unless (idxState == IndexStateHead) $           case r of-            RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")             RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"-            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")+            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")             RepoSecure {} -> pure ()        let idxState' = case r of@@ -265,44 +265,87 @@        case idxState' of         IndexStateHead -> do-            info verbosity ("index-state("++rname++") = " ++-                              display (isiHeadTime isi))+            info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))             return ()         IndexStateTime ts0 -> do             when (isiMaxTime isi /= ts0) $                 if ts0 > isiMaxTime isi                     then warn verbosity $-                                   "Requested index-state" ++ display ts0-                                ++ " is newer than '" ++ rname ++ "'!"+                                   "Requested index-state " ++ prettyShow ts0+                                ++ " is newer than '" ++ unRepoName rname ++ "'!"                                 ++ " Falling back to older state ("-                                ++ display (isiMaxTime isi) ++ ")."+                                ++ prettyShow (isiMaxTime isi) ++ ")."                     else info verbosity $-                                   "Requested index-state " ++ display ts0-                                ++ " does not exist in '"++rname++"'!"+                                   "Requested index-state " ++ prettyShow ts0+                                ++ " does not exist in '"++ unRepoName rname ++"'!"                                 ++ " Falling back to older state ("-                                ++ display (isiMaxTime isi) ++ ")."-            info verbosity ("index-state("++rname++") = " ++-                              display (isiMaxTime isi) ++ " (HEAD = " ++-                              display (isiHeadTime isi) ++ ")")+                                ++ prettyShow (isiMaxTime isi) ++ ")."+            info verbosity ("index-state("++ unRepoName rname ++") = " +++                              prettyShow (isiMaxTime isi) ++ " (HEAD = " +++                              prettyShow (isiHeadTime isi) ++ ")") -      pure (pis,deps)+      pure RepoData+          { rdRepoName    = rname+          , rdTimeStamp   = isiMaxTime isi+          , rdIndex       = pis+          , rdPreferences = deps+          } -  let (pkgs, prefs) = mconcat pkgss-      prefs' = Map.fromListWith intersectVersionRanges-                 [ (name, range) | Dependency name range _ <- prefs ]+  let activeRepos :: ActiveRepos+      activeRepos = fromMaybe defaultActiveRepos mb_activeRepos++  pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of+    Right x  -> return x+    Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)++  let activeRepos' :: ActiveRepos+      activeRepos' = ActiveRepos+          [ ActiveRepo (rdRepoName rd) strategy+          | (rd, strategy) <- pkgss'+          ]++  let totalIndexState :: TotalIndexState+      totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList+          [ (n, IndexStateTime ts)+          | (RepoData n ts _idx _prefs, _strategy) <- pkgss'+          -- e.g. file+noindex have nullTimestamp as their timestamp+          , ts /= nullTimestamp+          ]++  let addIndex+          :: PackageIndex UnresolvedSourcePackage+          -> (RepoData, CombineStrategy)+          -> PackageIndex UnresolvedSourcePackage+      addIndex acc (RepoData _ _ _   _, CombineStrategySkip)     = acc+      addIndex acc (RepoData _ _ idx _, CombineStrategyMerge)    = PackageIndex.merge acc idx+      addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx++  let pkgs :: PackageIndex UnresolvedSourcePackage+      pkgs = foldl' addIndex mempty pkgss'++  -- Note: preferences combined without using CombineStrategy+  let prefs :: Map PackageName VersionRange+      prefs = Map.fromListWith intersectVersionRanges+          [ (name, range)+          | (RepoData _n _ts _idx prefs', _strategy) <- pkgss'+          , Dependency name range _ <- prefs'+          ]+   _ <- evaluate pkgs-  _ <- evaluate prefs'-  return SourcePackageDb {+  _ <- evaluate prefs+  _ <- evaluate totalIndexState+  return (SourcePackageDb {     packageIndex       = pkgs,-    packagePreferences = prefs'-  }+    packagePreferences = prefs+  }, totalIndexState, activeRepos') -readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])-readCacheStrict verbosity index mkPkg = do-    updateRepoIndexCache verbosity index-    cache <- readIndexCache verbosity index-    withFile (indexFile index) ReadMode $ \indexHnd ->-      evaluate . force =<< packageListFromCache verbosity mkPkg indexHnd cache+-- auxiliary data used in getSourcePackagesAtIndexState+data RepoData = RepoData+    { rdRepoName    :: RepoName+    , rdTimeStamp   :: Timestamp+    , rdIndex       :: PackageIndex UnresolvedSourcePackage+    , rdPreferences :: [Dependency]+    }  -- | Read a repository index from disk, from the local file specified by -- the 'Repo'.@@ -311,7 +354,7 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState+readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState               -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState =   handleNotFound $ do@@ -322,18 +365,18 @@                               idxState    where-    mkAvailablePackage pkgEntry =-      SourcePackage {-        packageInfoId      = pkgid,-        packageDescription = packageDesc pkgEntry,-        packageSource      = case pkgEntry of+    mkAvailablePackage pkgEntry = SourcePackage+      { srcpkgPackageId   = pkgid+      , srcpkgDescription = pkgdesc+      , srcpkgSource      = case pkgEntry of           NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing-          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,-        packageDescrOverride = case pkgEntry of+          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path+      , srcpkgDescrOverride = case pkgEntry of           NormalPackage _ _ pkgtxt _ -> Just pkgtxt           _                          -> Nothing       }       where+        pkgdesc = packageDesc pkgEntry         pkgid = packageId pkgEntry      handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e@@ -341,12 +384,9 @@         case repo of           RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote           RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote-          RepoLocal{..}  -> warn verbosity $-               "The package list for the local repo '" ++ repoLocalDir-            ++ "' is missing. The repo is invalid."           RepoLocalNoIndex local _ -> warn verbosity $               "Error during construction of local+noindex "-              ++ localRepoName local ++ " repository index: "+              ++ unRepoName (localRepoName local) ++ " repository index: "               ++ show e         return (mempty,mempty,emptyStateInfo)       else ioError e@@ -356,14 +396,13 @@       when (dt >= isOldThreshold) $ case repo of         RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt         RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt-        RepoLocal{} -> return ()         RepoLocalNoIndex {} -> return ()      errMissingPackageList repoRemote =-         "The package list for '" ++ remoteRepoName repoRemote+         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)       ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote     errOutdatedPackageList repoRemote dt =-         "The package list for '" ++ remoteRepoName repoRemote+         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)       ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "       ++ "'cabal update' to get the latest list of available packages." @@ -408,8 +447,8 @@ --  -- | An index entry is either a normal package, or a local build tree reference.-data PackageEntry =-  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo+data PackageEntry+  = NormalPackage  PackageId GenericPackageDescription ByteString BlockNo   | BuildTreeRef BuildTreeRefType                  PackageId GenericPackageDescription FilePath   BlockNo @@ -484,7 +523,7 @@   Tar.NormalFile content _      | takeExtension fileName == ".cabal"     -> case splitDirectories (normalise fileName) of-        [pkgname,vers,_] -> case simpleParse vers of+        [pkgname,vers,_] -> case simpleParsec vers of           Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (mkPackageName pkgname) ver@@ -525,7 +564,7 @@   _ -> Nothing  parsePreferredVersions :: ByteString -> [Dependency]-parsePreferredVersions = mapMaybe simpleParse+parsePreferredVersions = mapMaybe simpleParsec                        . filter (not . isPrefixOf "--")                        . lines                        . BS.Char8.unpack -- TODO: Are we sure no unicode?@@ -586,7 +625,6 @@ is01Index (RepoIndex _ repo) = case repo of                                  RepoSecure {} -> True                                  RepoRemote {} -> False-                                 RepoLocal  {} -> False                                  RepoLocalNoIndex {} -> True is01Index (SandboxIndex _)   = False @@ -603,7 +641,7 @@                           }         writeIndexCache index cache         info verbosity ("Index cache updated to index-state "-                        ++ display (cacheHeadTs cache))+                        ++ prettyShow (cacheHeadTs cache))      callbackNoIndex entries = do         writeNoIndexCache verbosity index $ NoIndexCache entries@@ -634,7 +672,7 @@     -> ([IndexCacheEntry] -> IO a)     -> ([NoIndexCacheEntry] -> IO a)     -> IO a-withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback _ =+withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =     repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->       Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do         -- Incrementally (lazily) read all the entries in the tar file in order,@@ -665,7 +703,7 @@     dirContents <- listDirectory localDir     let contentSet = Set.fromList dirContents -    entries <- handle handler $ fmap catMaybes $ forM dirContents $ \file -> do+    entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do         case isTarGz file of             Nothing -> do                 unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $@@ -673,7 +711,7 @@                 return Nothing             Just pkgid | cabalPath `Set.member` contentSet -> do                 contents <- BSS.readFile (localDir </> cabalPath)-                forM (parseGenericPackageDescriptionMaybe contents) $ \gpd ->+                for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->                     return (CacheGPD gpd contents)               where                 cabalPath = prettyShow pkgid ++ ".cabal"@@ -687,14 +725,14 @@                     Just ce -> return (Just ce)                     Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file -    info verbosity $ "Entries in file+noindex repository " ++ name+    info verbosity $ "Entries in file+noindex repository " ++ unRepoName name     for_ entries $ \(CacheGPD gpd _) ->         info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)      callback entries   where     handler :: IOException -> IO a-    handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e+    handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e      isTarGz :: FilePath -> Maybe PackageIdentifier     isTarGz fp = do@@ -729,7 +767,7 @@                           => Verbosity                           -> (PackageEntry -> pkg)                           -> Index-                          -> IndexState+                          -> RepoIndexState                           -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) readPackageIndexCacheFile verbosity mkPkg index idxState     | localNoIndex index = do@@ -835,10 +873,10 @@         dummyPackageDescription :: Version -> GenericPackageDescription         dummyPackageDescription specVer = GenericPackageDescription             { packageDescription = emptyPackageDescription-                                   { specVersionRaw = Left specVer-                                   , package        = pkgid-                                   , synopsis       = dummySynopsis+                                   { package     = pkgid+                                   , synopsis    = dummySynopsis                                    }+            , gpdScannedVersion = Just specVer -- tells index scanner to skip this file.             , genPackageFlags  = []             , condLibrary      = Nothing             , condSubLibraries = []@@ -922,9 +960,9 @@     structuredEncodeFile path cache  -- | Write the 'IndexState' to the filesystem-writeIndexTimestamp :: Index -> IndexState -> IO ()+writeIndexTimestamp :: Index -> RepoIndexState -> IO () writeIndexTimestamp index st-  = writeFile (timestampFile index) (display st)+  = writeFile (timestampFile index) (prettyShow st)  -- | Read out the "current" index timestamp, i.e., what -- timestamp you would use to revert to this version@@ -938,9 +976,9 @@         return (isiHeadTime isi)  -- | Read the 'IndexState' from the filesystem-readIndexTimestamp :: Index -> IO (Maybe IndexState)+readIndexTimestamp :: Index -> IO (Maybe RepoIndexState) readIndexTimestamp index-  = fmap simpleParse (readFile (timestampFile index))+  = fmap simpleParsec (readFile (timestampFile index))         `catchIO` \e ->             if isDoesNotExistError e                 then return Nothing@@ -1087,7 +1125,7 @@         _ -> Nothing      (key: remainder) | key == BSS.pack preferredVersionKey -> do-      pref <- simpleParse (BSS.unpack (BSS.unwords remainder))+      pref <- simpleParsecBS (BSS.unwords remainder)       return $ CachePreference pref 0 nullTimestamp      _  -> Nothing@@ -1126,8 +1164,8 @@ show00IndexCacheEntry entry = unwords $ case entry of     CachePackageId pkgid b _ ->         [ packageKey-        , display (packageName pkgid)-        , display (packageVersion pkgid)+        , prettyShow (packageName pkgid)+        , prettyShow (packageVersion pkgid)         , blocknoKey         , show b         ]@@ -1138,5 +1176,5 @@         ]     CachePreference dep _ _  ->         [ preferredVersionKey-        , display dep+        , prettyShow dep         ]
+ Distribution/Client/IndexUtils/ActiveRepos.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Client.IndexUtils.ActiveRepos (+    ActiveRepos (..),+    defaultActiveRepos,+    filterSkippedActiveRepos,+    ActiveRepoEntry (..),+    CombineStrategy (..),+    organizeByRepos,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Client.Types.RepoName (RepoName (..))+import Prelude ()++import Distribution.Parsec (parsecLeadingCommaNonEmpty)++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++-- | Ordered list of active repositories.+newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]+  deriving (Eq, Show, Generic)++defaultActiveRepos :: ActiveRepos+defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]++-- | Note, this does nothing if 'ActiveRepoRest' is present.+filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos+filterSkippedActiveRepos repos@(ActiveRepos entries)+    | any isActiveRepoRest entries = repos+    | otherwise                    = ActiveRepos (filter notSkipped entries)+  where+    isActiveRepoRest (ActiveRepoRest _) = True+    isActiveRepoRest _                  = False++    notSkipped (ActiveRepo _ CombineStrategySkip) = False+    notSkipped _                                  = True++instance Binary ActiveRepos+instance Structured ActiveRepos+instance NFData ActiveRepos++instance Pretty ActiveRepos where+    pretty (ActiveRepos [])+        = Disp.text ":none"+    pretty (ActiveRepos repos)+        = Disp.hsep+        $ Disp.punctuate Disp.comma+        $ map pretty repos++-- | Note: empty string is not valid 'ActiveRepos'.+--+-- >>> simpleParsec "" :: Maybe ActiveRepos+-- Nothing+--+-- >>> simpleParsec ":none" :: Maybe ActiveRepos+-- Just (ActiveRepos [])+--+-- >>> simpleParsec ":rest" :: Maybe ActiveRepos+-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])+--+-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos+-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])+--+instance Parsec ActiveRepos where+    parsec = ActiveRepos [] <$ P.try (P.string ":none")+        <|> do+            repos <- parsecLeadingCommaNonEmpty parsec+            return (ActiveRepos (toList repos))++data ActiveRepoEntry+    = ActiveRepoRest CombineStrategy        -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'+    | ActiveRepo RepoName CombineStrategy   -- ^ explicit repository name+  deriving (Eq, Show, Generic)++instance Binary ActiveRepoEntry+instance Structured ActiveRepoEntry+instance NFData ActiveRepoEntry++instance Pretty ActiveRepoEntry where+    pretty (ActiveRepoRest s) =+        Disp.text ":rest" <<>> Disp.colon <<>> pretty s+    pretty (ActiveRepo r s) =+        pretty r <<>> Disp.colon <<>> pretty s++instance Parsec ActiveRepoEntry where+    parsec = leadColon <|> leadRepo where+        leadColon = do+            _ <- P.char ':'+            token <- P.munch1 isAlpha+            case token of+                "rest" -> ActiveRepoRest <$> strategyP+                "repo" -> P.char ':' *> leadRepo+                _      -> P.unexpected $ "Unknown active repository entry type: " ++ token++        leadRepo = do+            r <- parsec+            s <- strategyP+            return (ActiveRepo r s)++        strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)++data CombineStrategy+    = CombineStrategySkip     -- ^ skip this repository+    | CombineStrategyMerge    -- ^ merge existing versions+    | CombineStrategyOverride -- ^ if later repository specifies a package,+                              --   all package versions are replaced+  deriving (Eq, Show, Enum, Bounded, Generic)++instance Binary CombineStrategy+instance Structured CombineStrategy+instance NFData CombineStrategy++instance Pretty CombineStrategy where+    pretty CombineStrategySkip     = Disp.text "skip"+    pretty CombineStrategyMerge    = Disp.text "merge"+    pretty CombineStrategyOverride = Disp.text "override"++instance Parsec CombineStrategy where+    parsec = P.choice+        [ CombineStrategySkip     <$ P.string "skip"+        , CombineStrategyMerge    <$ P.string "merge"+        , CombineStrategyOverride <$ P.string "override"+        ]++-------------------------------------------------------------------------------+-- Organisation+-------------------------------------------------------------------------------++-- | Sort values 'RepoName' according to 'ActiveRepos' list.+--+-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos+-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos+-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos+-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos+-- Left "no repository provided d"+--+-- Note: currently if 'ActiveRepoRest' is provided more than once,+-- rest-repositories will be multiple times in the output.+--+organizeByRepos+    :: forall a. ActiveRepos+    -> (a -> RepoName)+    -> [a]+    -> Either String [(a, CombineStrategy)]+organizeByRepos (ActiveRepos xs0) sel ys0 =+    -- here we use lazyness to do only one traversal+    let (rest, result) = case go rest xs0 ys0 of+            Right (rest', result') -> (rest', Right result')+            Left err               -> ([],    Left err)+    in result+  where+    go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])+    go _rest []                      ys = Right (ys, [])+    go  rest (ActiveRepoRest s : xs) ys =+        go rest xs ys <&> \(rest', result) ->+           (rest', map (\x -> (x, s)) rest ++ result)+    go  rest (ActiveRepo r s : xs)   ys = do+        (z, zs) <- extract r ys+        go rest xs zs <&> \(rest', result) ->+            (rest', (z, s) : result)++    extract :: RepoName -> [a] -> Either String (a, [a])+    extract r = loop id where+        loop _acc []     = Left $ "no repository provided " ++ prettyShow r+        loop  acc (x:xs)+            | sel x == r = Right (x, acc xs)+            | otherwise  = loop (acc . (x :)) xs++    (<&>)+        :: Either err ([s], b)+        -> (([s], b) -> ([s], c))+        -> Either err ([s], c)+    (<&>) = flip fmap
+ Distribution/Client/IndexUtils/IndexState.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils.IndexUtils+-- Copyright   :  (c) 2016 Herbert Valerio Riedel+-- License     :  BSD3+--+-- Package repositories index state.+--+module Distribution.Client.IndexUtils.IndexState (+    RepoIndexState(..),+    TotalIndexState,+    headTotalIndexState,+    makeTotalIndexState,+    lookupIndexState,+    insertIndexState,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Client.IndexUtils.Timestamp (Timestamp)+import Distribution.Client.Types.RepoName       (RepoName (..))++import Distribution.Parsec (parsecLeadingCommaNonEmpty)++import qualified Data.Map.Strict                 as Map+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-------------------------------------------------------------------------------+-- Total index state+-------------------------------------------------------------------------------++-- | Index state of multiple repositories+data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)+  deriving (Eq, Show, Generic)++instance Binary TotalIndexState+instance Structured TotalIndexState+instance NFData TotalIndexState++instance Pretty TotalIndexState where+    pretty (TIS IndexStateHead m)+        | not (Map.null m)+        = Disp.hsep $ Disp.punctuate Disp.comma+            [ pretty rn Disp.<+> pretty idx+            | (rn, idx) <- Map.toList m+            ]+    pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where+        go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx++-- |+--+-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList []))+--+-- >>> simpleParsec "" :: Maybe TotalIndexState+-- Nothing+--+-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList []))+--+-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState+-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)]))+--+-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))+--+instance Parsec TotalIndexState where+    parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where+        single0 = startsWithRepoName <|> TokTimestamp <$> parsec+        startsWithRepoName = do+            reponame <- parsec+            -- the "HEAD" is technically a valid reponame...+            if reponame == RepoName "HEAD"+            then return TokHead+            else do+                P.spaces+                TokRepo reponame <$> parsec++        add :: TotalIndexState -> Tok -> TotalIndexState+        add _           TokHead           = headTotalIndexState+        add _           (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty+        add (TIS def m) (TokRepo rn idx)  = TIS def (Map.insert rn idx m)++-- used in Parsec TotalIndexState implementation+data Tok+    = TokRepo RepoName RepoIndexState+    | TokTimestamp Timestamp+    | TokHead++-- | Remove non-default values from 'TotalIndexState'.+normalise :: TotalIndexState -> TotalIndexState+normalise (TIS def m) = TIS def (Map.filter (/= def) m)++-- | 'TotalIndexState' where all repositories are at @HEAD@ index state.+headTotalIndexState :: TotalIndexState+headTotalIndexState = TIS IndexStateHead Map.empty++-- | Create 'TotalIndexState'.+makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState+makeTotalIndexState def m = normalise (TIS def m)++-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.+lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState+lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m++-- | Insert a 'RepoIndexState' to 'TotalIndexState'.+insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState+insertIndexState rn idx (TIS def m)+    | idx == def = TIS def (Map.delete rn m)+    | otherwise  = TIS def (Map.insert rn idx m)++-------------------------------------------------------------------------------+-- Repository index state+-------------------------------------------------------------------------------++-- | Specification of the state of a specific repo package index+data RepoIndexState+    = IndexStateHead -- ^ Use all available entries+    | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time+    deriving (Eq,Generic,Show)++instance Binary RepoIndexState+instance Structured RepoIndexState+instance NFData RepoIndexState++instance Pretty RepoIndexState where+    pretty IndexStateHead = Disp.text "HEAD"+    pretty (IndexStateTime ts) = pretty ts++instance Parsec RepoIndexState where+    parsec = parseHead <|> parseTime where+        parseHead = IndexStateHead <$ P.string "HEAD"+        parseTime = IndexStateTime <$> parsec
Distribution/Client/IndexUtils/Timestamp.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}  ----------------------------------------------------------------------------- -- |@@ -17,8 +18,6 @@     , timestampToUTCTime     , utcTimeToTimestamp     , maximumTimestamp--    , IndexState(..)     ) where  import Distribution.Client.Compat.Prelude@@ -26,16 +25,13 @@ -- read is needed for Text instance import Prelude (read) -import qualified Codec.Archive.Tar.Entry    as Tar-import           Data.Time                  (UTCTime (..), fromGregorianValid,-                                             makeTimeOfDayValid, showGregorian,-                                             timeOfDayToTime, timeToTimeOfDay)-import           Data.Time.Clock.POSIX      (posixSecondsToUTCTime,-                                             utcTimeToPOSIXSeconds)-import qualified Distribution.Deprecated.ReadP  as ReadP-import           Distribution.Deprecated.Text-import qualified Text.PrettyPrint           as Disp+import Data.Time             (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import qualified Codec.Archive.Tar.Entry         as Tar+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp+ -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime                   deriving (Eq,Ord,Enum,NFData,Show,Generic)@@ -100,16 +96,18 @@ instance Binary Timestamp instance Structured Timestamp -instance Text Timestamp where-    disp = Disp.text . showTimestamp+instance Pretty Timestamp where+    pretty = Disp.text . showTimestamp -    parse = parsePosix ReadP.+++ parseUTC+instance Parsec Timestamp where+    parsec = parsePosix <|> parseUTC       where         -- | Parses unix timestamps, e.g. @"\@1474626019"@         parsePosix = do-            _ <- ReadP.char '@'-            t <- parseInteger-            maybe ReadP.pfail return $ posixSecondsToTimestamp t+            _ <- P.char '@'+            t <- P.integral -- note, no negative timestamps+            maybe (fail (show t ++ " is not representable as timestamp")) return $+                posixSecondsToTimestamp t          -- | Parses ISO8601/RFC3339-style UTC timestamps,         -- e.g. @"2017-12-31T23:59:59Z"@@@ -120,72 +118,44 @@             -- we want more control over the accepted formats.              ye <- parseYear-            _ <- ReadP.char '-'+            _ <- P.char '-'             mo   <- parseTwoDigits-            _ <- ReadP.char '-'+            _ <- P.char '-'             da   <- parseTwoDigits-            _ <- ReadP.char 'T'+            _ <- P.char 'T' -            utctDay <- maybe ReadP.pfail return $+            utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $                        fromGregorianValid ye mo da              ho   <- parseTwoDigits-            _ <- ReadP.char ':'+            _ <- P.char ':'             mi   <- parseTwoDigits-            _ <- ReadP.char ':'+            _ <- P.char ':'             se   <- parseTwoDigits-            _ <- ReadP.char 'Z'+            _ <- P.char 'Z' -            utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $+            utctDayTime <- maybe (fail (show (ho,mi,se) ++  " is not valid time of day")) (return . timeOfDayToTime) $                            makeTimeOfDayValid ho mi (realToFrac (se::Int)) -            maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})+            let utc = UTCTime {..} +            maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc+         parseTwoDigits = do-            d1 <- ReadP.satisfy isDigit-            d2 <- ReadP.satisfy isDigit+            d1 <- P.satisfy isDigit+            d2 <- P.satisfy isDigit             return (read [d1,d2])          -- A year must have at least 4 digits; e.g. "0097" is fine,         -- while "97" is not c.f. RFC3339 which         -- deprecates 2-digit years         parseYear = do-            sign <- ReadP.option ' ' (ReadP.char '-')-            ds <- ReadP.munch1 isDigit-            when (length ds < 4) ReadP.pfail+            sign <- P.option ' ' (P.char '-')+            ds <- P.munch1 isDigit+            when (length ds < 4) $ fail "Year should have at least 4 digits"             return (read (sign:ds)) -        parseInteger = do-            sign <- ReadP.option ' ' (ReadP.char '-')-            ds <- ReadP.munch1 isDigit-            return (read (sign:ds) :: Integer)- -- | Special timestamp value to be used when 'timestamp' is -- missing/unknown/invalid nullTimestamp :: Timestamp nullTimestamp = TS minBound--------------------------------------------------------------------------------- defined here for now to avoid import cycles---- | Specification of the state of a specific repo package index-data IndexState = IndexStateHead -- ^ Use all available entries-                | IndexStateTime !Timestamp -- ^ Use all entries that existed at-                                            -- the specified time-                deriving (Eq,Generic,Show)--instance Binary IndexState-instance Structured IndexState-instance NFData IndexState--instance Text IndexState where-    disp IndexStateHead = Disp.text "HEAD"-    disp (IndexStateTime ts) = disp ts--    parse = parseHead ReadP.+++ parseTime-      where-        parseHead = do-            _ <- ReadP.string "HEAD"-            return IndexStateHead--        parseTime = IndexStateTime `fmap` parse
Distribution/Client/Init.hs view
@@ -21,1293 +21,5 @@    ) where -import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import Distribution.Deprecated.ReadP (readP_to_E)--import System.IO-  ( hSetBuffering, stdout, BufferMode(..) )-import System.Directory-  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile-  , getDirectoryContents, createDirectoryIfMissing )-import System.FilePath-  ( (</>), (<.>), takeBaseName, takeExtension, equalFilePath )-import Data.Time-  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )--import Data.List-  ( (\\) )-import qualified Data.List.NonEmpty as NE-import Data.Function-  ( on )-import qualified Data.Map as M-import qualified Data.Set as Set-import Control.Monad-  ( (>=>), join, forM_, mapM, mapM_ )-import Control.Arrow-  ( (&&&), (***) )--import Text.PrettyPrint hiding (mode, cat)--import Distribution.Version-  ( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion-  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )-import Distribution.Verbosity-  ( Verbosity )-import Distribution.ModuleName-  ( ModuleName )  -- And for the Text instance-import qualified Distribution.ModuleName as ModuleName-  ( fromString, toFilePath )-import Distribution.InstalledPackageInfo-  ( InstalledPackageInfo, exposed )-import qualified Distribution.Package as P-import Distribution.Types.LibraryName-  ( LibraryName(..) )-import Language.Haskell.Extension ( Language(..) )--import Distribution.Client.Init.Types-  ( InitFlags(..), BuildType(..), PackageType(..), Category(..)-  , displayPackageType )-import Distribution.Client.Init.Licenses-  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )-import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,-    SourceFileEntry(..),-    scanForModules, neededBuildPrograms )--import Distribution.License-  ( License(..), knownLicenses, licenseToSPDX )-import qualified Distribution.SPDX as SPDX--import Distribution.ReadE-  ( runReadE )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Simple.Utils-  ( dropWhileEndLE )-import Distribution.Simple.Configure-  ( getInstalledPackages )-import Distribution.Simple.Compiler-  ( PackageDBStack, Compiler )-import Distribution.Simple.Program-  ( ProgramDb )-import Distribution.Simple.PackageIndex-  ( InstalledPackageIndex, moduleNameIndex )-import Distribution.Deprecated.Text-  ( display, Text(..) )-import Distribution.Pretty-  ( prettyShow )-import Distribution.Parsec-  ( eitherParsec )--import Distribution.Solver.Types.PackageIndex-  ( elemByPackageName )--import Distribution.Client.IndexUtils-  ( getSourcePackages )-import Distribution.Client.Types-  ( SourcePackageDb(..) )-import Distribution.Client.Setup-  ( RepoContext(..) )--initCabal :: Verbosity-          -> PackageDBStack-          -> RepoContext-          -> Compiler-          -> ProgramDb-          -> InitFlags-          -> IO ()-initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do--  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-  sourcePkgDb <- getSourcePackages verbosity repoCtxt--  hSetBuffering stdout NoBuffering--  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags--  case license initFlags' of-    Flag PublicDomain -> return ()-    _                 -> writeLicense initFlags'-  writeSetupFile initFlags'-  writeChangeLog initFlags'-  createDirectories (sourceDirs initFlags')-  createLibHs initFlags'-  createDirectories (applicationDirs initFlags')-  createMainHs initFlags'-  -- If a test suite was requested and this is not an executable-only-  -- package, then create the "test" directory.-  when (eligibleForTestSuite initFlags') $ do-    createDirectories (testDirs initFlags')-    createTestHs initFlags'-  success <- writeCabalFile initFlags'--  when success $ generateWarnings initFlags'--------------------------------------------------------------------------------  Flag acquisition  ------------------------------------------------------------------------------------------------------------------------------------- | Fill in more details by guessing, discovering, or prompting the---   user.-extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags-extendFlags pkgIx sourcePkgDb =-      getSimpleProject-  >=> getLibOrExec-  >=> getCabalVersion-  >=> getPackageName sourcePkgDb-  >=> getVersion-  >=> getLicense-  >=> getAuthorInfo-  >=> getHomepage-  >=> getSynopsis-  >=> getCategory-  >=> getExtraSourceFiles-  >=> getAppDir-  >=> getSrcDir-  >=> getGenTests-  >=> getTestDir-  >=> getLanguage-  >=> getGenComments-  >=> getModulesBuildToolsAndDeps pkgIx---- | Combine two actions which may return a value, preferring the first. That---   is, run the second action only if the first doesn't return a value.-infixr 1 ?>>-(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)-f ?>> g = do-  ma <- f-  if isJust ma-    then return ma-    else g---- | Witness the isomorphism between Maybe and Flag.-maybeToFlag :: Maybe a -> Flag a-maybeToFlag = maybe NoFlag Flag--defaultCabalVersion :: Version-defaultCabalVersion = mkVersion [1,10]--displayCabalVersion :: Version -> String-displayCabalVersion v = case versionNumbers v of-  [1,10] -> "1.10   (legacy)"-  [2,0]  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"-  [2,2]  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"-  [2,4]  -> "2.4    (+ support for '**' globbing)"-  _      -> display v---- | Ask if a simple project with sensible defaults should be created.-getSimpleProject :: InitFlags -> IO InitFlags-getSimpleProject flags = do-  simpleProj <-     return (flagToMaybe $ simpleProject flags)-                ?>> maybePrompt flags-                    (promptYesNo-                      "Should I generate a simple project with sensible defaults"-                      (Just True))-  return $ case maybeToFlag simpleProj of-    Flag True ->-      flags { interactive = Flag False-            , simpleProject = Flag True-            , packageType = Flag LibraryAndExecutable-            , cabalVersion = Flag (mkVersion [2,4])-            }-    simpleProjFlag@_ ->-      flags { simpleProject = simpleProjFlag }----- | Ask which version of the cabal spec to use.-getCabalVersion :: InitFlags -> IO InitFlags-getCabalVersion flags = do-  cabVer <-     return (flagToMaybe $ cabalVersion flags)-            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`-                                  promptList "Please choose version of the Cabal specification to use"-                                  [mkVersion [1,10], mkVersion [2,0], mkVersion [2,2], mkVersion [2,4]]-                                  (Just defaultCabalVersion) displayCabalVersion False)-            ?>> return (Just defaultCabalVersion)--  return $  flags { cabalVersion = maybeToFlag cabVer }----- | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess. It looks at the SourcePackageDb to avoid---   using an existing package name.-getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags-getPackageName sourcePkgDb flags = do-  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)-              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)--  let guess' | isPkgRegistered guess = Nothing-             | otherwise = guess--  pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (prompt "Package name" guess')-              ?>> return guess'--  chooseAgain <- if isPkgRegistered pkgName'-                    then promptYesNo promptOtherNameMsg (Just True)-                    else return False--  if chooseAgain-    then getPackageName sourcePkgDb flags-    else return $ flags { packageName = maybeToFlag pkgName' }--  where-    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg-    isPkgRegistered Nothing    = False--    promptOtherNameMsg = "This package name is already used by another " ++-                         "package on hackage. Do you want to choose a " ++-                         "different name"---- | Package version: use 0.1.0.0 as a last resort, but try prompting the user---  if possible.-getVersion :: InitFlags -> IO InitFlags-getVersion flags = do-  let v = Just $ mkVersion [0,1,0,0]-  v' <-     return (flagToMaybe $ version flags)-        ?>> maybePrompt flags (prompt "Package version" v)-        ?>> return v-  return $ flags { version = maybeToFlag v' }---- | Choose a license.-getLicense :: InitFlags -> IO InitFlags-getLicense flags = do-  lic <-     return (flagToMaybe $ license flags)-         ?>> fmap (fmap (either UnknownLicense id))-                  (maybePrompt flags-                    (promptList "Please choose a license" listedLicenses-                     (Just BSD3) displayLicense True))--  case checkLicenseInvalid lic of-    Just msg -> putStrLn msg >> getLicense flags-    Nothing  -> return $ flags { license = maybeToFlag lic }--  where-    displayLicense l | needSpdx  = prettyShow (licenseToSPDX l)-                     | otherwise = display l--    checkLicenseInvalid (Just (UnknownLicense t))-      | needSpdx  = case eitherParsec t :: Either String SPDX.License of-                      Right _ -> Nothing-                      Left _  -> Just "\nThe license must be a valid SPDX expression."-      | otherwise = if any (not . isAlphaNum) t-                    then Just promptInvalidOtherLicenseMsg-                    else Nothing-    checkLicenseInvalid _ = Nothing--    promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++-                                   "If your license name has many words, " ++-                                   "the convention is to use camel case (e.g. PublicDomain). " ++-                                   "Please choose a different license."--    listedLicenses =-      knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing-                       , Apache Nothing, OtherLicense]--    needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags)---- | The author's name and email. Prompt, or try to guess from an existing---   darcs repo.-getAuthorInfo :: InitFlags -> IO InitFlags-getAuthorInfo flags = do-  (authorName, authorEmail)  <--    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail-  authorName'  <-     return (flagToMaybe $ author flags)-                  ?>> maybePrompt flags (promptStr "Author name" authorName)-                  ?>> return authorName--  authorEmail' <-     return (flagToMaybe $ email flags)-                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)-                  ?>> return authorEmail--  return $ flags { author = maybeToFlag authorName'-                 , email  = maybeToFlag authorEmail'-                 }---- | Prompt for a homepage URL.-getHomepage :: InitFlags -> IO InitFlags-getHomepage flags = do-  hp  <- queryHomepage-  hp' <-     return (flagToMaybe $ homepage flags)-         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)-         ?>> return hp--  return $ flags { homepage = maybeToFlag hp' }---- | Right now this does nothing, but it could be changed to do some---   intelligent guessing.-queryHomepage :: IO (Maybe String)-queryHomepage = return Nothing     -- get default remote darcs repo?---- | Prompt for a project synopsis.-getSynopsis :: InitFlags -> IO InitFlags-getSynopsis flags = do-  syn <-     return (flagToMaybe $ synopsis flags)-         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)--  return $ flags { synopsis = maybeToFlag syn }---- | Prompt for a package category.---   Note that it should be possible to do some smarter guessing here too, i.e.---   look at the name of the top level source directory.-getCategory :: InitFlags -> IO InitFlags-getCategory flags = do-  cat <-     return (flagToMaybe $ category flags)-         ?>> fmap join (maybePrompt flags-                         (promptListOptional "Project category" [Codec ..]))-  return $ flags { category = maybeToFlag cat }---- | Try to guess extra source files (don't prompt the user).-getExtraSourceFiles :: InitFlags -> IO InitFlags-getExtraSourceFiles flags = do-  extraSrcFiles <-     return (extraSrc flags)-                   ?>> Just `fmap` guessExtraSourceFiles flags--  return $ flags { extraSrc = extraSrcFiles }--defaultChangeLog :: FilePath-defaultChangeLog = "CHANGELOG.md"---- | Try to guess things to include in the extra-source-files field.---   For now, we just look for things in the root directory named---   'readme', 'changes', or 'changelog', with any sort of---   capitalization and any extension.-guessExtraSourceFiles :: InitFlags -> IO [FilePath]-guessExtraSourceFiles flags = do-  dir <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  files <- getDirectoryContents dir-  let extraFiles = filter isExtra files-  if any isLikeChangeLog extraFiles-    then return extraFiles-    else return (defaultChangeLog : extraFiles)--  where-    isExtra = likeFileNameBase ("README" : changeLogLikeBases)-    isLikeChangeLog = likeFileNameBase changeLogLikeBases-    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName-    changeLogLikeBases = ["CHANGES", "CHANGELOG"]---- | Ask whether the project builds a library or executable.-getLibOrExec :: InitFlags -> IO InitFlags-getLibOrExec flags = do-  pkgType <-     return (flagToMaybe $ packageType flags)-           ?>> maybePrompt flags (either (const Executable) id `fmap`-                                   promptList "What does the package build"-                                   [Executable, Library, LibraryAndExecutable]-                                   Nothing displayPackageType False)-           ?>> return (Just Executable)--  -- If this package contains an executable, get the main file name.-  mainFile <- if pkgType == Just Library then return Nothing else-                    getMainFile flags--  return $ flags { packageType = maybeToFlag pkgType-                 , mainIs = maybeToFlag mainFile-                 }----- | Try to guess the main file of the executable, and prompt the user to choose--- one of them. Top-level modules including the word 'Main' in the file name--- will be candidates, and shorter filenames will be preferred.-getMainFile :: InitFlags -> IO (Maybe FilePath)-getMainFile flags =-  return (flagToMaybe $ mainIs flags)-  ?>> do-    candidates <- guessMainFileCandidates flags-    let showCandidate = either (++" (does not yet exist, but will be created)") id-        defaultFile = listToMaybe candidates-    maybePrompt flags (either id (either id id) `fmap`-                       promptList "What is the main module of the executable"-                       candidates-                       defaultFile showCandidate True)-      ?>> return (fmap (either id id) defaultFile)---- | Ask if a test suite should be generated for the library.-getGenTests :: InitFlags -> IO InitFlags-getGenTests flags = do-  genTests <-     return (flagToMaybe $ initializeTestSuite flags)-                  -- Only generate a test suite if the package contains a library.-              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing-              ?>> maybePrompt flags-                  (promptYesNo-                    "Should I generate a test suite for the library"-                    (Just True))-  return $ flags { initializeTestSuite = maybeToFlag genTests }---- | Ask for the test root directory.-getTestDir :: InitFlags -> IO InitFlags-getTestDir flags = do-  dirs <- return (testDirs flags)-              -- Only need testDirs when test suite generation is enabled.-          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing-          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt-                   flags-                   (promptList "Test directory" ["test"] (Just "test") id True))--  return $ flags { testDirs = dirs }---- | Ask for the base language of the package.-getLanguage :: InitFlags -> IO InitFlags-getLanguage flags = do-  lang <-     return (flagToMaybe $ language flags)-          ?>> maybePrompt flags-                (either UnknownLanguage id `fmap`-                  promptList "What base language is the package written in"-                  [Haskell2010, Haskell98]-                  (Just Haskell2010) display True)-          ?>> return (Just Haskell2010)--  if invalidLanguage lang-    then putStrLn invalidOtherLanguageMsg >> getLanguage flags-    else return $ flags { language = maybeToFlag lang }--  where-    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t-    invalidLanguage _ = False--    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++-                              "Please enter a different language."---- | Ask whether to generate explanatory comments.-getGenComments :: InitFlags -> IO InitFlags-getGenComments flags = do-  genComments <-     return (not <$> flagToMaybe (noComments flags))-                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))-                 ?>> return (Just False)-  return $ flags { noComments = maybeToFlag (fmap not genComments) }-  where-    promptMsg = "Add informative comments to each field in the cabal file (y/n)"---- | Ask for the application root directory.-getAppDir :: InitFlags -> IO InitFlags-getAppDir flags = do-  appDirs <- return (applicationDirs flags)-             -- No application dir if this is a 'Library'.-             ?>> if (packageType flags) == Flag Library then return (Just []) else return Nothing-             ?>> fmap (:[]) `fmap` guessAppDir flags-             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt-                      flags-                      (promptListOptional'-                       ("Application " ++ mainFile ++ "directory")-                       ["src-exe", "app"] id))--  return $ flags { applicationDirs = appDirs }--  where-    mainFile = case mainIs flags of-      Flag mainPath -> "(" ++ mainPath ++ ") "-      _             -> ""---- | Try to guess app directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'app'.-guessAppDir :: InitFlags -> IO (Maybe String)-guessAppDir flags = do-  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  appIsDir <- doesDirectoryExist (dir </> "app")-  return $ if appIsDir-             then Just "app"-             else Nothing---- | Ask for the source (library) root directory.-getSrcDir :: InitFlags -> IO InitFlags-getSrcDir flags = do-  srcDirs <- return (sourceDirs flags)-             -- source dir if this is an 'Executable'.-             ?>> if (packageType flags) == Flag Executable then return (Just []) else return Nothing-             ?>> fmap (:[]) `fmap` guessSourceDir flags-             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt-                      flags-                      (promptListOptional' "Library source directory"-                       ["src", "lib", "src-lib"] id))--  return $ flags { sourceDirs = srcDirs }---- | Try to guess source directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'src'.-guessSourceDir :: InitFlags -> IO (Maybe String)-guessSourceDir flags = do-  dir      <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  srcIsDir <- doesDirectoryExist (dir </> "src")-  return $ if srcIsDir-             then Just "src"-             else Nothing---- | Check whether a potential source file is located in one of the---   source directories.-isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool-isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf-isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs---- | Get the list of exposed modules and extra tools needed to build them.-getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags-getModulesBuildToolsAndDeps pkgIx flags = do-  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags--  sourceFiles0 <- scanForModules dir--  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0--  Just mods <-      return (exposedModules flags)-           ?>> (return . Just . map moduleName $ sourceFiles)--  tools <-     return (buildTools flags)-           ?>> (return . Just . neededBuildPrograms $ sourceFiles)--  deps <-      return (dependencies flags)-           ?>> Just <$> importsToDeps flags-                        (fromString "Prelude" :  -- to ensure we get base as a dep-                           (   nub   -- only need to consider each imported package once-                             . filter (`notElem` mods)  -- don't consider modules from-                                                        -- this package itself-                             . concatMap imports-                             $ sourceFiles-                           )-                        )-                        pkgIx--  exts <-     return (otherExts flags)-          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)--  -- If we're initializing a library and there were no modules discovered-  -- then create an empty 'MyLib' module.-  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because-  -- then the executable needs to set 'other-modules: MyLib' or else the build-  -- fails.-  let (finalModsList, otherMods) = case (packageType flags, mods) of--        -- For an executable leave things as they are.-        (Flag Executable, _) -> (mods, otherModules flags)--        -- If a non-empty module list exists don't change anything.-        (_, (_:_)) -> (mods, otherModules flags)--        -- Library only: 'MyLib' in 'other-modules' only.-        (Flag Library, _) -> ([myLibModule], Nothing)--        -- For a 'LibraryAndExecutable' we need to have special handling.-        -- If we don't have a module list (Nothing or empty), then create a Lib.-        (_, []) ->-          if sourceDirs flags == applicationDirs flags-          then ([myLibModule], Just [myLibModule])-          else ([myLibModule], Nothing)--  return $ flags { exposedModules = Just finalModsList-                 , otherModules   = otherMods-                 , buildTools     = tools-                 , dependencies   = deps-                 , otherExts      = exts-                 }--importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]-importsToDeps flags mods pkgIx = do--  let modMap :: M.Map ModuleName [InstalledPackageInfo]-      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx--      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]-      modDeps = map (id &&& flip M.lookup modMap) mods--  message flags "\nGuessing dependencies..."-  nub . catMaybes <$> mapM (chooseDep flags) modDeps---- Given a module and a list of installed packages providing it,--- choose a dependency (i.e. package + version range) to use for that--- module.-chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])-          -> IO (Maybe P.Dependency)--chooseDep flags (m, Nothing)-  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")-    >> return Nothing--chooseDep flags (m, Just [])-  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")-    >> return Nothing--    -- We found some packages: group them by name.-chooseDep flags (m, Just ps)-  = case pkgGroups of-      -- if there's only one group, i.e. multiple versions of a single package,-      -- we make it into a dependency, choosing the latest-ish version (see toDep).-      [grp] -> Just <$> toDep grp-      -- otherwise, we refuse to choose between different packages and make the user-      -- do it.-      grps  -> do message flags ("\nWarning: multiple packages found providing "-                                 ++ display m-                                 ++ ": " ++ intercalate ", " (fmap (display . P.pkgName . NE.head) grps))-                  message flags "You will need to pick one and manually add it to the Build-depends: field."-                  return Nothing-  where-    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)--    desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags)--    -- Given a list of available versions of the same package, pick a dependency.-    toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency--    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*-    toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries--    -- Otherwise, choose the latest version and issue a warning.-    toDep pids  = do-      message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")-      return $ P.Dependency (P.pkgName . NE.head $ pids)-                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)-                            (Set.singleton LMainLibName) --TODO take into account sublibraries---- | Given a version, return an API-compatible (according to PVP) version range.------ If the boolean argument denotes whether to use a desugared--- representation (if 'True') or the new-style @^>=@-form (if--- 'False').------ Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the--- same as @0.4.*@).-pvpize :: Bool -> Version -> VersionRange-pvpize False  v = majorBoundVersion v-pvpize True   v = orLaterVersion v'-           `intersectVersionRanges`-           earlierVersion (incVersion 1 v')-  where v' = alterVersion (take 2) v---- | Increment the nth version component (counting from 0).-incVersion :: Int -> Version -> Version-incVersion n = alterVersion (incVersion' n)-  where-    incVersion' 0 []     = [1]-    incVersion' 0 (v:_)  = [v+1]-    incVersion' m []     = replicate m 0 ++ [1]-    incVersion' m (v:vs) = v : incVersion' (m-1) vs---- | Returns true if this package is eligible for test suite initialization.-eligibleForTestSuite :: InitFlags -> Bool-eligibleForTestSuite flags =-  Flag True == initializeTestSuite flags-  && Flag Executable /= packageType flags--------------------------------------------------------------------------------  Prompting/user interaction  --------------------------------------------------------------------------------------------------------------------------- | Run a prompt or not based on the interactive flag of the---   InitFlags structure.-maybePrompt :: InitFlags -> IO t -> IO (Maybe t)-maybePrompt flags p =-  case interactive flags of-    Flag True -> Just `fmap` p-    _         -> return Nothing---- | Create a prompt with optional default value that returns a---   String.-promptStr :: String -> Maybe String -> IO String-promptStr = promptDefault' Just id---- | Create a yes/no prompt with optional default value.----promptYesNo :: String -> Maybe Bool -> IO Bool-promptYesNo =-    promptDefault' recogniseYesNo showYesNo-  where-    recogniseYesNo s | s == "y" || s == "Y" = Just True-                     | s == "n" || s == "N" = Just False-                     | otherwise            = Nothing-    showYesNo True  = "y"-    showYesNo False = "n"---- | Create a prompt with optional default value that returns a value---   of some Text instance.-prompt :: Text t => String -> Maybe t -> IO t-prompt = promptDefault'-           (either (const Nothing) Just . runReadE (readP_to_E id parse))-           display---- | Create a prompt with an optional default value.-promptDefault' :: (String -> Maybe t)       -- ^ parser-               -> (t -> String)             -- ^ pretty-printer-               -> String                    -- ^ prompt message-               -> Maybe t                   -- ^ optional default value-               -> IO t-promptDefault' parser pretty pr def = do-  putStr $ mkDefPrompt pr (pretty `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d)  -> return d-    _  -> case parser inp of-            Just t  -> return t-            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"-                          promptDefault' parser pretty pr def---- | Create a prompt from a prompt string and a String representation---   of an optional default value.-mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ "?" ++ defStr def-  where defStr Nothing  = " "-        defStr (Just s) = " [default: " ++ s ++ "] "--promptListOptional :: (Text t, Eq t)-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> IO (Maybe (Either String t))-promptListOptional pr choices = promptListOptional' pr choices display--promptListOptional' :: Eq t-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> (t -> String)     -- ^ show an item-                   -> IO (Maybe (Either String t))-promptListOptional' pr choices displayItem =-    fmap rearrange-  $ promptList pr (Nothing : map Just choices) (Just Nothing)-               (maybe "(none)" displayItem) True-  where-    rearrange = either (Just . Left) (fmap Right)---- | Create a prompt from a list of items.-promptList :: Eq t-           => String            -- ^ prompt-           -> [t]               -- ^ choices-           -> Maybe t           -- ^ optional default value-           -> (t -> String)     -- ^ show an item-           -> Bool              -- ^ whether to allow an 'other' option-           -> IO (Either String t)-promptList pr choices def displayItem other = do-  putStrLn $ pr ++ ":"-  let options1 = map (\c -> (Just c == def, displayItem c)) choices-      options2 = zip ([1..]::[Int])-                     (options1 ++ [(False, "Other (specify)") | other])-  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2-  promptList' displayItem (length options2) choices def other- where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest-                      | otherwise = " " ++ star i ++ rest-                  where rest = show n ++ ") "-                        star True = "*"-                        star False = " "--promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' displayItem numChoices choices def other = do-  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d) -> return $ Right d-    _  -> case readMaybe inp of-            Nothing -> invalidChoice inp-            Just n  -> getChoice n- where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."-                              promptList' displayItem numChoices choices def other-       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)-                   | n < numChoices ||-                     (n == numChoices && not other)-                                  = return . Right $ choices !! (n-1)-                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing--------------------------------------------------------------------------------  File generation  ------------------------------------------------------------------------------------------------------------------------------------writeLicense :: InitFlags -> IO ()-writeLicense flags = do-  message flags "\nGenerating LICENSE..."-  year <- show <$> getYear-  let authors = fromMaybe "???" . flagToMaybe . author $ flags-  let licenseFile =-        case license flags of-          Flag BSD2-            -> Just $ bsd2 authors year--          Flag BSD3-            -> Just $ bsd3 authors year--          Flag (GPL (Just v)) | v == mkVersion [2]-            -> Just gplv2--          Flag (GPL (Just v)) | v == mkVersion [3]-            -> Just gplv3--          Flag (LGPL (Just v)) | v == mkVersion [2,1]-            -> Just lgpl21--          Flag (LGPL (Just v)) | v == mkVersion [3]-            -> Just lgpl3--          Flag (AGPL (Just v)) | v == mkVersion [3]-            -> Just agplv3--          Flag (Apache (Just v)) | v == mkVersion [2,0]-            -> Just apache20--          Flag MIT-            -> Just $ mit authors year--          Flag (MPL v) | v == mkVersion [2,0]-            -> Just mpl20--          Flag ISC-            -> Just $ isc authors year--          _ -> Nothing--  case licenseFile of-    Just licenseText -> writeFileSafe flags "LICENSE" licenseText-    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."--getYear :: IO Integer-getYear = do-  u <- getCurrentTime-  z <- getCurrentTimeZone-  let l = utcToLocalTime z u-      (y, _, _) = toGregorian $ localDay l-  return y--writeSetupFile :: InitFlags -> IO ()-writeSetupFile flags = do-  message flags "Generating Setup.hs..."-  writeFileSafe flags "Setup.hs" setupFile- where-  setupFile = unlines-    [ "import Distribution.Simple"-    , "main = defaultMain"-    ]--writeChangeLog :: InitFlags -> IO ()-writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do-  message flags ("Generating "++ defaultChangeLog ++"...")-  writeFileSafe flags defaultChangeLog changeLog- where-  changeLog = unlines-    [ "# Revision history for " ++ pname-    , ""-    , "## " ++ pver ++ " -- YYYY-mm-dd"-    , ""-    , "* First version. Released on an unsuspecting world."-    ]-  pname = maybe "" display $ flagToMaybe $ packageName flags-  pver = maybe "" display $ flagToMaybe $ version flags----writeCabalFile :: InitFlags -> IO Bool-writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do-  message flags "Error: no package name provided."-  return False-writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = display p ++ ".cabal"-  message flags $ "Generating " ++ cabalFileName ++ "..."-  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)-  return True---- | Write a file \"safely\", backing up any existing version (unless---   the overwrite flag is set).-writeFileSafe :: InitFlags -> FilePath -> String -> IO ()-writeFileSafe flags fileName content = do-  moveExistingFile flags fileName-  writeFile fileName content---- | Create directories, if they were given, and don't already exist.-createDirectories :: Maybe [String] -> IO ()-createDirectories mdirs = case mdirs of-  Just dirs -> forM_ dirs (createDirectoryIfMissing True)-  Nothing   -> return ()---- | Create MyLib.hs file, if its the only module in the liste.-createLibHs :: InitFlags -> IO ()-createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do-  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"-  case sourceDirs flags of-    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)-    _                -> writeLibHs flags modFilePath---- | Write a MyLib.hs file if it doesn't already exist.-writeLibHs :: InitFlags -> FilePath -> IO ()-writeLibHs flags libPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let libFullPath = dir </> libPath-  exists <- doesFileExist libFullPath-  unless exists $ do-    message flags $ "Generating " ++ libPath ++ "..."-    writeFileSafe flags libFullPath myLibHs--myLibModule :: ModuleName-myLibModule = ModuleName.fromString "MyLib"---- | Default MyLib.hs file.  Used when no Lib.hs exists.-myLibHs :: String-myLibHs = unlines-  [ "module MyLib (someFunc) where"-  , ""-  , "someFunc :: IO ()"-  , "someFunc = putStrLn \"someFunc\""-  ]---- | Create Main.hs, but only if we are init'ing an executable and---   the mainIs flag has been provided.-createMainHs :: InitFlags -> IO ()-createMainHs flags =-  if hasMainHs flags then-    case applicationDirs flags of-      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)-      _ -> writeMainHs flags mainFile-  else return ()-  where-    mainFile = case mainIs flags of-      Flag x -> x-      NoFlag -> error "createMainHs: no mainIs"----- | Write a main file if it doesn't already exist.-writeMainHs :: InitFlags -> FilePath -> IO ()-writeMainHs flags mainPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let mainFullPath = dir </> mainPath-  exists <- doesFileExist mainFullPath-  unless exists $ do-      message flags $ "Generating " ++ mainPath ++ "..."-      writeFileSafe flags mainFullPath (mainHs flags)---- | Check that a main file exists.-hasMainHs :: InitFlags -> Bool-hasMainHs flags = case mainIs flags of-  Flag _ -> (packageType flags == Flag Executable-             || packageType flags == Flag LibraryAndExecutable)-  _ -> False---- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.------   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.-mainHs :: InitFlags -> String-mainHs flags = (unlines . map prependPrefix) $ case packageType flags of-  Flag LibraryAndExecutable ->-    [ "module Main where"-    , ""-    , "import qualified MyLib (someFunc)"-    , ""-    , "main :: IO ()"-    , "main = do"-    , "  putStrLn \"Hello, Haskell!\""-    , "  MyLib.someFunc"-    ]-  _ ->-    [ "module Main where"-    , ""-    , "main :: IO ()"-    , "main = putStrLn \"Hello, Haskell!\""-    ]-  where-    prependPrefix "" = ""-    prependPrefix line-      | isLiterate = "> " ++ line-      | otherwise  = line-    isLiterate = case mainIs flags of-      Flag mainPath -> takeExtension mainPath == ".lhs"-      _             -> False--testFile :: String-testFile = "MyLibTest.hs"---- | Create MyLibTest.hs, but only if we are init'ing a library and---   the initializeTestSuite flag has been set.-createTestHs :: InitFlags -> IO ()-createTestHs flags =-  when (eligibleForTestSuite flags) $-    case testDirs flags of-      Just (testPath:_) -> writeTestHs flags (testPath </> testFile)-      _ -> writeMainHs flags testFile----- | Write a test file.-writeTestHs :: InitFlags -> FilePath -> IO ()-writeTestHs flags testPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let testFullPath = dir </> testPath-  exists <- doesFileExist testFullPath-  unless exists $ do-      message flags $ "Generating " ++ testPath ++ "..."-      writeFileSafe flags testFullPath testHs---- | Default MyLibTest.hs file.-testHs :: String-testHs = unlines-  [ "module Main (main) where"-  , ""-  , "main :: IO ()"-  , "main = putStrLn \"Test suite not yet implemented.\""-  ]----- | Move an existing file, if there is one, and the overwrite flag is---   not set.-moveExistingFile :: InitFlags -> FilePath -> IO ()-moveExistingFile flags fileName =-  unless (overwrite flags == Flag True) $ do-    e <- doesFileExist fileName-    when e $ do-      newName <- findNewName fileName-      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName-      copyFile fileName newName--findNewName :: FilePath -> IO FilePath-findNewName oldName = findNewName' 0-  where-    findNewName' :: Integer -> IO FilePath-    findNewName' n = do-      let newName = oldName <.> ("save" ++ show n)-      e <- doesFileExist newName-      if e then findNewName' (n+1) else return newName---- | Generate a .cabal file from an InitFlags structure.  NOTE: this---   is rather ad-hoc!  What we would REALLY like is to have a---   standard low-level AST type representing .cabal files, which---   preserves things like comments, and to write an *inverse*---   parser/pretty-printer pair between .cabal files and this AST.---   Then instead of this ad-hoc code we could just map an InitFlags---   structure onto a low-level AST structure and use the existing---   pretty-printing code to generate the file.-generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c = trimTrailingWS $-  (++ "\n") .-  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $-  -- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD-  (if specVer < mkVersion [1,12]-   then field "cabal-version" (Flag $ orLaterVersion specVer) -- legacy-   else field "cabal-version" (Flag $ specVer))-              Nothing -- NB: the first line must be the 'cabal-version' declaration-              False-  $$-  (if minimal c /= Flag True-    then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated "-                          ++ "by 'cabal init'.  For further documentation, see "-                          ++ "http://haskell.org/cabal/users-guide/")-         $$ text ""-    else empty)-  $$-  vcat [ field  "name"          (packageName   c)-                (Just "The name of the package.")-                True--       , field  "version"       (version       c)-                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://pvp.haskell.org\n"-                ++ "PVP summary:      +-+------- breaking API changes\n"-                ++ "                  | | +----- non-breaking API additions\n"-                ++ "                  | | | +--- code changes with no API change")-                True--       , fieldS "synopsis"      (synopsis      c)-                (Just "A short (one-line) description of the package.")-                True--       , fieldS "description"   NoFlag-                (Just "A longer description of the package.")-                True--       , fieldS "homepage"      (homepage     c)-                (Just "URL for the project homepage or repository.")-                False--       , fieldS "bug-reports"   NoFlag-                (Just "A URL where users can report bugs.")-                True--       , fieldS  "license"      licenseStr-                (Just "The license under which the package is released.")-                True--       , case (license c) of-           Flag PublicDomain -> empty-           _ -> fieldS "license-file" (Flag "LICENSE")-                       (Just "The file containing the license text.")-                       True--       , fieldS "author"        (author       c)-                (Just "The package author(s).")-                True--       , fieldS "maintainer"    (email        c)-                (Just "An email address to which users can send suggestions, bug reports, and patches.")-                True--       , case (license c) of-           Flag PublicDomain -> empty-           _ -> fieldS "copyright"     NoFlag-                       (Just "A copyright notice.")-                       True--       , fieldS "category"      (either id display `fmap` category c)-                Nothing-                True--       , fieldS "build-type"    (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple")-                Nothing-                False--       , fieldS "extra-source-files" (listFieldS (extraSrc c))-                (Just "Extra files to be distributed with the package, such as examples or a README.")-                True--       , case packageType c of-           Flag Executable -> executableStanza-           Flag Library    -> libraryStanza-           Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza-           _               -> empty--       , if eligibleForTestSuite c then testSuiteStanza else empty-       ]- where-   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)--   licenseStr | specVer < mkVersion [2,2] = prettyShow `fmap` license c-              | otherwise                 = go `fmap` license c-     where-       go (UnknownLicense s) = s-       go l                  = prettyShow (licenseToSPDX l)--   generateBuildInfo :: BuildType -> InitFlags -> Doc-   generateBuildInfo buildType c' = vcat-     [ fieldS "other-modules" (listField otherMods)-              (Just $ case buildType of-                 LibBuild    -> "Modules included in this library but not exported."-                 ExecBuild -> "Modules included in this executable, other than Main.")-              True--     , fieldS "other-extensions" (listField (otherExts c'))-              (Just "LANGUAGE extensions used by modules in this package.")-              True--     , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c'))-              (Just "Other library packages from which modules are imported.")-              True--     , fieldS "hs-source-dirs" (listFieldS (case buildType of-                                            LibBuild  -> sourceDirs c'-                                            ExecBuild -> applicationDirs c'))-              (Just "Directories containing source files.")-              True--     , fieldS "build-tools" (listFieldS (buildTools c'))-              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")-              False--     , field  "default-language" (language c')-              (Just "Base language which the package is written in.")-              True-     ]-     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).-     where-       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild-                      then case packageName c' of-                             Flag pkgName -> ", " ++ P.unPackageName pkgName-                             _ -> ""-                      else ""--       -- Only include 'MyLib' in 'other-modules' of the executable.-       otherModsFromFlag = otherModules c'-       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]-                   then Nothing-                   else otherModsFromFlag--   listField :: Text s => Maybe [s] -> Flag String-   listField = listFieldS . fmap (map display)--   listFieldS :: Maybe [String] -> Flag String-   listFieldS = Flag . maybe "" (intercalate ", ")--   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc-   field s f = fieldS s (fmap display f)--   fieldS :: String        -- ^ Name of the field-          -> Flag String   -- ^ Field contents-          -> Maybe String  -- ^ Comment to explain the field-          -> Bool          -- ^ Should the field be included (commented out) even if blank?-          -> Doc-   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty-   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty-   fieldS s f com _ = case (isJust com, noComments c, minimal c) of-                        (_, _, Flag True) -> id-                        (_, Flag True, _) -> id-                        (True, _, _)      -> (showComment com $$) . ($$ text "")-                        (False, _, _)     -> ($$ text "")-                      $-                      comment f <<>> text s <<>> colon-                                <<>> text (replicate (20 - length s) ' ')-                                <<>> text (fromMaybe "" . flagToMaybe $ f)-   comment NoFlag    = text "-- "-   comment (Flag "") = text "-- "-   comment _         = text ""--   showComment :: Maybe String -> Doc-   showComment (Just t) = vcat-                        . map (text . ("-- "++)) . lines-                        . renderStyle style {-                            lineLength = 76,-                            ribbonsPerLine = 1.05-                          }-                        . vcat-                        . map (fcat . map text . breakLine)-                        . lines-                        $ t-   showComment Nothing  = text ""--   breakLine  [] = []-   breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'-   breakLine' [] = []-   breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'--   trimTrailingWS :: String -> String-   trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines--   executableStanza :: Doc-   executableStanza = text "\nexecutable" <+>-             text (maybe "" display . flagToMaybe $ packageName c) $$-             nest 2 (vcat-             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True--             , generateBuildInfo ExecBuild c-             ])--   libraryStanza :: Doc-   libraryStanza = text "\nlibrary" $$ nest 2 (vcat-             [ fieldS "exposed-modules" (listField (exposedModules c))-                      (Just "Modules exported by the library.")-                      True--             , generateBuildInfo LibBuild c-             ])--   testSuiteStanza :: Doc-   testSuiteStanza = text "\ntest-suite" <+>-     text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$-     nest 2 (vcat-             [ field  "default-language" (language c)-               (Just "Base language which the package is written in.")-               True--             , fieldS "type" (Flag "exitcode-stdio-1.0")-               (Just "The interface type and version of the test suite.")-               True--             , fieldS "hs-source-dirs" (listFieldS (testDirs c))-               (Just "The directory where the test specifications are found.")-               True--             , fieldS "main-is" (Flag testFile)-               (Just "The entrypoint to the test suite.")-               True--             , fieldS "build-depends" (listField (dependencies c))-               (Just "Test dependencies.")-               True-             ])---- | Generate warnings for missing fields etc.-generateWarnings :: InitFlags -> IO ()-generateWarnings flags = do-  message flags ""-  when (synopsis flags `elem` [NoFlag, Flag ""])-       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")--  message flags "You may want to edit the .cabal file and add a Description field."---- | Possibly generate a message to stdout, taking into account the---   --quiet flag.-message :: InitFlags -> String -> IO ()-message (InitFlags{quiet = Flag True}) _ = return ()-message _ s = putStrLn s+import Distribution.Client.Init.Command+  ( initCabal, incVersion )
+ Distribution/Client/Init/Command.hs view
@@ -0,0 +1,730 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Command+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Command (++    -- * Commands+    initCabal+  , incVersion++  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import System.IO+  ( hSetBuffering, stdout, BufferMode(..) )+import System.Directory+  ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents )+import System.FilePath+  ( (</>), takeBaseName, equalFilePath )++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Control.Monad+  ( (>=>) )+import Control.Arrow+  ( (&&&), (***) )++import Distribution.CabalSpecVersion+  ( CabalSpecVersion (..), showCabalSpecVersion )+import Distribution.Version+  ( Version, mkVersion, alterVersion, majorBoundVersion+  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )+import Distribution.ModuleName+  ( ModuleName )  -- And for the Text instance+import Distribution.InstalledPackageInfo+  ( InstalledPackageInfo, exposed )+import qualified Distribution.Package as P+import qualified Distribution.SPDX as SPDX+import Language.Haskell.Extension ( Language(..) )++import Distribution.Client.Init.Defaults+  ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir )+import Distribution.Client.Init.FileCreators+  ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs+  , createTestSuiteIfEligible, writeCabalFile )+import Distribution.Client.Init.Prompt+  ( prompt, promptYesNo, promptStr, promptList, maybePrompt+  , promptListOptional )+import Distribution.Client.Init.Utils+  ( eligibleForTestSuite,  message )+import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..), Category(..)+  , displayPackageType )+import Distribution.Client.Init.Heuristics+  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,+    SourceFileEntry(..),+    scanForModules, neededBuildPrograms )++import Distribution.Simple.Flag+  ( maybeToFlag )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Simple.Configure+  ( getInstalledPackages )+import Distribution.Simple.Compiler+  ( PackageDBStack, Compiler )+import Distribution.Simple.Program+  ( ProgramDb )+import Distribution.Simple.PackageIndex+  ( InstalledPackageIndex, moduleNameIndex )++import Distribution.Solver.Types.PackageIndex+  ( elemByPackageName )++import Distribution.Client.IndexUtils+  ( getSourcePackages )+import Distribution.Client.Types+  ( SourcePackageDb(..) )+import Distribution.Client.Setup+  ( RepoContext(..) )++initCabal :: Verbosity+          -> PackageDBStack+          -> RepoContext+          -> Compiler+          -> ProgramDb+          -> InitFlags+          -> IO ()+initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do++  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  sourcePkgDb <- getSourcePackages verbosity repoCtxt++  hSetBuffering stdout NoBuffering++  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags++  case license initFlags' of+    Flag SPDX.NONE -> return ()+    _              -> writeLicense initFlags'+  writeChangeLog initFlags'+  createDirectories (sourceDirs initFlags')+  createLibHs initFlags'+  createDirectories (applicationDirs initFlags')+  createMainHs initFlags'+  createTestSuiteIfEligible initFlags'+  success <- writeCabalFile initFlags'++  when success $ generateWarnings initFlags'++---------------------------------------------------------------------------+--  Flag acquisition  -----------------------------------------------------+---------------------------------------------------------------------------++-- | Fill in more details in InitFlags by guessing, discovering, or prompting+-- the user.+extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags+extendFlags pkgIx sourcePkgDb =+      getSimpleProject+  >=> getLibOrExec+  >=> getCabalVersion+  >=> getPackageName sourcePkgDb+  >=> getVersion+  >=> getLicense+  >=> getAuthorInfo+  >=> getHomepage+  >=> getSynopsis+  >=> getCategory+  >=> getExtraSourceFiles+  >=> getAppDir+  >=> getSrcDir+  >=> getGenTests+  >=> getTestDir+  >=> getLanguage+  >=> getGenComments+  >=> getModulesBuildToolsAndDeps pkgIx++-- | Combine two actions which may return a value, preferring the first. That+--   is, run the second action only if the first doesn't return a value.+infixr 1 ?>>+(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)+f ?>> g = do+  ma <- f+  if isJust ma+    then return ma+    else g++-- | Ask if a simple project with sensible defaults should be created.+getSimpleProject :: InitFlags -> IO InitFlags+getSimpleProject flags = do+  simpleProj <-     return (flagToMaybe $ simpleProject flags)+                ?>> maybePrompt flags+                    (promptYesNo+                      "Should I generate a simple project with sensible defaults"+                      (Just True))+  return $ case maybeToFlag simpleProj of+    Flag True ->+      flags { interactive = Flag False+            , simpleProject = Flag True+            , packageType = Flag LibraryAndExecutable+            , cabalVersion = Flag defaultCabalVersion+            }+    simpleProjFlag@_ ->+      flags { simpleProject = simpleProjFlag }+++-- | Get the version of the cabal spec to use.+--+-- The spec version can be specified by the InitFlags cabalVersion field. If+-- none is specified then the user is prompted to pick from a list of+-- supported versions (see code below).+getCabalVersion :: InitFlags -> IO InitFlags+getCabalVersion flags = do+  cabVer <-     return (flagToMaybe $ cabalVersion flags)+            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`+                                  promptList "Please choose version of the Cabal specification to use"+                                  [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0]+                                  (Just defaultCabalVersion) displayCabalVersion False)+            ?>> return (Just defaultCabalVersion)++  return $  flags { cabalVersion = maybeToFlag cabVer }++  where+    displayCabalVersion :: CabalSpecVersion -> String+    displayCabalVersion v = case v of+      CabalSpecV1_10 -> "1.10   (legacy)"+      CabalSpecV2_0  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"+      CabalSpecV2_2  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"+      CabalSpecV2_4  -> "2.4    (+ support for '**' globbing)"+      CabalSpecV3_0  -> "3.0    (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"+      _              -> showCabalSpecVersion v++++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags+getPackageName sourcePkgDb flags = do+  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)+              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)++  let guess' | isPkgRegistered guess = Nothing+             | otherwise = guess++  pkgName' <-     return (flagToMaybe $ packageName flags)+              ?>> maybePrompt flags (prompt "Package name" guess')+              ?>> return guess'++  chooseAgain <- if isPkgRegistered pkgName'+                    then promptYesNo promptOtherNameMsg (Just True)+                    else return False++  if chooseAgain+    then getPackageName sourcePkgDb flags+    else return $ flags { packageName = maybeToFlag pkgName' }++  where+    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg+    isPkgRegistered Nothing    = False++    promptOtherNameMsg = "This package name is already used by another " +++                         "package on hackage. Do you want to choose a " +++                         "different name"++-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user+--  if possible.+getVersion :: InitFlags -> IO InitFlags+getVersion flags = do+  let v = Just $ mkVersion [0,1,0,0]+  v' <-     return (flagToMaybe $ version flags)+        ?>> maybePrompt flags (prompt "Package version" v)+        ?>> return v+  return $ flags { version = maybeToFlag v' }++-- | Choose a license for the package.+--+-- The license can come from Initflags (license field), if it is not present+-- then prompt the user from a predefined list of licenses.+getLicense :: InitFlags -> IO InitFlags+getLicense flags = do+  elic <- return (fmap Right $ flagToMaybe $ license flags)+      ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True)++  case elic of+      Nothing          -> return flags { license = NoFlag }+      Just (Right lic) -> return flags { license = Flag lic }+      Just (Left str)  -> case eitherParsec str of+          Right lic -> return flags { license = Flag lic }+          -- on error, loop+          Left err -> do+              putStrLn "The license must be a valid SPDX expression."+              putStrLn err+              getLicense flags+  where+    -- perfectly we'll have this and writeLicense (in FileCreators)+    -- in a single file+    listedLicenses =+      SPDX.NONE :+      map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))+      [ SPDX.BSD_2_Clause+      , SPDX.BSD_3_Clause+      , SPDX.Apache_2_0+      , SPDX.MIT+      , SPDX.MPL_2_0+      , SPDX.ISC++      , SPDX.GPL_2_0_only+      , SPDX.GPL_3_0_only+      , SPDX.LGPL_2_1_only+      , SPDX.LGPL_3_0_only+      , SPDX.AGPL_3_0_only++      , SPDX.GPL_2_0_or_later+      , SPDX.GPL_3_0_or_later+      , SPDX.LGPL_2_1_or_later+      , SPDX.LGPL_3_0_or_later+      , SPDX.AGPL_3_0_or_later+      ]++-- | The author's name and email. Prompt, or try to guess from an existing+--   darcs repo.+getAuthorInfo :: InitFlags -> IO InitFlags+getAuthorInfo flags = do+  (authorName, authorEmail)  <-+    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail+  authorName'  <-     return (flagToMaybe $ author flags)+                  ?>> maybePrompt flags (promptStr "Author name" authorName)+                  ?>> return authorName++  authorEmail' <-     return (flagToMaybe $ email flags)+                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)+                  ?>> return authorEmail++  return $ flags { author = maybeToFlag authorName'+                 , email  = maybeToFlag authorEmail'+                 }++-- | Prompt for a homepage URL for the package.+getHomepage :: InitFlags -> IO InitFlags+getHomepage flags = do+  hp  <- queryHomepage+  hp' <-     return (flagToMaybe $ homepage flags)+         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)+         ?>> return hp++  return $ flags { homepage = maybeToFlag hp' }++-- | Right now this does nothing, but it could be changed to do some+--   intelligent guessing.+queryHomepage :: IO (Maybe String)+queryHomepage = return Nothing     -- get default remote darcs repo?++-- | Prompt for a project synopsis.+getSynopsis :: InitFlags -> IO InitFlags+getSynopsis flags = do+  syn <-     return (flagToMaybe $ synopsis flags)+         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)++  return $ flags { synopsis = maybeToFlag syn }++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+getCategory :: InitFlags -> IO InitFlags+getCategory flags = do+  cat <-     return (flagToMaybe $ category flags)+         ?>> fmap join (maybePrompt flags+                         (promptListOptional "Project category" [Codec ..]))+  return $ flags { category = maybeToFlag cat }++-- | Try to guess extra source files (don't prompt the user).+getExtraSourceFiles :: InitFlags -> IO InitFlags+getExtraSourceFiles flags = do+  extraSrcFiles <-     return (extraSrc flags)+                   ?>> Just `fmap` guessExtraSourceFiles flags++  return $ flags { extraSrc = extraSrcFiles }++defaultChangeLog :: FilePath+defaultChangeLog = "CHANGELOG.md"++-- | Try to guess things to include in the extra-source-files field.+--   For now, we just look for things in the root directory named+--   'readme', 'changes', or 'changelog', with any sort of+--   capitalization and any extension.+guessExtraSourceFiles :: InitFlags -> IO [FilePath]+guessExtraSourceFiles flags = do+  dir <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  files <- getDirectoryContents dir+  let extraFiles = filter isExtra files+  if any isLikeChangeLog extraFiles+    then return extraFiles+    else return (defaultChangeLog : extraFiles)++  where+    isExtra = likeFileNameBase ("README" : changeLogLikeBases)+    isLikeChangeLog = likeFileNameBase changeLogLikeBases+    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName+    changeLogLikeBases = ["CHANGES", "CHANGELOG"]++-- | Ask whether the project builds a library or executable.+getLibOrExec :: InitFlags -> IO InitFlags+getLibOrExec flags = do+  pkgType <-     return (flagToMaybe $ packageType flags)+           ?>> maybePrompt flags (either (const Executable) id `fmap`+                                   promptList "What does the package build"+                                   [Executable, Library, LibraryAndExecutable]+                                   Nothing displayPackageType False)+           ?>> return (Just Executable)++  -- If this package contains an executable, get the main file name.+  mainFile <- if pkgType == Just Library then return Nothing else+                    getMainFile flags++  return $ flags { packageType = maybeToFlag pkgType+                 , mainIs = maybeToFlag mainFile+                 }+++-- | Try to guess the main file of the executable, and prompt the user to choose+-- one of them. Top-level modules including the word 'Main' in the file name+-- will be candidates, and shorter filenames will be preferred.+getMainFile :: InitFlags -> IO (Maybe FilePath)+getMainFile flags =+  return (flagToMaybe $ mainIs flags)+  ?>> do+    candidates <- guessMainFileCandidates flags+    let showCandidate = either (++" (does not yet exist, but will be created)") id+        defaultFile = listToMaybe candidates+    maybePrompt flags (either id (either id id) `fmap`+                       promptList "What is the main module of the executable"+                       candidates+                       defaultFile showCandidate True)+      ?>> return (fmap (either id id) defaultFile)++-- | Ask if a test suite should be generated for the library.+getGenTests :: InitFlags -> IO InitFlags+getGenTests flags = do+  genTests <-     return (flagToMaybe $ initializeTestSuite flags)+                  -- Only generate a test suite if the package contains a library.+              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing+              ?>> maybePrompt flags+                  (promptYesNo+                    "Should I generate a test suite for the library"+                    (Just True))+  return $ flags { initializeTestSuite = maybeToFlag genTests }++-- | Ask for the test suite root directory.+getTestDir :: InitFlags -> IO InitFlags+getTestDir flags = do+  dirs <- return (testDirs flags)+              -- Only need testDirs when test suite generation is enabled.+          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing+          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt+                   flags+                   (promptList "Test directory" ["test"] (Just "test") id True))++  return $ flags { testDirs = dirs }++-- | Ask for the Haskell base language of the package.+getLanguage :: InitFlags -> IO InitFlags+getLanguage flags = do+  lang <-     return (flagToMaybe $ language flags)+          ?>> maybePrompt flags+                (either UnknownLanguage id `fmap`+                  promptList "What base language is the package written in"+                  [Haskell2010, Haskell98]+                  (Just Haskell2010) prettyShow True)+          ?>> return (Just Haskell2010)++  if invalidLanguage lang+    then putStrLn invalidOtherLanguageMsg >> getLanguage flags+    else return $ flags { language = maybeToFlag lang }++  where+    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t+    invalidLanguage _ = False++    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " +++                              "Please enter a different language."++-- | Ask whether to generate explanatory comments.+getGenComments :: InitFlags -> IO InitFlags+getGenComments flags = do+  genComments <-     return (not <$> flagToMaybe (noComments flags))+                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))+                 ?>> return (Just False)+  return $ flags { noComments = maybeToFlag (fmap not genComments) }+  where+    promptMsg = "Add informative comments to each field in the cabal file (y/n)"++-- | Ask for the application root directory.+getAppDir :: InitFlags -> IO InitFlags+getAppDir flags = do+  appDirs <-+    return (applicationDirs flags)+    ?>> noAppDirIfLibraryOnly+    ?>> guessAppDir flags+    ?>> promptUserForApplicationDir+    ?>> setDefault+  return $ flags { applicationDirs = appDirs }++  where+    -- If the packageType==Library, then there is no application dir.+    noAppDirIfLibraryOnly :: IO (Maybe [String])+    noAppDirIfLibraryOnly =+      if (packageType flags) == Flag Library+      then return (Just [])+      else return Nothing++    -- Set the default application directory.+    setDefault :: IO (Maybe [String])+    setDefault = pure (Just [defaultApplicationDir])++    -- Prompt the user for the application directory (defaulting to "app").+    -- Returns 'Nothing' if in non-interactive mode, otherwise will always+    -- return a 'Just' value ('Just []' if no separate application directory).+    promptUserForApplicationDir :: IO (Maybe [String])+    promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt+      flags+      (promptList+       ("Application " ++ mainFile ++ "directory")+       [[defaultApplicationDir], ["src-exe"], []]+        (Just [defaultApplicationDir])+       showOption True)++    showOption :: [String] -> String+    showOption [] = "(none)"+    showOption (x:_) = x++    -- The name+    mainFile :: String+    mainFile = case mainIs flags of+      Flag mainPath -> "(" ++ mainPath ++ ") "+      _             -> ""++-- | Try to guess app directory. Could try harder; for the+--   moment just looks to see whether there is a directory called 'app'.+guessAppDir :: InitFlags -> IO (Maybe [String])+guessAppDir flags = do+  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  appIsDir <- doesDirectoryExist (dir </> "app")+  return $ if appIsDir+             then Just ["app"]+             else Nothing++-- | Ask for the source (library) root directory.+getSrcDir :: InitFlags -> IO InitFlags+getSrcDir flags = do+  srcDirs <-+    return (sourceDirs flags)+    ?>> noSourceDirIfExecutableOnly+    ?>> guessSourceDir flags+    ?>> promptUserForSourceDir+    ?>> setDefault++  return $ flags { sourceDirs = srcDirs }++  where+    -- If the packageType==Executable, then there is no source dir.+    noSourceDirIfExecutableOnly :: IO (Maybe [String])+    noSourceDirIfExecutableOnly =+      if (packageType flags) == Flag Executable+      then return (Just [])+      else return Nothing++    -- Set the default source directory.+    setDefault :: IO (Maybe [String])+    setDefault = pure (Just [defaultSourceDir])++    -- Prompt the user for the source directory (defaulting to "app").+    -- Returns 'Nothing' if in non-interactive mode, otherwise will always+    -- return a 'Just' value ('Just []' if no separate application directory).+    promptUserForSourceDir :: IO (Maybe [String])+    promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt+      flags+      (promptList+       ("Library source directory")+       [[defaultSourceDir], ["lib"], ["src-lib"], []]+        (Just [defaultSourceDir])+       showOption True)++    showOption :: [String] -> String+    showOption [] = "(none)"+    showOption (x:_) = x+++-- | Try to guess source directory. Could try harder; for the+--   moment just looks to see whether there is a directory called 'src'.+guessSourceDir :: InitFlags -> IO (Maybe [String])+guessSourceDir flags = do+  dir      <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  srcIsDir <- doesDirectoryExist (dir </> "src")+  return $ if srcIsDir+             then Just ["src"]+             else Nothing++-- | Check whether a potential source file is located in one of the+--   source directories.+isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool+isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf+isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs++-- | Get the list of exposed modules and extra tools needed to build them.+getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags+getModulesBuildToolsAndDeps pkgIx flags = do+  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags++  sourceFiles0 <- scanForModules dir++  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0++  Just mods <-      return (exposedModules flags)+           ?>> (return . Just . map moduleName $ sourceFiles)++  tools <-     return (buildTools flags)+           ?>> (return . Just . neededBuildPrograms $ sourceFiles)++  deps <-      return (dependencies flags)+           ?>> Just <$> importsToDeps flags+                        (fromString "Prelude" :  -- to ensure we get base as a dep+                           (   nub   -- only need to consider each imported package once+                             . filter (`notElem` mods)  -- don't consider modules from+                                                        -- this package itself+                             . concatMap imports+                             $ sourceFiles+                           )+                        )+                        pkgIx++  exts <-     return (otherExts flags)+          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)++  -- If we're initializing a library and there were no modules discovered+  -- then create an empty 'MyLib' module.+  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because+  -- then the executable needs to set 'other-modules: MyLib' or else the build+  -- fails.+  let (finalModsList, otherMods) = case (packageType flags, mods) of++        -- For an executable leave things as they are.+        (Flag Executable, _) -> (mods, otherModules flags)++        -- If a non-empty module list exists don't change anything.+        (_, (_:_)) -> (mods, otherModules flags)++        -- Library only: 'MyLib' in 'other-modules' only.+        (Flag Library, _) -> ([myLibModule], Nothing)++        -- For a 'LibraryAndExecutable' we need to have special handling.+        -- If we don't have a module list (Nothing or empty), then create a Lib.+        (_, []) ->+          if sourceDirs flags == applicationDirs flags+          then ([myLibModule], Just [myLibModule])+          else ([myLibModule], Nothing)++  return $ flags { exposedModules = Just finalModsList+                 , otherModules   = otherMods+                 , buildTools     = tools+                 , dependencies   = deps+                 , otherExts      = exts+                 }++-- | Given a list of imported modules, retrieve the list of dependencies that+-- provide those modules.+importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]+importsToDeps flags mods pkgIx = do++  let modMap :: M.Map ModuleName [InstalledPackageInfo]+      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx++      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]+      modDeps = map (id &&& flip M.lookup modMap) mods++  message flags "\nGuessing dependencies..."+  nub . catMaybes <$> traverse (chooseDep flags) modDeps++-- Given a module and a list of installed packages providing it,+-- choose a dependency (i.e. package + version range) to use for that+-- module.+chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])+          -> IO (Maybe P.Dependency)++chooseDep flags (m, Nothing)+  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")+    >> return Nothing++chooseDep flags (m, Just [])+  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")+    >> return Nothing++    -- We found some packages: group them by name.+chooseDep flags (m, Just ps)+  = case pkgGroups of+      -- if there's only one group, i.e. multiple versions of a single package,+      -- we make it into a dependency, choosing the latest-ish version (see toDep).+      [grp] -> Just <$> toDep grp+      -- otherwise, we refuse to choose between different packages and make the user+      -- do it.+      grps  -> do message flags ("\nWarning: multiple packages found providing "+                                 ++ prettyShow m+                                 ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))+                  message flags "You will need to pick one and manually add it to the Build-depends: field."+                  return Nothing+  where+    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)++    desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags)++    -- Given a list of available versions of the same package, pick a dependency.+    toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency++    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*+    toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries++    -- Otherwise, choose the latest version and issue a warning.+    toDep pids  = do+      message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")+      return $ P.Dependency (P.pkgName . NE.head $ pids)+                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)+                            P.mainLibSet --TODO take into account sublibraries++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- If the boolean argument denotes whether to use a desugared+-- representation (if 'True') or the new-style @^>=@-form (if+-- 'False').+--+-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the+-- same as @0.4.*@).+pvpize :: Bool -> Version -> VersionRange+pvpize False  v = majorBoundVersion v+pvpize True   v = orLaterVersion v'+           `intersectVersionRanges`+           earlierVersion (incVersion 1 v')+  where v' = alterVersion (take 2) v++-- | Increment the nth version component (counting from 0).+incVersion :: Int -> Version -> Version+incVersion n = alterVersion (incVersion' n)+  where+    incVersion' 0 []     = [1]+    incVersion' 0 (v:_)  = [v+1]+    incVersion' m []     = replicate m 0 ++ [1]+    incVersion' m (v:vs) = v : incVersion' (m-1) vs++-- | Generate warnings for missing fields etc.+generateWarnings :: InitFlags -> IO ()+generateWarnings flags = do+  message flags ""+  when (synopsis flags `elem` [NoFlag, Flag ""])+       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")++  message flags "You may want to edit the .cabal file and add a Description field."
+ Distribution/Client/Init/Defaults.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Defaults+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Default values to use in cabal init (if not specified in config/flags).+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Defaults (+    defaultApplicationDir+  , defaultSourceDir+  , defaultCabalVersion+  , myLibModule+  ) where++import Prelude (String)++import Distribution.ModuleName+  ( ModuleName )  -- And for the Text instance+import qualified Distribution.ModuleName as ModuleName+  ( fromString )+import Distribution.CabalSpecVersion+  ( CabalSpecVersion (..))++defaultApplicationDir :: String+defaultApplicationDir = "app"++defaultSourceDir :: String+defaultSourceDir = "src"++defaultCabalVersion :: CabalSpecVersion+defaultCabalVersion = CabalSpecV2_4++myLibModule :: ModuleName+myLibModule = ModuleName.fromString "MyLib"
+ Distribution/Client/Init/FileCreators.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.FileCreators+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions to create files during 'cabal init'.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.FileCreators (++    -- * Commands+    writeLicense+  , writeChangeLog+  , createDirectories+  , createLibHs+  , createMainHs+  , createTestSuiteIfEligible+  , writeCabalFile++  -- * For testing+  , generateCabalFile+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import System.FilePath+  ( (</>), (<.>), takeExtension )++import Distribution.Types.Dependency+import Distribution.Types.VersionRange++import Data.Time+  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )+import System.Directory+  ( getCurrentDirectory, doesFileExist, copyFile+  , createDirectoryIfMissing )++import Text.PrettyPrint hiding ((<>), mode, cat)++import Distribution.Client.Init.Defaults+  ( defaultCabalVersion, myLibModule )+import Distribution.Client.Init.Licenses+  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )+import Distribution.Client.Init.Utils+  ( eligibleForTestSuite, message )+import Distribution.Client.Init.Types+  ( InitFlags(..), BuildType(..), PackageType(..) )++import Distribution.CabalSpecVersion+import Distribution.Compat.Newtype+  ( Newtype )+import Distribution.Fields.Field+  ( FieldName )+import Distribution.License+  ( licenseFromSPDX )+import qualified Distribution.ModuleName as ModuleName+  ( toFilePath )+import Distribution.FieldGrammar.Newtypes+  ( SpecVersion(..) )+import Distribution.PackageDescription.FieldGrammar+  ( formatDependencyList, formatExposedModules, formatHsSourceDirs,+    formatOtherExtensions, formatOtherModules, formatExtraSourceFiles )+import Distribution.Simple.Flag+  ( maybeToFlag )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Simple.Utils+  ( toUTF8BS )+import Distribution.Fields.Pretty+  ( PrettyField(..), showFields' )++import qualified Distribution.SPDX as SPDX+++---------------------------------------------------------------------------+--  File generation  ------------------------------------------------------+---------------------------------------------------------------------------++-- | Write the LICENSE file, as specified in the InitFlags license field.+--+-- For licences that contain the author's name(s), the values are taken+-- from the 'authors' field of 'InitFlags', and if not specified will+-- be the string "???".+--+-- If the license type is unknown no license file will be created and+-- a warning will be raised.+writeLicense :: InitFlags -> IO ()+writeLicense flags = do+  message flags "\nGenerating LICENSE..."+  year <- show <$> getCurrentYear+  let authors = fromMaybe "???" . flagToMaybe . author $ flags+  let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId+      isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid+      isSimpleLicense _                                                            = Nothing+  let licenseFile =+        case flagToMaybe (license flags) >>= isSimpleLicense of+          Just SPDX.BSD_2_Clause  -> Just $ bsd2 authors year+          Just SPDX.BSD_3_Clause  -> Just $ bsd3 authors year+          Just SPDX.Apache_2_0    -> Just apache20+          Just SPDX.MIT           -> Just $ mit authors year+          Just SPDX.MPL_2_0       -> Just mpl20+          Just SPDX.ISC           -> Just $ isc authors year++          -- GNU license come in "only" and "or-later" flavours+          -- license file used are the same.+          Just SPDX.GPL_2_0_only  -> Just gplv2+          Just SPDX.GPL_3_0_only  -> Just gplv3+          Just SPDX.LGPL_2_1_only -> Just lgpl21+          Just SPDX.LGPL_3_0_only -> Just lgpl3+          Just SPDX.AGPL_3_0_only -> Just agplv3++          Just SPDX.GPL_2_0_or_later  -> Just gplv2+          Just SPDX.GPL_3_0_or_later  -> Just gplv3+          Just SPDX.LGPL_2_1_or_later -> Just lgpl21+          Just SPDX.LGPL_3_0_or_later -> Just lgpl3+          Just SPDX.AGPL_3_0_or_later -> Just agplv3++          _ -> Nothing++  case licenseFile of+    Just licenseText -> writeFileSafe flags "LICENSE" licenseText+    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."++-- | Returns the current calendar year.+getCurrentYear :: IO Integer+getCurrentYear = do+  u <- getCurrentTime+  z <- getCurrentTimeZone+  let l = utcToLocalTime z u+      (y, _, _) = toGregorian $ localDay l+  return y++defaultChangeLog :: FilePath+defaultChangeLog = "CHANGELOG.md"++-- | Writes the changelog to the current directory.+writeChangeLog :: InitFlags -> IO ()+writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do+  message flags ("Generating "++ defaultChangeLog ++"...")+  writeFileSafe flags defaultChangeLog changeLog+ where+  changeLog = unlines+    [ "# Revision history for " ++ pname+    , ""+    , "## " ++ pver ++ " -- YYYY-mm-dd"+    , ""+    , "* First version. Released on an unsuspecting world."+    ]+  pname = maybe "" prettyShow $ flagToMaybe $ packageName flags+  pver = maybe "" prettyShow $ flagToMaybe $ version flags++-- | Creates and writes the initialized .cabal file.+--+-- Returns @False@ if no package name is specified, @True@ otherwise.+writeCabalFile :: InitFlags -> IO Bool+writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do+  message flags "Error: no package name provided."+  return False+writeCabalFile flags@(InitFlags{packageName = Flag p}) = do+  let cabalFileName = prettyShow p ++ ".cabal"+  message flags $ "Generating " ++ cabalFileName ++ "..."+  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)+  return True++-- | Write a file \"safely\", backing up any existing version (unless+--   the overwrite flag is set).+writeFileSafe :: InitFlags -> FilePath -> String -> IO ()+writeFileSafe flags fileName content = do+  moveExistingFile flags fileName+  writeFile fileName content++-- | Create directories, if they were given, and don't already exist.+createDirectories :: Maybe [String] -> IO ()+createDirectories mdirs = case mdirs of+  Just dirs -> for_ dirs (createDirectoryIfMissing True)+  Nothing   -> return ()++-- | Create MyLib.hs file, if its the only module in the liste.+createLibHs :: InitFlags -> IO ()+createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do+  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"+  case sourceDirs flags of+    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)+    _                -> writeLibHs flags modFilePath++-- | Write a MyLib.hs file if it doesn't already exist.+writeLibHs :: InitFlags -> FilePath -> IO ()+writeLibHs flags libPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let libFullPath = dir </> libPath+  exists <- doesFileExist libFullPath+  unless exists $ do+    message flags $ "Generating " ++ libPath ++ "..."+    writeFileSafe flags libFullPath myLibHs++-- | Default MyLib.hs file.  Used when no Lib.hs exists.+myLibHs :: String+myLibHs = unlines+  [ "module MyLib (someFunc) where"+  , ""+  , "someFunc :: IO ()"+  , "someFunc = putStrLn \"someFunc\""+  ]++-- | Create Main.hs, but only if we are init'ing an executable and+--   the mainIs flag has been provided.+createMainHs :: InitFlags -> IO ()+createMainHs flags =+  if hasMainHs flags then+    case applicationDirs flags of+      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)+      _ -> writeMainHs flags mainFile+  else return ()+  where+    mainFile = case mainIs flags of+      Flag x -> x+      NoFlag -> error "createMainHs: no mainIs"++-- | Write a main file if it doesn't already exist.+writeMainHs :: InitFlags -> FilePath -> IO ()+writeMainHs flags mainPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let mainFullPath = dir </> mainPath+  exists <- doesFileExist mainFullPath+  unless exists $ do+      message flags $ "Generating " ++ mainPath ++ "..."+      writeFileSafe flags mainFullPath (mainHs flags)++-- | Returns true if a main file exists.+hasMainHs :: InitFlags -> Bool+hasMainHs flags = case mainIs flags of+  Flag _ -> (packageType flags == Flag Executable+             || packageType flags == Flag LibraryAndExecutable)+  _ -> False++-- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.+--+--   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.+mainHs :: InitFlags -> String+mainHs flags = (unlines . map prependPrefix) $ case packageType flags of+  Flag LibraryAndExecutable ->+    [ "module Main where"+    , ""+    , "import qualified MyLib (someFunc)"+    , ""+    , "main :: IO ()"+    , "main = do"+    , "  putStrLn \"Hello, Haskell!\""+    , "  MyLib.someFunc"+    ]+  _ ->+    [ "module Main where"+    , ""+    , "main :: IO ()"+    , "main = putStrLn \"Hello, Haskell!\""+    ]+  where+    prependPrefix :: String -> String+    prependPrefix "" = ""+    prependPrefix line+      | isLiterate = "> " ++ line+      | otherwise  = line+    isLiterate = case mainIs flags of+      Flag mainPath -> takeExtension mainPath == ".lhs"+      _             -> False++-- | Create a test suite for the package if eligible.+createTestSuiteIfEligible :: InitFlags -> IO ()+createTestSuiteIfEligible flags =+  when (eligibleForTestSuite flags) $ do+    createDirectories (testDirs flags)+    createTestHs flags++-- | The name of the test file to generate (if --tests is specified).+testFile :: String+testFile = "MyLibTest.hs"++-- | Create MyLibTest.hs, but only if we are init'ing a library and+--   the initializeTestSuite flag has been set.+--+-- It is up to the caller to verify that the package is eligible+-- for test suite initialization (see eligibleForTestSuite).+createTestHs :: InitFlags -> IO ()+createTestHs flags =+  case testDirs flags of+    Just (testPath:_) -> writeTestHs flags (testPath </> testFile)+    _ -> writeMainHs flags testFile++-- | Write a test file.+writeTestHs :: InitFlags -> FilePath -> IO ()+writeTestHs flags testPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let testFullPath = dir </> testPath+  exists <- doesFileExist testFullPath+  unless exists $ do+      message flags $ "Generating " ++ testPath ++ "..."+      writeFileSafe flags testFullPath testHs++-- | Default MyLibTest.hs file.+testHs :: String+testHs = unlines+  [ "module Main (main) where"+  , ""+  , "main :: IO ()"+  , "main = putStrLn \"Test suite not yet implemented.\""+  ]+++-- | Move an existing file, if there is one, and the overwrite flag is+--   not set.+moveExistingFile :: InitFlags -> FilePath -> IO ()+moveExistingFile flags fileName =+  unless (overwrite flags == Flag True) $ do+    e <- doesFileExist fileName+    when e $ do+      newName <- findNewName fileName+      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName+      copyFile fileName newName+++-- | Given a file path find a new name for the file that does not+--   already exist.+findNewName :: FilePath -> IO FilePath+findNewName oldName = findNewName' 0+  where+    findNewName' :: Integer -> IO FilePath+    findNewName' n = do+      let newName = oldName <.> ("save" ++ show n)+      e <- doesFileExist newName+      if e then findNewName' (n+1) else return newName+++-- | Generate a .cabal file from an InitFlags structure.+generateCabalFile :: String -> InitFlags -> String+generateCabalFile fileName c =+    showFields' annCommentLines postProcessFieldLines 4 $ catMaybes+  [ fieldP "cabal-version" (Flag . SpecVersion $ specVer)+      []+      False++  , field "name" (packageName c)+      ["Initial package description '" ++ fileName ++ "' generated by",+       "'cabal init'. For further documentation, see:",+       "  http://haskell.org/cabal/users-guide/",+       "",+       "The name of the package."]+      True++  , field  "version"       (version       c)+           ["The package version.",+            "See the Haskell package versioning policy (PVP) for standards",+            "guiding when and how versions should be incremented.",+            "https://pvp.haskell.org",+            "PVP summary:      +-+------- breaking API changes",+            "                  | | +----- non-breaking API additions",+            "                  | | | +--- code changes with no API change"]+           True++  , fieldS "synopsis"      (synopsis      c)+           ["A short (one-line) description of the package."]+           True++  , fieldS "description"   NoFlag+           ["A longer description of the package."]+           True++  , fieldS "homepage"      (homepage     c)+           ["URL for the project homepage or repository."]+           False++  , fieldS "bug-reports"   NoFlag+           ["A URL where users can report bugs."]+           True++  , fieldS  "license"      licenseStr+                ["The license under which the package is released."]+                True++  , case license c of+      NoFlag         -> Nothing+      Flag SPDX.NONE -> Nothing+      _ -> fieldS "license-file" (Flag "LICENSE")+                  ["The file containing the license text."]+                  True++  , fieldS "author"        (author       c)+           ["The package author(s)."]+           True++  , fieldS "maintainer"    (email        c)+           ["An email address to which users can send suggestions, bug reports, and patches."]+           True++  , fieldS "copyright"     NoFlag+           ["A copyright notice."]+           True++  , fieldS "category"      (either id prettyShow `fmap` category c)+           []+           True++  , fieldS "build-type"    (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")+           []+           False++  , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))+           ["Extra files to be distributed with the package, such as examples or a README."]+           True+  ]+  +++  (case packageType c of+     Flag Executable -> [executableStanza]+     Flag Library    -> [libraryStanza]+     Flag LibraryAndExecutable -> [libraryStanza, executableStanza]+     _               -> [])+  +++  if eligibleForTestSuite c then [testSuiteStanza] else []++ where+   specVer :: CabalSpecVersion+   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)++   licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c+              | otherwise               = prettyShow                   <$> license c++   generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation]+   generateBuildInfo buildType c' = catMaybes+     [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)+       [ case buildType of+                 LibBuild    -> "Modules included in this library but not exported."+                 ExecBuild -> "Modules included in this executable, other than Main."]+       True++     , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))+       ["LANGUAGE extensions used by modules in this package."]+       True++     , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)+       ["Other library packages from which modules are imported."]+       True++     , fieldPAla "hs-source-dirs" formatHsSourceDirs+       (maybeToFlag (case buildType of+                                              LibBuild -> sourceDirs c+                                              ExecBuild -> applicationDirs c))+       ["Directories containing source files."]+       True++     , fieldS "build-tools" (listFieldS $ buildTools c)+       ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+       False++     , field "default-language" (language c)+       ["Base language which the package is written in."]+       True+     ]+     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).+     where+       buildDependencies :: Maybe [Dependency]+       buildDependencies = (++ myLibDep) <$> dependencies c'++       myLibDep :: [Dependency]+       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild+                      then case packageName c' of+                             Flag pkgName ->+                               [mkDependency pkgName anyVersion mainLibSet]+                             _ -> []+                  else []++       -- Only include 'MyLib' in 'other-modules' of the executable.+       otherModsFromFlag = otherModules c'+       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]+                   then Nothing+                   else otherModsFromFlag++   listFieldS :: Maybe [String] -> Flag String+   listFieldS Nothing = NoFlag+   listFieldS (Just []) = NoFlag+   listFieldS (Just xs) = Flag . intercalate ", " $ xs++   -- | Construct a 'PrettyField' from a field that can be automatically+   --   converted to a 'Doc' via 'display'.+   field :: Pretty t+         => FieldName+         -> Flag t+         -> [String]+         -> Bool+         -> Maybe (PrettyField FieldAnnotation)+   field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)++   -- | Construct a 'PrettyField' from a 'String' field.+   fieldS :: FieldName   -- ^ Name of the field+          -> Flag String -- ^ Field contents+          -> [String]    -- ^ Comment to explain the field+          -> Bool        -- ^ Should the field be included (commented out) even if blank?+          -> Maybe (PrettyField FieldAnnotation)+   fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag)++   -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.+   fieldP :: Pretty a+          => FieldName+          -> Flag a+          -> [String]+          -> Bool+          -> Maybe (PrettyField FieldAnnotation)+   fieldP fieldName fieldContentsFlag fieldComments includeField =+     fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField++   -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.+   fieldPAla+     :: (Pretty b, Newtype a b)+     => FieldName+     -> (a -> b)+     -> Flag a+     -> [String]+     -> Bool+     -> Maybe (PrettyField FieldAnnotation)+   fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =+     fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField++   -- | Construct a 'PrettyField' from a 'Doc' Flag.+   fieldD :: FieldName   -- ^ Name of the field+          -> Flag Doc    -- ^ Field contents+          -> [String]    -- ^ Comment to explain the field+          -> Bool        -- ^ Should the field be included (commented out) even if blank?+          -> Maybe (PrettyField FieldAnnotation)+   fieldD fieldName fieldContentsFlag fieldComments includeField =+     case fieldContentsFlag of+       NoFlag ->+         -- If there is no content, optionally produce a commented out field.+         fieldSEmptyContents fieldName fieldComments includeField++       Flag fieldContents ->+         if isEmpty fieldContents+         then+           -- If the doc is empty, optionally produce a commented out field.+           fieldSEmptyContents fieldName fieldComments includeField+         else+           -- If the doc is not empty, produce a field.+           Just $ case (noComments c, minimal c) of+             -- If the "--no-comments" flag is set, strip comments.+             (Flag True, _) ->+               fieldSWithContents fieldName fieldContents []+             -- If the "--minimal" flag is set, strip comments.+             (_, Flag True) ->+               fieldSWithContents fieldName fieldContents []+             -- Otherwise, include comments.+             (_, _) ->+               fieldSWithContents fieldName fieldContents fieldComments++   -- | Optionally produce a field with no content (depending on flags).+   fieldSEmptyContents :: FieldName+                       -> [String]+                       -> Bool+                       -> Maybe (PrettyField FieldAnnotation)+   fieldSEmptyContents fieldName fieldComments includeField+     | not includeField || (minimal c == Flag True) =+         Nothing+     | otherwise =+         Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty)++   -- | Produce a field with content.+   fieldSWithContents :: FieldName+                      -> Doc+                      -> [String]+                      -> PrettyField FieldAnnotation+   fieldSWithContents fieldName fieldContents fieldComments =+     PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents++   executableStanza :: PrettyField FieldAnnotation+   executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes+     [ fieldS "main-is" (mainIs c)+       [".hs or .lhs file containing the Main module."]+       True+     ]+     +++     generateBuildInfo ExecBuild c+     where+       exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)++   libraryStanza :: PrettyField FieldAnnotation+   libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes+     [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))+       ["Modules exported by the library."]+       True+     ]+     +++     generateBuildInfo LibBuild c+++   testSuiteStanza :: PrettyField FieldAnnotation+   testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes+     [ field "default-language" (language c)+       ["Base language which the package is written in."]+       True++     , fieldS "type" (Flag "exitcode-stdio-1.0")+       ["The interface type and version of the test suite."]+       True++     , fieldPAla "hs-source-dirs" formatHsSourceDirs+       (maybeToFlag (testDirs c))+       ["Directories containing source files."]+       True++     , fieldS "main-is" (Flag testFile)+       ["The entrypoint to the test suite."]+       True++     , fieldPAla  "build-depends" formatDependencyList (maybeToFlag (dependencies c))+       ["Test dependencies."]+       True+     ]+     where+       testSuiteName =+         text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)++-- | Annotations for cabal file PrettyField.+data FieldAnnotation = FieldAnnotation+  { annCommentedOut :: Bool+    -- ^ True iif the field and its contents should be commented out.+  , annCommentLines :: [String]+    -- ^ Comment lines to place before the field or section.+  }++-- | A field annotation instructing the pretty printer to comment out the field+--   and any contents, with no comments.+commentedOutWithComments :: [String] -> FieldAnnotation+commentedOutWithComments = FieldAnnotation True . map ("-- " ++)++-- | A field annotation with the specified comment lines.+withComments :: [String] -> FieldAnnotation+withComments = FieldAnnotation False++-- | A field annotation with no comments.+annNoComments :: FieldAnnotation+annNoComments = FieldAnnotation False []++postProcessFieldLines :: FieldAnnotation -> [String] -> [String]+postProcessFieldLines ann+  | annCommentedOut ann = map ("-- " ++)+  | otherwise = id
Distribution/Client/Init/Heuristics.hs view
@@ -24,7 +24,6 @@ import Distribution.Client.Compat.Prelude import Distribution.Utils.Generic (safeHead, safeTail, safeLast) -import Distribution.Parsec         (simpleParsec) import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName     ( ModuleName, toFilePath )@@ -38,14 +37,11 @@ import Distribution.Solver.Types.PackageIndex     ( allPackagesByName ) import Distribution.Solver.Types.SourcePackage-    ( packageDescription )+    ( srcpkgDescription )  import Distribution.Client.Types ( SourcePackageDb(..) )-import Control.Monad ( mapM )-import Data.Char   ( isNumber, isLower )-import Data.Either ( partitionEithers )+import Data.Char   ( isLower ) import Data.List   ( isInfixOf )-import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList ) import System.Directory ( getCurrentDirectory, getDirectoryContents,                           doesDirectoryExist, doesFileExist, getHomeDirectory, )@@ -55,7 +51,6 @@  import Distribution.Client.Init.Types     ( InitFlags(..) ) import Distribution.Client.Compat.Process ( readProcessWithExitCode )-import System.Exit ( ExitCode(..) )  import qualified Distribution.Utils.ShortText as ShortText @@ -104,8 +99,8 @@         x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'               in c ++ repairRest r       where-        repairComponent c | all isNumber c = invalid c-                          | otherwise      = valid c+        repairComponent c | all isDigit c = invalid c+                          | otherwise     = valid c     repairRest = repair' id ('-' :)  -- |Data type of source files found in the working directory@@ -132,12 +127,12 @@   where     scan dir hierarchy = do         entries <- getDirectoryContents (projectRoot </> dir)-        (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries)+        (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries)         let modules = catMaybes [ guessModuleName hierarchy file                                 | file <- files                                 , maybe False isUpper (safeHead file) ]-        modules' <- mapM (findImportsAndExts projectRoot) modules-        recMods <- mapM (scanRecursive dir hierarchy) dirs+        modules' <- traverse (findImportsAndExts projectRoot) modules+        recMods <- traverse (scanRecursive dir hierarchy) dirs         return $ concat (modules' : recMods)     tagIsDir parent entry = do         isDir <- doesDirectoryExist (parent </> entry)@@ -349,7 +344,7 @@ knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet     [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex)-          , let catList = (PD.category . PD.packageDescription . packageDescription) pkg+          , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg           , cat <- splitString ',' $ ShortText.fromShortText catList     ]
Distribution/Client/Init/Licenses.hs view
@@ -1,3 +1,13 @@+{-|+Module        :  Distribution.Client.Init.Licenses++Description   :  Factory functions for producing known license types.++License       :  BSD-like+Maintainer    :  cabal-devel@haskell.org+Stability     :  provisional+Portability   :  portable+-} module Distribution.Client.Init.Licenses   ( License   , bsd2@@ -12,6 +22,8 @@   , mpl20   , isc   ) where++import Prelude (String, unlines, (++))  type License = String
+ Distribution/Client/Init/Prompt.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Prompt+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- User prompt utility functions for use by the 'cabal init' command.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Prompt (++    -- * Commands+    prompt+  , promptYesNo+  , promptStr+  , promptList+  , promptListOptional+  , maybePrompt+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import Distribution.Client.Init.Types+  ( InitFlags(..) )+import Distribution.Simple.Setup+  ( Flag(..) )+++-- | Run a prompt or not based on the interactive flag of the+--   InitFlags structure.+maybePrompt :: InitFlags -> IO t -> IO (Maybe t)+maybePrompt flags p =+  case interactive flags of+    Flag True -> Just `fmap` p+    _         -> return Nothing++-- | Create a prompt with optional default value that returns a+--   String.+promptStr :: String -> Maybe String -> IO String+promptStr = promptDefault' Just id++-- | Create a yes/no prompt with optional default value.+promptYesNo :: String      -- ^ prompt message+            -> Maybe Bool  -- ^ optional default value+            -> IO Bool+promptYesNo =+    promptDefault' recogniseYesNo showYesNo+  where+    recogniseYesNo s | s == "y" || s == "Y" = Just True+                     | s == "n" || s == "N" = Just False+                     | otherwise            = Nothing+    showYesNo True  = "y"+    showYesNo False = "n"++-- | Create a prompt with optional default value that returns a value+--   of some Text instance.+prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t+prompt = promptDefault' simpleParsec prettyShow++-- | Create a prompt with an optional default value.+promptDefault' :: (String -> Maybe t)       -- ^ parser+               -> (t -> String)             -- ^ pretty-printer+               -> String                    -- ^ prompt message+               -> Maybe t                   -- ^ optional default value+               -> IO t+promptDefault' parser ppr pr def = do+  putStr $ mkDefPrompt pr (ppr `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d)  -> return d+    _  -> case parser inp of+            Just t  -> return t+            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"+                          promptDefault' parser ppr pr def++-- | Create a prompt from a prompt string and a String representation+--   of an optional default value.+mkDefPrompt :: String -> Maybe String -> String+mkDefPrompt pr def = pr ++ "?" ++ defStr def+  where defStr Nothing  = " "+        defStr (Just s) = " [default: " ++ s ++ "] "++-- | Create a prompt from a list of items, where no selected items is+--   valid and will be represented as a return value of 'Nothing'.+promptListOptional :: (Pretty t, Eq t)+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> IO (Maybe (Either String t))+promptListOptional pr choices = promptListOptional' pr choices prettyShow++promptListOptional' :: Eq t+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> (t -> String)     -- ^ show an item+                   -> IO (Maybe (Either String t))+promptListOptional' pr choices displayItem =+    fmap rearrange+  $ promptList pr (Nothing : map Just choices) (Just Nothing)+               (maybe "(none)" displayItem) True+  where+    rearrange = either (Just . Left) (fmap Right)++-- | Create a prompt from a list of items.+promptList :: Eq t+           => String            -- ^ prompt+           -> [t]               -- ^ choices+           -> Maybe t           -- ^ optional default value+           -> (t -> String)     -- ^ show an item+           -> Bool              -- ^ whether to allow an 'other' option+           -> IO (Either String t)+promptList pr choices def displayItem other = do+  putStrLn $ pr ++ ":"+  let options1 = map (\c -> (Just c == def, displayItem c)) choices+      options2 = zip ([1..]::[Int])+                     (options1 ++ [(False, "Other (specify)") | other])+  traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2+  promptList' displayItem (length options2) choices def other+ where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest+                      | otherwise = " " ++ star i ++ rest+                  where rest = show n ++ ") "+                        star True = "*"+                        star False = " "++promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' displayItem numChoices choices def other = do+  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d) -> return $ Right d+    _  -> case readMaybe inp of+            Nothing -> invalidChoice inp+            Just n  -> getChoice n+ where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."+                              promptList' displayItem numChoices choices def other+       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)+                   | n < numChoices ||+                     (n == numChoices && not other)+                                  = return . Right $ choices !! (n-1)+                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing
Distribution/Client/Init/Types.hs view
@@ -15,23 +15,23 @@ ----------------------------------------------------------------------------- module Distribution.Client.Init.Types where -import Distribution.Simple.Setup-  ( Flag(..) )+import Distribution.Client.Compat.Prelude+import Prelude () +import Distribution.Simple.Setup (Flag(..), toFlag )+ import Distribution.Types.Dependency as P-import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity import qualified Distribution.Package as P-import Distribution.License+import Distribution.SPDX.License (License) import Distribution.ModuleName+import Distribution.CabalSpecVersion import Language.Haskell.Extension ( Language(..), Extension )  import qualified Text.PrettyPrint as Disp-import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Deprecated.Text--import GHC.Generics ( Generic )+import qualified Distribution.Compat.CharParsing as P+import qualified Data.Map as Map  -- | InitFlags is really just a simple type to represent certain --   portions of a .cabal file.  Rather than have a flag for EVERY@@ -48,7 +48,7 @@                , packageName  :: Flag P.PackageName               , version      :: Flag Version-              , cabalVersion :: Flag Version+              , cabalVersion :: Flag CabalSpecVersion               , license      :: Flag License               , author       :: Flag String               , email        :: Flag String@@ -103,7 +103,12 @@ instance Semigroup InitFlags where   (<>) = gmappend --- | Some common package categories.+defaultInitFlags :: InitFlags+defaultInitFlags  = mempty+    { initVerbosity = toFlag normal+    }++-- | Some common package categories (non-exhaustive list). data Category     = Codec     | Concurrency@@ -124,6 +129,14 @@     | Web     deriving (Read, Show, Eq, Ord, Bounded, Enum) -instance Text Category where-  disp  = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse+instance Pretty Category where+  pretty = Disp.text . show++instance Parsec Category where+  parsec = do+    name <- P.munch1 isAlpha+    case Map.lookup name names of+      Just cat -> pure cat+      _        -> P.unexpected $ "Category: " ++ name+    where+      names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ]
+ Distribution/Client/Init/Utils.hs view
@@ -0,0 +1,38 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Utils+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Shared utilities used by multiple cabal init modules.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Utils (+    eligibleForTestSuite+  , message+  ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Simple.Setup+  ( Flag(..) )+import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..) )++-- | Returns true if this package is eligible for test suite initialization.+eligibleForTestSuite :: InitFlags -> Bool+eligibleForTestSuite flags =+  Flag True == initializeTestSuite flags+  && Flag Executable /= packageType flags++-- | Possibly generate a message to stdout, taking into account the+--   --quiet flag.+message :: InitFlags -> String -> IO ()+message (InitFlags{quiet = Flag True}) _ = return ()+message _ s = putStrLn s
Distribution/Client/Install.hs view
@@ -35,20 +35,8 @@  import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map-import qualified Data.Set as S import Control.Exception as Exception-         ( Exception(toException), bracket, catches-         , Handler(Handler), handleJust, IOException, SomeException )-#ifndef mingw32_HOST_OS-import Control.Exception as Exception-         ( Exception(fromException) )-#endif-import System.Exit-         ( ExitCode(..) )-import Distribution.Compat.Exception-         ( catchIO, catchExit )-import Control.Monad-         ( forM_, mapM )+         ( bracket, catches, Handler(Handler), handleJust ) import System.Directory          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,            createDirectoryIfMissing, removeFile, renameDirectory,@@ -84,22 +72,19 @@          , filterTestFlags ) import Distribution.Client.Config          ( getCabalDir, defaultUserInstall )-import Distribution.Client.Sandbox.Timestamp-         ( withUpdateTimestamps )-import Distribution.Client.Sandbox.Types-         ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox-         , whenUsingSandbox ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.BuildReports.Anonymous (showBuildReport) import qualified Distribution.Client.BuildReports.Anonymous as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports          ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink-         ( OverwritePolicy(..), symlinkBinaries )+         ( symlinkBinaries )+import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed@@ -134,8 +119,7 @@          , registerCommand, RegisterFlags(..), emptyRegisterFlags          , testCommand, TestFlags(..) ) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, comparing-         , writeFileAtomic )+         ( createDirectoryIfMissingVerbose, writeFileAtomic ) import Distribution.Simple.InstallDirs as InstallDirs          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate          , initialPathTemplateEnv, installDirsTemplateEnv )@@ -146,18 +130,18 @@          , Package(..), HasMungedPackageId(..), HasUnitId(..)          , UnitId ) import Distribution.Types.Dependency-         ( thisPackageVersion )+         ( Dependency (..), mainLibSet ) import Distribution.Types.GivenComponent          ( GivenComponent(..) )-import Distribution.Pretty ( prettyShow ) import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..) )+         ( PackageVersionConstraint(..), thisPackageVersionConstraint ) import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription-         ( PackageDescription, GenericPackageDescription(..), Flag(..)-         , FlagAssignment, mkFlagAssignment, unFlagAssignment-         , showFlagValue, diffFlagAssignment, nullFlagAssignment )+         ( PackageDescription, GenericPackageDescription(..) )+import Distribution.Types.Flag+         ( PackageFlag(..), FlagAssignment, mkFlagAssignment+         , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePD ) import Distribution.Version@@ -167,11 +151,11 @@          , withTempDirectory ) import Distribution.Client.Utils          ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)-         , tryCanonicalizePath, ProgressPhase(..), progressMessage )+         , ProgressPhase(..), progressMessage ) import Distribution.System          ( Platform, OS(Windows), buildOS, buildPlatform ) import Distribution.Verbosity as Verbosity-         ( Verbosity, modifyVerbosity, normal, verbose )+         ( modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension )  import qualified Data.ByteString as BS@@ -201,8 +185,6 @@   -> Compiler   -> Platform   -> ProgramDb-  -> UseSandbox-  -> Maybe SandboxPackageInfo   -> GlobalFlags   -> ConfigFlags   -> ConfigExFlags@@ -212,7 +194,7 @@   -> BenchmarkFlags   -> [UserTarget]   -> IO ()-install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo+install verbosity packageDBs repos comp platform progdb   globalFlags configFlags configExFlags installFlags   haddockFlags testFlags benchmarkFlags userTargets0 = do @@ -222,7 +204,6 @@         ++ " (if you didn't type --root-cmd, comment out root-cmd"         ++ " in your ~/.cabal/config file)"     let userOrSandbox = fromFlag (configUserInstall configFlags)-                     || isUseSandbox useSandbox     unless userOrSandbox $         warn verbosity $ "the --global flag is deprecated -- "         ++ "it is generally considered a bad idea to install packages "@@ -240,18 +221,12 @@             processInstallPlan verbosity args installContext installPlan   where     args :: InstallArgs-    args = (packageDBs, repos, comp, platform, progdb, useSandbox,-            mSandboxPkgInfo, globalFlags, configFlags, configExFlags,+    args = (packageDBs, repos, comp, platform, progdb,+            globalFlags, configFlags, configExFlags,             installFlags, haddockFlags, testFlags, benchmarkFlags) -    die'' message = die' verbosity (message ++ if isUseSandbox useSandbox-                                   then installFailedInSandbox else [])-    -- TODO: use a better error message, remove duplication.-    installFailedInSandbox =-      "\nNote: when using a sandbox, all packages are required to have "-      ++ "consistent dependencies. "-      ++ "Try reinstalling/unregistering the offending packages or "-      ++ "recreating the sandbox."+    die'' = die' verbosity+     logMsg message rest = debugNoWrap verbosity message >> rest  -- TODO: Make InstallContext a proper data type with documented fields.@@ -269,8 +244,6 @@                    , Compiler                    , Platform                    , ProgramDb-                   , UseSandbox-                   , Maybe SandboxPackageInfo                    , GlobalFlags                    , ConfigFlags                    , ConfigExFlags@@ -283,14 +256,14 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]                       -> IO InstallContext makeInstallContext verbosity-  (packageDBs, repoCtxt, comp, _, progdb,_,_,+  (packageDBs, repoCtxt, comp, _, progdb,    globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do      let idxState = flagToMaybe (installIndexState installFlags) -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-    sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState-    pkgConfigDb       <- readPkgConfigDb      verbosity progdb+    installedPkgIndex   <- getInstalledPackages verbosity comp packageDBs progdb+    (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing+    pkgConfigDb         <- readPkgConfigDb      verbosity progdb      checkConfigExFlags verbosity installedPkgIndex                        (packageIndex sourcePkgDb) configExFlags@@ -321,7 +294,7 @@ makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext                 -> IO (Progress String String SolverInstallPlan) makeInstallPlan verbosity-  (_, _, comp, platform, _, _, mSandboxPkgInfo,+  (_, _, comp, platform,_,    _, configFlags, configExFlags, installFlags,    _, _, _)   (installedPkgIndex, sourcePkgDb, pkgConfigDb,@@ -330,7 +303,7 @@     solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))               (compilerInfo comp)     notice verbosity "Resolving dependencies..."-    return $ planPackages verbosity comp platform mSandboxPkgInfo solver+    return $ planPackages verbosity comp platform solver           configFlags configExFlags installFlags           installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers @@ -339,7 +312,7 @@                    -> SolverInstallPlan                    -> IO () processInstallPlan verbosity-  args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _, _)+  args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _)   (installedPkgIndex, sourcePkgDb, _,    userTargets, pkgSpecifiers, _) installPlan0 = do @@ -362,7 +335,6 @@ planPackages :: Verbosity              -> Compiler              -> Platform-             -> Maybe SandboxPackageInfo              -> Solver              -> ConfigFlags              -> ConfigExFlags@@ -372,7 +344,7 @@              -> PkgConfigDb              -> [PackageSpecifier UnresolvedSourcePackage]              -> Progress String String SolverInstallPlan-planPackages verbosity comp platform mSandboxPkgInfo solver+planPackages verbosity comp platform solver              configFlags configExFlags installFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = @@ -445,8 +417,6 @@             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | pkgSpecifier <- pkgSpecifiers ] -      . maybe id applySandboxInstallPolicy mSandboxPkgInfo-       . (if reinstall then reinstallTargets else id)          -- Don't solve for executables, the legacy install codepath@@ -602,8 +572,8 @@   when offline $ do     let pkgs = [ confPkgSource cpkg                | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]-    notFetched <- fmap (map packageInfoId)-                  . filterM (fmap isNothing . checkFetched . packageSource)+    notFetched <- fmap (map packageId)+                  . filterM (fmap isNothing . checkFetched . srcpkgSource)                   $ pkgs     unless (null notFetched) $       die' verbosity $ "Can't download packages in offline mode. "@@ -685,24 +655,26 @@     showPkg (pkg, _) = prettyShow (packageId pkg) ++                        showLatest (pkg) -    showPkgAndReason (ReadyPackage pkg', pr) = prettyShow (packageId pkg') ++-          showLatest pkg' ++-          showFlagAssignment (nonDefaultFlags pkg') ++-          showStanzas (confPkgStanzas pkg') ++-          showDep pkg' ++-          case pr of-            NewPackage     -> " (new package)"-            NewVersion _   -> " (new version)"-            Reinstall _ cs -> " (reinstall)" ++ case cs of+    showPkgAndReason (ReadyPackage pkg', pr) = unwords+        [ prettyShow (packageId pkg')+        , showLatest pkg'+        , showFlagAssignment (nonDefaultFlags pkg')+        , showStanzas (confPkgStanzas pkg')+        , showDep pkg'+        , case pr of+            NewPackage     -> "(new package)"+            NewVersion _   -> "(new version)"+            Reinstall _ cs -> "(reinstall)" ++ case cs of                 []   -> ""-                diff -> " (changes: "  ++ intercalate ", " (map change diff)+                diff -> "(changes: "  ++ intercalate ", " (map change diff)                         ++ ")"+        ]      showLatest :: Package srcpkg => srcpkg -> String     showLatest pkg = case mLatestVersion of         Just latestVersion ->             if packageVersion pkg < latestVersion-            then (" (latest: " ++ prettyShow latestVersion ++ ")")+            then ("(latest: " ++ prettyShow latestVersion ++ ")")             else ""         Nothing -> ""       where@@ -713,22 +685,19 @@                            (packageIndex sourcePkgDb)                            (packageName pkg) -    toFlagAssignment :: [Flag] -> FlagAssignment+    toFlagAssignment :: [PackageFlag] -> FlagAssignment     toFlagAssignment =  mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))      nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment     nonDefaultFlags cpkg =       let defaultAssignment =             toFlagAssignment-             (genPackageFlags (SourcePackage.packageDescription $+             (genPackageFlags (SourcePackage.srcpkgDescription $                                confPkgSource cpkg))       in  confPkgFlags cpkg `diffFlagAssignment` defaultAssignment      showStanzas :: [OptionalStanza] -> String-    showStanzas = concatMap ((" *" ++) . showStanza)--    showFlagAssignment :: FlagAssignment -> String-    showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment+    showStanzas = unwords . map (("*" ++) . showStanza)      change (OnlyInLeft pkgid)        = prettyShow pkgid ++ " removed"     change (InBoth     pkgid pkgid') = prettyShow pkgid ++ " -> "@@ -762,7 +731,7 @@ reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String                       -> IO () reportPlanningFailure verbosity-  (_, _, comp, platform, _, _, _+  (_, _, comp, platform, _   ,_, configFlags, _, installFlags, _, _, _)   (_, sourcePkgDb, _, _, pkgSpecifiers, _)   message = do@@ -791,7 +760,7 @@     -- Save solver log     case logFile of       Nothing -> return ()-      Just template -> forM_ pkgids $ \pkgid ->+      Just template -> for_ pkgids $ \pkgid ->         let env = initialPathTemplateEnv pkgid dummyIpid                     (compilerInfo comp) platform             path = fromPathTemplate $ substPathTemplate env template@@ -842,18 +811,15 @@                    -> BuildOutcomes                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo+  (packageDBs, _, comp, platform, progdb   ,globalFlags, configFlags, _, installFlags, _, _, _)   targets installPlan buildOutcomes = do -  updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo-                              comp platform installPlan buildOutcomes-   unless oneShot $     World.insert verbosity worldFile       --FIXME: does not handle flags-      [ World.WorldPkgInfo dep mempty-      | UserTargetNamed dep <- targets ]+      [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty+      | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ]    let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)                                                   installPlan buildOutcomes@@ -866,7 +832,7 @@   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+  regenerateHaddockIndex verbosity packageDBs comp platform progdb                          configFlags installFlags buildOutcomes    symlinkBinaries verbosity platform comp configFlags installFlags@@ -886,13 +852,13 @@   [ do dotCabal <- getCabalDir        let logFileName = prettyShow (BuildReports.package report) <.> "log"            logFile     = logsDir </> logFileName-           reportsDir  = dotCabal </> "reports" </> remoteRepoName remoteRepo+           reportsDir  = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)            reportFile  = reportsDir </> logFileName         handleMissingLogFile $ do          buildLog <- readFile logFile          createDirectoryIfMissing True reportsDir -- FIXME-         writeFile reportFile (show (BuildReports.show report, buildLog))+         writeFile reportFile (show (showBuildReport report, buildLog))    | (report, Just repo) <- reports   , Just remoteRepo <- [maybeRepoRemote repo]@@ -919,12 +885,11 @@                        -> Compiler                        -> Platform                        -> ProgramDb-                       -> UseSandbox                        -> ConfigFlags                        -> InstallFlags                        -> BuildOutcomes                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+regenerateHaddockIndex verbosity packageDBs comp platform progdb                        configFlags installFlags buildOutcomes   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -952,8 +917,7 @@     -- installed. Since the index can be only per-user or per-sandbox (see     -- #1337), we don't do it for global installs or special cases where we're     -- installing into a specific db.-    shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall)-                                && someDocsWereInstalled buildOutcomes+    shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes       where         someDocsWereInstalled = any installedDocs . Map.elems         installedDocs (Right (BuildResult DocsOk _ _)) = True@@ -987,7 +951,7 @@ symlinkBinaries verbosity platform comp configFlags installFlags                 plan buildOutcomes = do   failed <- InstallSymlink.symlinkBinaries platform comp-                                           InstallSymlink.NeverOverwrite+                                           NeverOverwrite                                            configFlags installFlags                                            plan buildOutcomes   case failed of@@ -1051,33 +1015,6 @@     onExitFailure _               = "" #endif ---- | If we're working inside a sandbox and some add-source deps were installed,--- update the timestamps of those deps.-updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo-                            -> Compiler -> Platform-                            -> InstallPlan-                            -> BuildOutcomes-                            -> IO ()-updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir)-                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))-                            comp platform installPlan buildOutcomes =-  withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do-    let allInstalled = [ pkg-                       | InstallPlan.Configured pkg-                            <- InstallPlan.toList installPlan-                       , case InstallPlan.lookupBuildOutcome pkg buildOutcomes of-                           Just (Right _success) -> True-                           _                     -> False-                       ]-        allSrcPkgs   = [ confPkgSource cpkg | cpkg <- allInstalled ]-        allPaths     = [ pth | LocalUnpackedPackage pth-                            <- map packageSource allSrcPkgs]-    allPathsCanonical <- mapM tryCanonicalizePath allPaths-    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical--updateSandboxTimestampsFile _ _ _ _ _ _ _ = return ()- -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------@@ -1096,16 +1033,11 @@                      -> InstallPlan                      -> IO BuildOutcomes performInstallations verbosity-  (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _,+  (packageDBs, repoCtxt, comp, platform, progdb,    globalFlags, configFlags, configExFlags, installFlags,    haddockFlags, testFlags, _)   installedPkgIndex installPlan = do -  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.-  whenUsingSandbox useSandbox $ \sandboxDir ->-    when parallelInstall $-      notice verbosity $ "Notice: installing into a sandbox located at "-                         ++ sandboxDir   info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."    jobControl   <- if parallelInstall then newParallelJobControl numJobs@@ -1266,7 +1198,7 @@     -- We generate the legacy constraints as well as the new style precise deps.     -- In the end only one set gets passed to Setup.hs configure, depending on     -- the Cabal version we are talking to.-    configConstraints  = [ thisPackageVersion srcid+    configConstraints  = [ thisPackageVersionConstraint srcid                          | ConfiguredId                              srcid                              (Just@@ -1472,7 +1404,7 @@             let packageDBs = interpretPackageDbFlags                                 (fromFlag (configUserInstall configFlags))                                 (configPackageDBs configFlags)-            forM_ ipkgs' $ \ipkg' ->+            for_ ipkgs' $ \ipkg' ->                 registerPackage verbosity comp progdb                                 packageDBs ipkg'                                 defaultRegisterOptions@@ -1549,7 +1481,7 @@           if is_dir             -- Sort so that each prefix of the package             -- configurations is well formed-            then mapM (readPkgConf pkgConfDest) . sort . filter notHidden+            then traverse (readPkgConf pkgConfDest) . sort . filter notHidden                     =<< getDirectoryContents pkgConfDest             else fmap (:[]) $ readPkgConf "." pkgConfDest       else return []
Distribution/Client/InstallPlan.hs view
@@ -83,8 +83,7 @@          , HasUnitId(..), UnitId ) import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl-import Distribution.Deprecated.Text-import Distribution.Pretty (prettyShow)+import Distribution.Pretty (defaultStyle) import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan)@@ -286,9 +285,9 @@     vcat (map dispPlanPackage (Foldable.toList graph))   where dispPlanPackage p =             hang (hsep [ text (showPlanPackageTag p)-                       , disp (packageId p)-                       , parens (disp (nodeKey p))]) 2-                 (vcat (map disp (nodeNeighbors p)))+                       , pretty (packageId p)+                       , parens (pretty (nodeKey p))]) 2+                 (vcat (map pretty (nodeNeighbors p)))  showInstallPlan :: (Package ipkg, Package srcpkg,                     IsUnit ipkg, IsUnit srcpkg)@@ -467,10 +466,10 @@      mapDep _ ipiMap (PreExistingId _pid uid)         | Just pkgs <- Map.lookup uid ipiMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)     mapDep pidMap _ (PlannedId pid)         | Just pkgs <- Map.lookup pid pidMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)     -- This shouldn't happen, since mapDep should only be called     -- on neighbor SolverId, which must have all been done already     -- by the reverse top-sort (we assume the graph is not broken).@@ -500,10 +499,10 @@      mapDep _ ipiMap (PreExistingId _pid uid)         | Just pkgs <- Map.lookup uid ipiMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)     mapDep pidMap _ (PlannedId pid)         | Just pkgs <- Map.lookup pid pidMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)     -- This shouldn't happen, since mapDep should only be called     -- on neighbor SolverId, which must have all been done already     -- by the reverse top-sort (we assume the graph is not broken).@@ -897,17 +896,17 @@ showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)                 => PlanProblem ipkg srcpkg -> String showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (nodeKey pkg)+     "Package " ++ prettyShow (nodeKey pkg)   ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map display missingDeps)+  ++ intercalate ", " (map prettyShow missingDeps)  showPlanProblem (PackageCycle cycleGroup) =      "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display . nodeKey) cycleGroup)+  ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (nodeKey pkg)+     "Package " ++ prettyShow (nodeKey pkg)   ++ " is in the " ++ showPlanPackageTag pkg-  ++ " state but it depends on package " ++ display (nodeKey pkg')+  ++ " state but it depends on package " ++ prettyShow (nodeKey pkg')   ++ " which is in the " ++ showPlanPackageTag pkg'   ++ " state"
Distribution/Client/InstallSymlink.hs view
@@ -13,54 +13,13 @@ -- Managing installing binaries with symlinks. ----------------------------------------------------------------------------- module Distribution.Client.InstallSymlink (-    OverwritePolicy(..),     symlinkBinaries,     symlinkBinary,+    trySymlink,   ) where -#ifdef mingw32_HOST_OS--import Distribution.Compat.Binary-         ( Binary )-import Distribution.Utils.Structured-         ( Structured )--import Distribution.Package (PackageIdentifier)-import Distribution.Types.UnqualComponentName-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.Types (BuildOutcomes)-import Distribution.Client.Setup (InstallFlags)-import Distribution.Simple.Setup (ConfigFlags)-import Distribution.Simple.Compiler-import Distribution.System-import GHC.Generics (Generic)--data OverwritePolicy = NeverOverwrite | AlwaysOverwrite-  deriving (Show, Eq, Generic, Bounded, Enum)--instance Binary OverwritePolicy-instance Structured OverwritePolicy--symlinkBinaries :: Platform -> Compiler-                -> OverwritePolicy-                -> ConfigFlags-                -> InstallFlags-                -> InstallPlan-                -> BuildOutcomes-                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]-symlinkBinaries _ _ _ _ _ _ _ = return []--symlinkBinary :: OverwritePolicy-              -> FilePath -> FilePath -> FilePath -> String-              -> IO Bool-symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows"--#else--import Distribution.Compat.Binary-         ( Binary )-import Distribution.Utils.Structured-         ( Structured )+import Distribution.Client.Compat.Prelude hiding (ioError)+import Prelude ()  import Distribution.Client.Types          ( ConfiguredPackage(..), BuildOutcomes )@@ -89,33 +48,23 @@          ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System          ( Platform )-import Distribution.Deprecated.Text-         ( display )+import Distribution.Simple.Utils ( info, withTempDirectory ) -import System.Posix.Files-         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink-         , removeLink ) import System.Directory-         ( canonicalizePath )+         ( canonicalizePath, getTemporaryDirectory, removeFile ) import System.FilePath          ( (</>), splitPath, joinPath, isAbsolute ) -import Prelude hiding (ioError) import System.IO.Error          ( isDoesNotExistError, ioError )-import Distribution.Compat.Exception ( catchIO ) import Control.Exception          ( assert )-import Data.Maybe-         ( catMaybes )-import GHC.Generics-         ( Generic ) -data OverwritePolicy = NeverOverwrite | AlwaysOverwrite-  deriving (Show, Eq, Generic, Bounded, Enum)+import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )+import Distribution.Client.Types.OverwritePolicy -instance Binary OverwritePolicy-instance Structured OverwritePolicy+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8  -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically@@ -155,12 +104,12 @@       publicBinDir  <- canonicalizePath symlinkBinDir --    TODO: do we want to do this here? : --      createDirectoryIfMissing True publicBinDir-      fmap catMaybes $ sequence+      fmap catMaybes $ sequenceA         [ do privateBinDir <- pkgBinDir pkg ipid              ok <- symlinkBinary                      overwritePolicy                      publicBinDir  privateBinDir-                     (display publicExeName) privateExeName+                     (prettyShow publicExeName) privateExeName              if ok                then return Nothing                else return (Just (pkgid, publicExeName,@@ -185,11 +134,11 @@       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ] -    pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _)+    pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _)                                       flags stanzas _) =       case finalizePD flags (enableStanzas stanzas)              (const True)-             platform cinfo [] pkg of+             platform cinfo [] gpd of         Left _ -> error "finalizePD ReadyPackage failed"         Right (desc, _) -> desc @@ -220,6 +169,10 @@     cinfo            = compilerInfo comp     (CompilerId compilerFlavor _) = compilerInfoId cinfo +-- | Symlink binary.+--+-- The paths are take in pieces, so we can make relative link when possible.+-- symlinkBinary ::   OverwritePolicy        -- ^ Whether to force overwrite an existing file   -> FilePath            -- ^ The canonical path of the public bin dir eg@@ -246,9 +199,8 @@         AlwaysOverwrite -> rmLink >> mkLink >> return True   where     relativeBindir = makeRelative publicBindir privateBindir-    mkLink = createSymbolicLink (relativeBindir </> privateName)-                                (publicBindir   </> publicName)-    rmLink = removeLink (publicBindir </> publicName)+    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)+    rmLink = removeFile (publicBindir </> publicName)  -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or@@ -260,11 +212,11 @@                                 -- Use 'canonicalizePath' to make this.                     -> IO SymlinkStatus targetOkToOverwrite symlink target = handleNotExist $ do-  status <- getSymbolicLinkStatus symlink-  if not (isSymbolicLink status)+  isLink <- pathIsSymbolicLink symlink+  if not isLink     then return NotOurFile-    else do target' <- canonicalizePath symlink-            -- This relies on canonicalizePath handling symlinks+    else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink+            -- This partially relies on canonicalizePath handling symlinks             if target == target'               then return OkToOverwrite               else return NotOurFile@@ -296,4 +248,27 @@    in joinPath $ [ ".." | _  <- drop commonLen as ]               ++ drop commonLen bs -#endif+-- | Try to make a symlink in a temporary directory.+--+-- If this works, we can try to symlink: even on Windows.+--+trySymlink :: Verbosity -> IO Bool+trySymlink verbosity = do+  tmp <- getTemporaryDirectory+  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do+    let from = tmpDirPath </> "file.txt"+    let to   = tmpDirPath </> "file2.txt"++    -- create a file+    BS.writeFile from (BS8.pack "TEST")++    -- create a symbolic link+    let create :: IO Bool+        create = do+          createFileLink from to+          info verbosity $ "Symlinking seems to work"+          return True++    create `catchIO` \exc -> do+      info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc+      return False
Distribution/Client/JobControl.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.JobControl@@ -28,13 +29,17 @@     criticalSection   ) where -import Control.Monad+import Distribution.Client.Compat.Prelude+import Prelude ()++import Control.Monad (forever, replicateM_) import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan-import Control.Exception (SomeException, bracket_, throwIO, try)+import Control.Exception (bracket_, try)+import Distribution.Compat.Stack import Distribution.Client.Compat.Semaphore  @@ -96,7 +101,7 @@ -- that have already been executed or are currently executing cannot be -- cancelled. ---newParallelJobControl :: Int -> IO (JobControl IO a)+newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a)) newParallelJobControl n | n < 1 || n > 1000 =   error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n newParallelJobControl maxJobLimit = do
Distribution/Client/List.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.List@@ -13,6 +14,9 @@   list, info   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package          ( PackageName, Package(..), packageName          , packageVersion, UnitId )@@ -22,26 +26,23 @@ import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.PackageDescription   as Source+import qualified Distribution.Types.ModuleReexport as Source import Distribution.PackageDescription-         ( Flag(..), unFlagName )+         ( PackageFlag(..), unFlagName ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )-import Distribution.Pretty (pretty)  import Distribution.Simple.Compiler         ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils-        ( equating, comparing, die', notice )-import Distribution.Simple.Setup (fromFlag)+        ( equating, die', notice )+import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Version          ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion          , intersectVersionRanges, simplifyVersionRange )-import Distribution.Verbosity (Verbosity)-import Distribution.Deprecated.Text-         ( Text(disp), display )  import qualified Distribution.SPDX as SPDX @@ -63,64 +64,71 @@ import Distribution.Client.FetchUtils          ( isFetched ) +import Data.Bits ((.|.)) import Data.List-         ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )+         ( maximumBy )+import Data.List.NonEmpty (groupBy, nonEmpty)+import qualified Data.List as L import Data.Maybe-         ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList )+         ( fromJust ) import qualified Data.Map as Map import Data.Tree as Tree-import Control.Monad-         ( MonadPlus(mplus), join ) import Control.Exception          ( assert )-import Text.PrettyPrint as Disp+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( lineLength, ribbonsPerLine, Doc, renderStyle, char+         , nest, ($+$), text, vcat, style, parens, fsep) import System.Directory          ( doesDirectoryExist )  import Distribution.Utils.ShortText (ShortText) import qualified Distribution.Utils.ShortText as ShortText+import qualified Text.Regex.Base as Regex+import qualified Text.Regex.Posix.String as Regex   -- | Return a list of packages matching given search strings. getPkgList :: Verbosity            -> PackageDBStack            -> RepoContext-           -> Compiler-           -> ProgramDb+           -> Maybe (Compiler, ProgramDb)            -> ListFlags            -> [String]            -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do-    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do+    installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->+        getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt++    regexps <- for pats $ \pat -> do+        e <- Regex.compile compOption Regex.execBlank pat+        case e of+            Right r  -> return r+            Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err+     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb)) +        pkgsInfoMatching ::+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]+        pkgsInfoMatching =+          let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex+              matchingSource    = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex+          in mergePackages matchingInstalled matchingSource+         pkgsInfo ::           [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]         pkgsInfo             -- gather info for all packages-          | null pats = mergePackages-                        (InstalledPackageIndex.allPackages installedPkgIndex)-                        (         PackageIndex.allPackages sourcePkgIndex)+          | null regexps = mergePackages+                           (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)+                           (         PackageIndex.allPackages          sourcePkgIndex)              -- gather info for packages matching search term           | otherwise = pkgsInfoMatching -        pkgsInfoMatching ::-          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]-        pkgsInfoMatching =-          let matchingInstalled = matchingPackages-                                  InstalledPackageIndex.searchByNameSubstring-                                  installedPkgIndex-              matchingSource   = matchingPackages-                                 (\ idx n ->-                                   concatMap snd-                                   (PackageIndex.searchByNameSubstring idx n))-                                 sourcePkgIndex-          in mergePackages matchingInstalled matchingSource-         matches :: [PackageDisplayInfo]         matches = [ mergePackageInfo pref                       installedPkgs sourcePkgs selectedPkg False@@ -130,28 +138,32 @@                         selectedPkg = latestWithPref pref sourcePkgs ]     return matches   where-    onlyInstalled = fromFlag (listInstalled listFlags)-    matchingPackages search index =+    onlyInstalled   = fromFlagOrDefault False (listInstalled listFlags)+    caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)++    compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase+               | otherwise       = Regex.compExtended++    matchingPackages search regexps index =       [ pkg-      | pat <- pats-      , pkg <- search index pat ]+      | re <- regexps+      , pkg <- search index (Regex.matchTest re) ]   -- | Show information about packages. list :: Verbosity      -> PackageDBStack      -> RepoContext-     -> Compiler-     -> ProgramDb+     -> Maybe (Compiler, ProgramDb)      -> ListFlags      -> [String]      -> IO ()-list verbosity packageDBs repos comp progdb listFlags pats = do-    matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats+list verbosity packageDBs repos mcompProgdb listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats      if simpleOutput       then putStr $ unlines-             [ display (pkgName pkg) ++ " " ++ display version+             [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version              | pkg <- matches              , version <- if onlyInstalled                             then              installedVersions pkg@@ -201,7 +213,7 @@                        (fromFlag $ globalWorldFile globalFlags)                        sourcePkgs' userTargets -    pkgsinfo      <- sequence+    pkgsinfo      <- sequenceA                        [ do pkginfo <- either (die' verbosity) return $                                          gatherPkgInfo prefs                                            installedPkgIndex sourcePkgIndex@@ -220,9 +232,9 @@     gatherPkgInfo prefs installedPkgIndex sourcePkgIndex       (NamedPackage name props)       | null (selectedInstalledPkgs) && null (selectedSourcePkgs)-      = Left $ "There is no available version of " ++ display name+      = Left $ "There is no available version of " ++ prettyShow name             ++ " that satisfies "-            ++ display (simplifyVersionRange verConstraint)+            ++ prettyShow (simplifyVersionRange verConstraint)        | otherwise       = Right $ mergePackageInfo pref installedPkgs@@ -290,7 +302,7 @@     author            :: ShortText,     maintainer        :: ShortText,     dependencies      :: [ExtDependency],-    flags             :: [Flag],+    flags             :: [PackageFlag],     hasLib            :: Bool,     hasExe            :: Bool,     executables       :: [UnqualComponentName],@@ -307,14 +319,14 @@ showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo =   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-     char '*' <+> disp (pkgName pkginfo)+     char '*' <+> pretty (pkgName pkginfo)      $+$      (nest 4 $ vcat [        maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs      , text "Default available version:" <+>        case selectedSourcePkg pkginfo of          Nothing  -> text "[ Not available from any configured repository ]"-         Just pkg -> disp (packageVersion pkg)+         Just pkg -> pretty (packageVersion pkg)      , text "Installed versions:" <+>        case installedVersions pkginfo of          []  | hasLib pkginfo -> text "[ Not installed ]"@@ -327,16 +339,16 @@      $+$ text ""   where     maybeShowST l s f-        | ShortText.null l = empty+        | ShortText.null l = Disp.empty         | otherwise        = text s <+> f (ShortText.fromShortText l)  showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo =   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-   char '*' <+> disp (pkgName pkginfo)-            Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo)-            <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')-            Disp.<> parens pkgkind+   char '*' <+> pretty (pkgName pkginfo)+            <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)+            <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')+            <<>> parens pkgkind    $+$    (nest 4 $ vcat [      entryST "Synopsis"      synopsis     hideIfNull  reflowParagraphs@@ -355,19 +367,19 @@    , entryST "Author"        author       hideIfNull     reflowLines    , entryST "Maintainer"    maintainer   hideIfNull     reflowLines    , entry "Source repo"   sourceRepo   orNotSpecified text-   , entry "Executables"   executables  hideIfNull     (commaSep disp)+   , entry "Executables"   executables  hideIfNull     (commaSep pretty)    , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)    , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)    , entry "Documentation" haddockHtml  showIfInstalled text    , entry "Cached"        haveTarball  alwaysShow     dispYesNo-   , if not (hasLib pkginfo) then empty else-     text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+   , if not (hasLib pkginfo) then mempty else+     text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))    ])    $+$ text ""   where     entry fname field cond format = case cond (field pkginfo) of       Nothing           -> label <+> format (field pkginfo)-      Just Nothing      -> empty+      Just Nothing      -> mempty       Just (Just other) -> label <+> text other       where         label   = text fname Disp.<> char ':' Disp.<> padding@@ -393,8 +405,8 @@     dispYesNo True  = text "Yes"     dispYesNo False = text "No" -    dispExtDep (SourceDependency    dep) = disp dep-    dispExtDep (InstalledDependency dep) = disp dep+    dispExtDep (SourceDependency    dep) = pretty dep+    dispExtDep (InstalledDependency dep) = pretty dep      isInstalled = not (null (installedVersions pkginfo))     hasExes = length (executables pkginfo) >= 2@@ -404,7 +416,7 @@             | hasLib pkginfo                   = text "library"             | hasExes                          = text "programs"             | hasExe pkginfo                   = text "program"-            | otherwise                        = empty+            | otherwise                        = mempty   reflowParagraphs :: String -> Doc@@ -413,7 +425,7 @@   . intersperse (text "")                    -- re-insert blank lines   . map (fsep . map text . concatMap words)  -- reflow paragraphs   . filter (/= [""])-  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines+  . L.groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines   . lines  reflowLines :: String -> Doc@@ -495,7 +507,7 @@     sourceSelected       | isJust selectedPkg = selectedPkg       | otherwise          = latestWithPref versionPref sourcePkgs-    sourceGeneric = fmap packageDescription sourceSelected+    sourceGeneric = fmap srcpkgDescription sourceSelected     source        = fmap flattenPackageDescription sourceGeneric      uncons :: b -> (a -> b) -> [a] -> b@@ -509,7 +521,7 @@ -- updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo updateFileSystemPackageDetails pkginfo = do-  fetched   <- maybe (return False) (isFetched . packageSource)+  fetched   <- maybe (return False) (isFetched . srcpkgSource)                      (selectedSourcePkg pkginfo)   docsExist <- doesDirectoryExist (haddockHtml pkginfo)   return pkginfo {@@ -545,14 +557,14 @@     collect (OnlyInRight          (name,as)) = (name, [], as)  groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]-groupOn key = map (\xs -> (key (head xs), xs))+groupOn key = map (\xs -> (key (head xs), toList xs))             . groupBy (equating key)             . sortBy (comparing key)  dispTopVersions :: Int -> VersionRange -> [Version] -> Doc dispTopVersions n pref vs =          (Disp.fsep . Disp.punctuate (Disp.char ',')-        . map (\ver -> if ispref ver then disp ver else parens (disp ver))+        . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))         . sort . take n . interestingVersions ispref         $ vs)     <+> trailingMessage@@ -583,9 +595,12 @@     . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))     . reverseTree     . mkTree-    . map versionNumbers+    . map (or0 . versionNumbers)    where+    or0 []     = 0 :| []+    or0 (x:xs) = x :| xs+     swizzleTree = unfoldTree (spine [])       where         spine ts' (Node x [])     = (x, ts')@@ -598,12 +613,17 @@      reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) +    mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)     mkTree xs = unfoldTree step (False, [], xs)       where+        step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])         step (node,ns,vs) =           ( (reverse ns, node)-          , [ (any null vs', n:ns, filter (not . null) vs')-            | (n, vs') <- groups vs ]+          , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))+            | (n, vs') <- groups vs+            ]           )-        groups = map (\g -> (head (head g), map tail g))++        groups :: [NonEmpty a] -> [(a, NonEmpty [a])]+        groups = map (\g -> (head (head g), fmap tail g))                . groupBy (equating head)
Distribution/Client/Manpage.hs view
@@ -14,22 +14,63 @@ module Distribution.Client.Manpage   ( -- * Manual page generation     manpage+  , manpageCmd+  , ManpageFlags+  , defaultManpageFlags+  , manpageOptions   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ManpageFlags+import Distribution.Client.Setup        (globalCommand)+import Distribution.Compat.Process      (createProcess) import Distribution.Simple.Command-import Distribution.Client.Setup (globalCommand)+import Distribution.Simple.Flag         (fromFlagOrDefault)+import System.IO                        (hClose, hPutStr) -import Data.Char (toUpper)-import Data.List (intercalate)+import qualified System.Process as Process  data FileInfo = FileInfo String String -- ^ path, description +-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------+ -- | A list of files that should be documented in the manual page. files :: [FileInfo] files =   [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")   , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")   ]++manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()+manpageCmd pname commands flags+    | fromFlagOrDefault False (manpageRaw flags)+    = putStrLn contents+    | otherwise+    = do+        let cmd  = "man"+            args = ["-l", "-"]++        (mb_in, _, _, ph) <- createProcess (Process.proc cmd args)+            { Process.std_in  = Process.CreatePipe+            , Process.std_out = Process.Inherit+            , Process.std_err = Process.Inherit+            }++        -- put contents+        for_ mb_in $ \hin -> do+            hPutStr hin contents+            hClose hin++        -- wait for process to exit, propagate exit code+        ec <- Process.waitForProcess ph+        exitWith ec+  where+    contents :: String+    contents = manpage pname commands  -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String
+ Distribution/Client/ManpageFlags.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase    #-}+module Distribution.Client.ManpageFlags+( ManpageFlags (..)+, defaultManpageFlags+, manpageOptions,+) where++import Distribution.Client.Compat.Prelude++import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)+import Distribution.Simple.Setup   (Flag (..), toFlag, trueArg, optionVerbosity)+import Distribution.Verbosity      (normal)++data ManpageFlags = ManpageFlags+  { manpageVerbosity :: Flag Verbosity+  , manpageRaw       :: Flag Bool+  } deriving (Eq, Show, Generic)++instance Monoid ManpageFlags  where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ManpageFlags where+  (<>) = gmappend++defaultManpageFlags :: ManpageFlags+defaultManpageFlags = ManpageFlags+    { manpageVerbosity = toFlag normal+    , manpageRaw       = toFlag False+    }++manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags]+manpageOptions _ =+    [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v })+    , option "" ["raw"]+      "Output raw troff content"+      manpageRaw (\v flags -> flags { manpageRaw = v })+      trueArg+    ]
Distribution/Client/Nix.hs view
@@ -6,12 +6,11 @@        , inNixShell        , nixInstantiate        , nixShell-       , nixShellIfSandboxed        ) where  import Distribution.Client.Compat.Prelude -import Control.Exception (bracket, catch)+import Control.Exception (bracket) import System.Directory        ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist        , doesFileExist, removeDirectoryRecursive, removeFile )@@ -25,8 +24,6 @@ import Distribution.Compat.Environment        ( lookupEnv, setEnv, unsetEnv ) -import Distribution.Verbosity- import Distribution.Simple.Program        ( Program(..), ProgramDb        , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput@@ -36,7 +33,6 @@  import Distribution.Client.Config (SavedConfig(..)) import Distribution.Client.GlobalFlags (GlobalFlags(..))-import Distribution.Client.Sandbox.Types (UseSandbox(..))   configureOneProgram :: Verbosity -> Program -> IO ProgramDb@@ -86,7 +82,7 @@   -> GlobalFlags   -> SavedConfig   -> IO ()-nixInstantiate verb dist force globalFlags config =+nixInstantiate verb dist force' globalFlags config =   findNixExpr globalFlags config >>= \case     Nothing -> return ()     Just shellNix -> do@@ -98,7 +94,7 @@       let timestamp = timestampPath dist shellNix       upToDate <- existsAndIsMoreRecentThan timestamp shellNix -      let ready = alreadyInShell || (instantiated && upToDate && not force)+      let ready = alreadyInShell || (instantiated && upToDate && not force')       unless ready $ do          let prog = simpleProgram "nix-instantiate"@@ -184,19 +180,3 @@   when exists $ do     debug verb ("removing Nix gcroots from " ++ tgt)     removeDirectoryRecursive tgt---nixShellIfSandboxed-  :: Verbosity-  -> FilePath-  -> GlobalFlags-  -> SavedConfig-  -> UseSandbox-  -> IO ()-     -- ^ The action to perform inside a nix-shell. This is also the action-     -- that will be performed immediately if Nix is disabled.-  -> IO ()-nixShellIfSandboxed verb dist globalFlags config useSandbox go =-  case useSandbox of-    NoSandbox -> go-    UseSandbox _ -> nixShell verb dist globalFlags config go
+ Distribution/Client/NixStyleOptions.hs view
@@ -0,0 +1,85 @@+-- | Command line options for nix-style / v2 commands.+--+-- The commands take a lot of the same options, which affect how install plan+-- is constructed.+module Distribution.Client.NixStyleOptions (+    NixStyleFlags (..),+    nixStyleOptions,+    defaultNixStyleFlags,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Simple.Command                       (OptionField (..), ShowOrParseArgs)+import Distribution.Simple.Setup                         (BenchmarkFlags, HaddockFlags, TestFlags)+import Distribution.Solver.Types.ConstraintSource        (ConstraintSource (..))++import Distribution.Client.ProjectFlags+       (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions)+import Distribution.Client.Setup+       (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions,+       configureOptions, haddockOptions, installOptions, liftOptions, testOptions)++data NixStyleFlags a = NixStyleFlags+    { configFlags    :: ConfigFlags+    , configExFlags  :: ConfigExFlags+    , installFlags   :: InstallFlags+    , haddockFlags   :: HaddockFlags+    , testFlags      :: TestFlags+    , benchmarkFlags :: BenchmarkFlags+    , projectFlags   :: ProjectFlags+    , extraFlags     :: a+    }++nixStyleOptions+    :: (ShowOrParseArgs -> [OptionField a])+    -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]+nixStyleOptions commandOptions showOrParseArgs =+        liftOptions configFlags     set1+        -- Note: [Hidden Flags]+        -- hide "constraint", "dependency", and+        -- "exact-configuration" from the configure options.+        (filter ((`notElem` ["constraint", "dependency"+                            , "exact-configuration"])+                 . optionName) $ configureOptions showOrParseArgs)+     ++ liftOptions configExFlags   set2 (configureExOptions showOrParseArgs+                               ConstraintSourceCommandlineFlag)+     ++ liftOptions installFlags   set3+        -- hide "target-package-db" and "symlink-bindir" flags from the+        -- install options.+        -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags+        (filter ((`notElem` ["target-package-db", "symlink-bindir"])+                 . optionName) $+                               installOptions showOrParseArgs)+       ++ liftOptions haddockFlags set4+          -- hide "verbose" and "builddir" flags from the+          -- haddock options.+          (filter ((`notElem` ["v", "verbose", "builddir"])+                  . optionName) $+                                haddockOptions showOrParseArgs)+     ++ liftOptions testFlags      set5 (testOptions showOrParseArgs)+     ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)+     ++ liftOptions projectFlags   set7 (projectFlagsOptions showOrParseArgs)+     ++ liftOptions extraFlags     set8 (commandOptions showOrParseArgs)+  where+    set1 x flags = flags { configFlags    = x }+    set2 x flags = flags { configExFlags  = x }+    set3 x flags = flags { installFlags   = x }+    set4 x flags = flags { haddockFlags   = x }+    set5 x flags = flags { testFlags      = x }+    set6 x flags = flags { benchmarkFlags = x }+    set7 x flags = flags { projectFlags   = x }+    set8 x flags = flags { extraFlags     = x }++defaultNixStyleFlags :: a ->  NixStyleFlags a+defaultNixStyleFlags x = NixStyleFlags+    { configFlags    = mempty+    , configExFlags  = mempty+    , installFlags   = mempty+    , haddockFlags   = mempty+    , testFlags      = mempty+    , benchmarkFlags = mempty+    , projectFlags   = defaultProjectFlags+    , extraFlags     = x+    }
Distribution/Client/Outdated.hs view
@@ -37,22 +37,21 @@ import Distribution.Simple.Utils        (die', notice, debug, tryFindPackageDesc) import Distribution.System                           (Platform)-import Distribution.Deprecated.Text                             (display) import Distribution.Types.ComponentRequestedSpec        (ComponentRequestedSpec(..)) import Distribution.Types.Dependency-       (Dependency(..), depPkgName, simplifyDependency)-import Distribution.Verbosity                        (Verbosity, silent)+       (Dependency(..))+import Distribution.Verbosity                        (silent) import Distribution.Version        (Version, VersionRange, LowerBound(..), UpperBound(..)        ,asVersionIntervals, majorBoundVersion) import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)+import Distribution.Types.PackageVersionConstraint+       (PackageVersionConstraint (..), simplifyPackageVersionConstraint)  import qualified Data.Set as S import System.Directory                              (getCurrentDirectory)-import System.Exit                                   (exitFailure)-import Control.Exception                             (throwIO)  -- | Entry point for the 'outdated' command. outdated :: Verbosity -> OutdatedFlags -> RepoContext@@ -91,7 +90,7 @@                then depsFromNewFreezeFile verbosity mprojectFile                else depsFromPkgDesc verbosity comp platform   debug verbosity $ "Dependencies loaded: "-    ++ (intercalate ", " $ map display deps)+    ++ (intercalate ", " $ map prettyShow deps)   let outdatedDeps = listOutdated deps pkgIndex                      (ListOutdatedSettings ignorePred minorPred)   when (not quiet) $@@ -102,25 +101,25 @@  -- | Print either the list of all outdated dependencies, or a message -- that there are none.-showResult :: Verbosity -> [(Dependency,Version)] -> Bool -> IO ()+showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () showResult verbosity outdatedDeps simpleOutput =   if (not . null $ outdatedDeps)     then     do when (not simpleOutput) $          notice verbosity "Outdated dependencies:"-       for_ outdatedDeps $ \(d@(Dependency pn _ _), v) ->-         let outdatedDep = if simpleOutput then display pn-                           else display d ++ " (latest: " ++ display v ++ ")"+       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->+         let outdatedDep = if simpleOutput then prettyShow pn+                           else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"          in notice verbosity outdatedDep     else notice verbosity "All dependencies are up to date."  -- | Convert a list of 'UserConstraint's to a 'Dependency' list.-userConstraintsToDependencies :: [UserConstraint] -> [Dependency]+userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint] userConstraintsToDependencies ucnstrs =   mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs  -- | Read the list of dependencies from the freeze file.-depsFromFreezeFile :: Verbosity -> IO [Dependency]+depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] depsFromFreezeFile verbosity = do   cwd        <- getCurrentDirectory   userConfig <- loadUserConfig verbosity cwd Nothing@@ -131,7 +130,7 @@   return deps  -- | Read the list of dependencies from the new-style freeze file.-depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [Dependency]+depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint] depsFromNewFreezeFile verbosity mprojectFile = do   projectRoot <- either throwIO return =<<                  findProjectRoot Nothing mprojectFile@@ -147,7 +146,7 @@   return deps  -- | Read the list of dependencies from the package description.-depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [Dependency]+depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint] depsFromPkgDesc verbosity comp platform = do   cwd  <- getCurrentDirectory   path <- tryFindPackageDesc verbosity cwd@@ -161,7 +160,9 @@       let bd = allBuildDepends pd       debug verbosity         "Reading the list of dependencies from the package description"-      return bd+      return $ map toPVC bd+  where+    toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr  -- | Various knobs for customising the behaviour of 'listOutdated'. data ListOutdatedSettings = ListOutdatedSettings {@@ -172,16 +173,16 @@   }  -- | Find all outdated dependencies.-listOutdated :: [Dependency]+listOutdated :: [PackageVersionConstraint]              -> PackageIndex UnresolvedSourcePackage              -> ListOutdatedSettings-             -> [(Dependency, Version)]+             -> [(PackageVersionConstraint, Version)] listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =-  mapMaybe isOutdated $ map simplifyDependency deps+  mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps   where-    isOutdated :: Dependency -> Maybe (Dependency, Version)-    isOutdated dep@(Dependency pname vr _)-      | ignorePred (depPkgName dep) = Nothing+    isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)+    isOutdated dep@(PackageVersionConstraint pname vr)+      | ignorePred pname = Nothing       | otherwise                   =           let this   = map packageVersion $ lookupDependency pkgIndex pname vr               latest = lookupLatest dep@@ -195,12 +196,12 @@           latest' = maximum latest       in if this' < latest' then Just latest' else Nothing -    lookupLatest :: Dependency -> [Version]-    lookupLatest dep@(Dependency pname vr _)-      | minorPred (depPkgName dep) =+    lookupLatest :: PackageVersionConstraint -> [Version]+    lookupLatest (PackageVersionConstraint pname vr)+      | minorPred pname =         map packageVersion $ lookupDependency pkgIndex  pname (relaxMinor vr)-      | otherwise                  =-        map packageVersion $ lookupPackageName pkgIndex (depPkgName dep)+      | otherwise =+        map packageVersion $ lookupPackageName pkgIndex pname      relaxMinor :: VersionRange -> VersionRange     relaxMinor vr =
Distribution/Client/PackageHash.hs view
@@ -30,16 +30,13 @@          , PkgconfigName ) import Distribution.System          ( Platform, OS(Windows, OSX), buildOS )-import Distribution.PackageDescription-         ( FlagAssignment, unFlagAssignment, showFlagValue )+import Distribution.Types.Flag+         ( FlagAssignment, showFlagAssignment ) import Distribution.Simple.Compiler          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)          , ProfDetailLevel(..), showProfDetailLevel ) import Distribution.Simple.InstallDirs          ( PathTemplate, fromPathTemplate )-import Distribution.Pretty (prettyShow)-import Distribution.Deprecated.Text-         ( display ) import Distribution.Types.PkgconfigVersion (PkgconfigVersion) import Distribution.Client.HashValue import Distribution.Client.Types@@ -50,8 +47,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Function     (on)- ------------------------------- -- Calculating package hashes --@@ -76,11 +71,22 @@ -- without significant path length limitations (ie not Windows). -- hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} =-    mkComponentId $-         display pkgHashPkgId   -- to be a bit user friendly-      ++ "-"-      ++ showHashValue (hashPackageHashInputs pkghashinputs)+hashedInstalledPackageIdLong+    pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent}+    = mkComponentId $+           prettyShow pkgHashPkgId   -- to be a bit user friendly+        ++ maybe "" displayComponent pkgHashComponent+        ++ "-"+        ++ showHashValue (hashPackageHashInputs pkghashinputs)+  where+    displayComponent :: CD.Component -> String+    displayComponent CD.ComponentLib        = ""+    displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s+    displayComponent (CD.ComponentFLib s)   = "-f-" ++ prettyShow s+    displayComponent (CD.ComponentExe s)    = "-e-" ++ prettyShow s+    displayComponent (CD.ComponentTest s)   = "-t-" ++ prettyShow s+    displayComponent (CD.ComponentBench s)  = "-b-" ++ prettyShow s+    displayComponent CD.ComponentSetup      = "-setup"  -- | On Windows we have serious problems with path lengths. Windows imposes a -- maximum path length of 260 chars, and even if we can use the windows long@@ -105,8 +111,8 @@     mkComponentId $       intercalate "-"         -- max length now 64-        [ truncateStr 14 (display name)-        , truncateStr  8 (display version)+        [ truncateStr 14 (prettyShow name)+        , truncateStr  8 (prettyShow version)         , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))         ]   where@@ -143,8 +149,8 @@ hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =   mkComponentId $     intercalate "-"-      [ filter (not . flip elem "aeiou") (display name)-      , display version+      [ filter (not . flip elem "aeiou") (prettyShow name)+      , prettyShow version       , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))       ]   where@@ -250,37 +256,37 @@     -- into the ghc-pkg db. At that point this should probably be changed to     -- use the config file infrastructure so it can be read back in again.     LBS.pack $ unlines $ catMaybes $-      [ entry "pkgid"       display pkgHashPkgId+      [ entry "pkgid"       prettyShow pkgHashPkgId       , mentry "component"  show pkgHashComponent       , entry "src"         showHashValue pkgHashSourceHash       , entry "pkg-config-deps"-                            (intercalate ", " . map (\(pn, mb_v) -> display pn +++                            (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++                                                     case mb_v of                                                         Nothing -> ""                                                         Just v -> " " ++ prettyShow v)                                               . Set.toList) pkgHashPkgConfigDeps-      , entry "deps"        (intercalate ", " . map display+      , entry "deps"        (intercalate ", " . map prettyShow                                               . Set.toList) pkgHashDirectDeps         -- and then all the config-      , entry "compilerid"  display pkgHashCompilerId-      , entry "platform"    display pkgHashPlatform+      , entry "compilerid"  prettyShow pkgHashCompilerId+      , entry "platform" prettyShow pkgHashPlatform       , opt   "flags" mempty showFlagAssignment pkgHashFlagAssignment       , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs-      , opt   "vanilla-lib" True  display pkgHashVanillaLib-      , opt   "shared-lib"  False display pkgHashSharedLib-      , opt   "dynamic-exe" False display pkgHashDynExe-      , opt   "fully-static-exe" False display pkgHashFullyStaticExe-      , opt   "ghci-lib"    False display pkgHashGHCiLib-      , opt   "prof-lib"    False display pkgHashProfLib-      , opt   "prof-exe"    False display pkgHashProfExe+      , opt   "vanilla-lib" True  prettyShow pkgHashVanillaLib+      , opt   "shared-lib"  False prettyShow pkgHashSharedLib+      , opt   "dynamic-exe" False prettyShow pkgHashDynExe+      , opt   "fully-static-exe" False prettyShow pkgHashFullyStaticExe+      , opt   "ghci-lib"    False prettyShow pkgHashGHCiLib+      , opt   "prof-lib"    False prettyShow pkgHashProfLib+      , opt   "prof-exe"    False prettyShow pkgHashProfExe       , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail       , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail-      , opt   "hpc"          False display pkgHashCoverage+      , opt   "hpc"          False prettyShow pkgHashCoverage       , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization-      , opt   "split-objs"   False display pkgHashSplitObjs-      , opt   "split-sections" False display pkgHashSplitSections-      , opt   "stripped-lib" False display pkgHashStripLibs-      , opt   "stripped-exe" True  display pkgHashStripExes+      , opt   "split-objs"   False prettyShow pkgHashSplitObjs+      , opt   "split-sections" False prettyShow pkgHashSplitSections+      , opt   "stripped-lib" False prettyShow pkgHashStripLibs+      , opt   "stripped-exe" True  prettyShow pkgHashStripExes       , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo       , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs       , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs@@ -288,18 +294,18 @@       , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix       , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix -      , opt   "documentation"  False display pkgHashDocumentation-      , opt   "haddock-hoogle" False display pkgHashHaddockHoogle-      , opt   "haddock-html"   False display pkgHashHaddockHtml+      , opt   "documentation"  False prettyShow pkgHashDocumentation+      , opt   "haddock-hoogle" False prettyShow pkgHashHaddockHoogle+      , opt   "haddock-html"   False prettyShow pkgHashHaddockHtml       , opt   "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation-      , opt   "haddock-foreign-libraries" False display pkgHashHaddockForeignLibs-      , opt   "haddock-executables" False display pkgHashHaddockExecutables-      , opt   "haddock-tests" False display pkgHashHaddockTestSuites-      , opt   "haddock-benchmarks" False display pkgHashHaddockBenchmarks-      , opt   "haddock-internal" False display pkgHashHaddockInternal+      , opt   "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs+      , opt   "haddock-executables" False prettyShow pkgHashHaddockExecutables+      , opt   "haddock-tests" False prettyShow pkgHashHaddockTestSuites+      , opt   "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks+      , opt   "haddock-internal" False prettyShow pkgHashHaddockInternal       , opt   "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss-      , opt   "haddock-hyperlink-source" False display pkgHashHaddockLinkedSource-      , opt   "haddock-quickjump" False display pkgHashHaddockQuickJump+      , opt   "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource+      , opt   "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump       , opt   "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents        ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs@@ -309,5 +315,3 @@     opt   key def format value          | value == def = Nothing          | otherwise    = entry key format value--    showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment
− Distribution/Client/PackageUtils.hs 
@@ -1,38 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PackageUtils--- Copyright   :  (c) Duncan Coutts 2010--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Various package description utils that should be in the Cabal lib-------------------------------------------------------------------------------module Distribution.Client.PackageUtils (-    externalBuildDepends,-  ) where--import Distribution.Package                      (packageName, packageVersion)-import Distribution.PackageDescription-       (PackageDescription (..), enabledBuildDepends, libName)-import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec)-import Distribution.Types.Dependency-import Distribution.Types.LibraryName-import Distribution.Types.UnqualComponentName-import Distribution.Version                      (isAnyVersion, withinRange)---- | The list of dependencies that refer to external packages--- rather than internal package components.----externalBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency]-externalBuildDepends pkg spec = filter (not . internal) (enabledBuildDepends pkg spec)-  where-    -- True if this dependency is an internal one (depends on a library-    -- defined in the same package).-    internal (Dependency depName versionRange _) =-           (depName == packageName pkg &&-            packageVersion pkg `withinRange` versionRange) ||-           (LSubLibName (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) &&-            isAnyVersion versionRange)
Distribution/Client/ParseUtils.hs view
@@ -54,14 +54,14 @@ import Distribution.Simple.Command          ( OptionField  ) -import Text.PrettyPrint ( (<+>), ($+$) )+import Text.PrettyPrint ( ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp          ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )  -- For new parser stuff import Distribution.CabalSpecVersion (cabalSpecLatest)-import Distribution.FieldGrammar (FieldGrammar, partitionFields, parseFieldGrammar)+import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) import Distribution.Fields.ParseResult (runParseResult) import Distribution.Parsec.Error (showPError) import Distribution.Parsec.Position (Position (..))@@ -124,9 +124,9 @@      }  -- | 'FieldGrammar' section description-data FGSectionDescr a = forall s. FGSectionDescr+data FGSectionDescr g a = forall s. FGSectionDescr     { fgSectionName    :: String-    , fgSectionGrammar :: forall g. (FieldGrammar g, Applicative (g s)) => g s s+    , fgSectionGrammar :: g s s     -- todo: add subsections?     , fgSectionGet     :: a -> [(String, s)]     , fgSectionSet     :: LineNo -> String -> s -> a -> ParseResult a@@ -219,7 +219,7 @@ parseFieldsAndSections     :: [FieldDescr a]      -- ^ field     -> [SectionDescr a]    -- ^ legacy sections-    -> [FGSectionDescr a]  -- ^ FieldGrammar sections+    -> [FGSectionDescr FG.ParsecFieldGrammar a]  -- ^ FieldGrammar sections     -> a     -> [Field] -> ParseResult a parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =@@ -286,7 +286,7 @@ -- Note that unlike 'ppFields', at present it does not support printing -- default values. If needed, adding such support would be quite reasonable. ---ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =     ppFields fieldDescrs Nothing val       $+$@@ -313,7 +313,7 @@ -- 'ppFieldsAndSections' and so does not need to be exported. -- ppSectionAndSubsections :: String -> String-                        -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc+                        -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar  a] -> a -> Disp.Doc ppSectionAndSubsections name arg fields sections fgSections cur   | Disp.isEmpty fieldsDoc = Disp.empty   | otherwise              = Disp.text name <+> argDoc@@ -360,7 +360,7 @@ -- -- It accumulates the result on top of a given initial (typically empty) value. ---parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a             -> String -> ParseResult a parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =       parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty@@ -369,6 +369,6 @@ -- | Render a value in the config file syntax, based on a description of the -- configuration file in terms of its fields and sections. ---showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc+showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc showConfig = ppFieldsAndSections
Distribution/Client/ProjectBuilding.hs view
@@ -90,8 +90,6 @@  import           Distribution.Simple.Utils import           Distribution.Version-import           Distribution.Verbosity-import           Distribution.Pretty import           Distribution.Compat.Graph (IsNode(..))  import qualified Data.List.NonEmpty as NE@@ -100,8 +98,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Control.Exception (Exception (..), Handler (..), SomeAsyncException, SomeException, assert, catches, handle, throwIO)-import Data.Function     (on)+import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>)) import System.IO         (IOMode (AppendMode), withFile)@@ -203,13 +200,8 @@           -- artifacts under the shared dist directory.           dryRunLocalPkg pkg depsBuildStatus srcdir -        Just (RemoteSourceRepoPackage _repo srcdir) ->-          -- At this point, source repos are essentially the same as local-          -- dirs, since we've already download them.-          dryRunLocalPkg pkg depsBuildStatus srcdir--        -- The three tarball cases are handled the same as each other,-        -- though depending on the build style.+        -- The rest cases are all tarball cases are,+        -- and handled the same as each other though depending on the build style.         Just (LocalTarballPackage    tarball) ->           dryRunTarballPkg pkg depsBuildStatus tarball @@ -219,6 +211,10 @@         Just (RepoTarballPackage _ _ tarball) ->           dryRunTarballPkg pkg depsBuildStatus tarball +        Just (RemoteSourceRepoPackage _repo tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++     dryRunTarballPkg :: ElaboratedConfiguredPackage                      -> [BuildStatus]                      -> FilePath@@ -1226,7 +1222,7 @@                 execRebuild srcdir (needElaboratedConfiguredPackage pkg)               listSdist =                 fmap (map monitorFileHashed) $-                    allPackageSourceFiles verbosity scriptOptions srcdir+                    allPackageSourceFiles verbosity srcdir               ifNullThen m m' = do xs <- m                                    if null xs then m' else return xs           monitors <- case PD.buildType (elabPkgDescription pkg) of
Distribution/Client/ProjectBuilding/Types.hs view
@@ -22,17 +22,15 @@     BuildFailureReason(..),   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.Types          (DocsResult, TestsResult) import Distribution.Client.FileMonitor    (MonitorChangedReason(..))  import Distribution.Package               (UnitId, PackageId) import Distribution.InstalledPackageInfo  (InstalledPackageInfo) import Distribution.Simple.LocalBuildInfo (ComponentName)--import Data.Map          (Map)-import Data.Set          (Set)-import Data.Typeable     (Typeable)-import Control.Exception (Exception, SomeException)   ------------------------------------------------------------------------------
Distribution/Client/ProjectConfig.hs view
@@ -29,7 +29,6 @@     readGlobalConfig,     readProjectLocalFreezeConfig,     withProjectOrGlobalConfig,-    withProjectOrGlobalConfigIgn,     writeProjectLocalExtraConfig,     writeProjectLocalFreezeConfig,     writeProjectConfigFile,@@ -89,7 +88,7 @@          ( PackageProperty(..) )  import Distribution.Package-         ( PackageName, PackageId, packageId, UnitId )+         ( PackageName, PackageId, UnitId, packageId ) import Distribution.Types.PackageVersionConstraint          ( PackageVersionConstraint(..) ) import Distribution.System@@ -100,10 +99,9 @@          ( parseGenericPackageDescription ) import Distribution.Fields          ( runParseResult, PError, PWarning, showPWarning)-import Distribution.Pretty (prettyShow) import Distribution.Types.SourceRepo          ( RepoType(..) )-import Distribution.Client.SourceRepo+import Distribution.Client.Types.SourceRepo          ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) import Distribution.Simple.Compiler          ( Compiler, compilerInfo )@@ -124,22 +122,20 @@ import Distribution.Utils.NubList          ( fromNubList ) import Distribution.Verbosity-         ( Verbosity, modifyVerbosity, verbose )+         ( modifyVerbosity, verbose ) import Distribution.Version          ( Version )-import Distribution.Deprecated.Text import qualified Distribution.Deprecated.ParseUtils as OldParser          ( ParseResult(..), locatedErrorMsg, showPWarning )+import Distribution.Client.SrcDist+         ( packageDirToSdist )  import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar import qualified Distribution.Client.GZipUtils as GZipUtils -import Control.Monad import Control.Monad.Trans (liftIO)-import Control.Exception-import Data.Either import qualified Data.ByteString       as BS import qualified Data.ByteString.Lazy  as LBS import qualified Data.Map as Map@@ -186,7 +182,6 @@     withRepoContext'       verbosity       buildSettingRemoteRepos-      buildSettingLocalRepos       buildSettingLocalNoIndexRepos       buildSettingCacheDir       buildSettingHttpTransport@@ -209,7 +204,6 @@     withRepoContext'       verbosity       (fromNubList projectConfigRemoteRepos)-      (fromNubList projectConfigLocalRepos)       (fromNubList projectConfigLocalNoIndexRepos)       (fromFlagOrDefault                    (error@@ -234,7 +228,6 @@     --TODO: [required eventually] some of these settings need validation, e.g.     -- the flag assignments need checking.     solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos-    solverSettingLocalRepos        = fromNubList projectConfigLocalRepos     solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos     solverSettingConstraints       = projectConfigConstraints     solverSettingPreferences       = projectConfigPreferences@@ -256,6 +249,7 @@     solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls     solverSettingOnlyConstrained   = fromFlag projectConfigOnlyConstrained     solverSettingIndexState        = flagToMaybe projectConfigIndexState+    solverSettingActiveRepos       = flagToMaybe projectConfigActiveRepos     solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs   --solverSettingReinstall         = fromFlag projectConfigReinstall@@ -300,7 +294,6 @@                          ProjectConfig {                            projectConfigShared = ProjectConfigShared {                              projectConfigRemoteRepos,-                             projectConfigLocalRepos,                              projectConfigLocalNoIndexRepos,                              projectConfigProgPathExtra                            },@@ -321,7 +314,6 @@     buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode     buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles     buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos-    buildSettingLocalRepos    = fromNubList projectConfigLocalRepos     buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos     buildSettingCacheDir      = fromFlag    projectConfigCacheDir     buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport@@ -438,9 +430,6 @@             then return (Right (ProjectRootExplicit dir projectFileName))             else go (takeDirectory dir) -   --TODO: [nice to have] add compat support for old style sandboxes-- -- | Errors returned by 'findProjectRoot'. -- data BadProjectRoot = BadProjectRootExplicitFile FilePath@@ -462,30 +451,26 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =     "The given project file '" ++ projectFile ++ "' does not exist." --- | Like 'withProjectOrGlobalConfig', with an additional boolean--- which tells to ignore local project.------ Used to implement -z / --ignore-project behaviour----withProjectOrGlobalConfigIgn-    :: Bool -- ^ whether to ignore local project-    -> Verbosity-    -> Flag FilePath-    -> IO a-    -> (ProjectConfig -> IO a)+withProjectOrGlobalConfig+    :: Verbosity                  -- ^ verbosity+    -> Flag Bool                  -- ^ whether to ignore local project+    -> Flag FilePath              -- ^ @--cabal-config@+    -> IO a                       -- ^ with project+    -> (ProjectConfig -> IO a)    -- ^ without projet     -> IO a-withProjectOrGlobalConfigIgn True  verbosity gcf _with without = do+withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do     globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf     without globalConfig-withProjectOrGlobalConfigIgn False verbosity gcf with without =-    withProjectOrGlobalConfig verbosity gcf with without+withProjectOrGlobalConfig verbosity _ignorePrj  gcf  with without =+    withProjectOrGlobalConfig' verbosity gcf with without -withProjectOrGlobalConfig :: Verbosity-                          -> Flag FilePath-                          -> IO a-                          -> (ProjectConfig -> IO a)-                          -> IO a-withProjectOrGlobalConfig verbosity globalConfigFlag with without = do+withProjectOrGlobalConfig'+    :: Verbosity+    -> Flag FilePath+    -> IO a+    -> (ProjectConfig -> IO a)+    -> IO a+withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do   globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag    let@@ -544,9 +529,6 @@         -- We expect a package in the current directory.         projectPackages         = [ "./*.cabal" ], -        -- This is to automatically pick up deps that we unpack locally.-        projectPackagesOptional = [ "./*/*.cabal" ],-         projectConfigProvenance = Set.singleton Implicit       } @@ -824,7 +806,7 @@   where     findPackageLocations required pkglocstr = do       (problems, pkglocs) <--        partitionEithers <$> mapM (findPackageLocation required) pkglocstr+        partitionEithers <$> traverse (findPackageLocation required) pkglocstr       unless (null problems) $         liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems       return (concat pkglocs)@@ -883,7 +865,7 @@       checkIsFileGlobPackage pkglocstr =-      case simpleParse pkglocstr of+      case simpleParsec pkglocstr of         Nothing   -> return Nothing         Just glob -> liftM Just $ do           matches <- matchFileGlob glob@@ -896,7 +878,7 @@              _  -> do               (failures, pkglocs) <- partitionEithers <$>-                                     mapM checkFilePackageMatch matches+                                     traverse checkFilePackageMatch matches               return $! case (failures, pkglocs) of                 ([failure], []) | isJust (isTrivialFilePathGlob glob)                         -> Left (BadPackageLocationFile failure)@@ -1004,13 +986,13 @@                            pkgLocations = do      pkgsLocalDirectory <--      sequence+      sequenceA         [ readSourcePackageLocalDirectory verbosity dir cabalFile         | location <- pkgLocations         , (dir, cabalFile) <- projectPackageLocal location ]      pkgsLocalTarball <--      sequence+      sequenceA         [ readSourcePackageLocalTarball verbosity path         | ProjectPackageLocalTarball path <- pkgLocations ] @@ -1018,7 +1000,7 @@       getTransport <- delayInitSharedResource $                       configureTransport verbosity progPathExtra                                          preferredHttpTransport-      sequence+      sequenceA         [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout                                                  getTransport uri         | ProjectPackageRemoteTarball uri <- pkgLocations ]@@ -1162,7 +1144,7 @@                           let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in                           configureVCS verbosity {-progPathExtra-} vcs -    concat <$> sequence+    concat <$> sequenceA       [ rerunIfChanged verbosity monitor repoGroup' $ do           vcs' <- getConfiguredVCS repoType           syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'@@ -1190,10 +1172,11 @@         syncSourceRepos verbosity vcs           [ (repo, repoPath)           | (repo, _, repoPath) <- repoGroupWithPaths ]+        -- TODO phadej 2020-06-18 add post-sync script          -- But for reading we go through each 'SourceRepo' including its subdir         -- value and have to know which path each one ended up in.-        sequence+        sequenceA           [ readPackageFromSourceRepo repoWithSubdir repoPath           | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths           , repoWithSubdir <- NE.toList reposWithSubdir ]@@ -1219,25 +1202,31 @@                   : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]      readPackageFromSourceRepo-        :: SourceRepositoryPackage Maybe -> FilePath+        :: SourceRepositoryPackage Maybe+        -> FilePath         -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))     readPackageFromSourceRepo repo repoPath = do-        let packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)+        let packageDir :: FilePath+            packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)+         entries <- liftIO $ getDirectoryContents packageDir-        --TODO: wrap exceptions+        --TODO: dcoutts 2018-06-23: wrap exceptions         case filter (\e -> takeExtension e == ".cabal") entries of           []       -> liftIO $ throwIO $ NoCabalFileFound packageDir           (_:_:_)  -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir           [cabalFileName] -> do+            let cabalFilePath = packageDir </> cabalFileName             monitorFiles [monitorFileHashed cabalFilePath]-            liftIO $ fmap (mkSpecificSourcePackage location)-                   . readSourcePackageCabalFile verbosity cabalFilePath-                 =<< BS.readFile cabalFilePath-            where-              cabalFilePath = packageDir </> cabalFileName-              location      = RemoteSourceRepoPackage repo packageDir+            gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath +            -- write sdist tarball, to repoPath-pgkid+            tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir+            let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz"+            liftIO $ LBS.writeFile tarballPath tarball +            let location = RemoteSourceRepoPackage repo tarballPath+            return $ mkSpecificSourcePackage location gpd+     reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a     reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems @@ -1251,16 +1240,14 @@ -- mkSpecificSourcePackage :: PackageLocation FilePath                         -> GenericPackageDescription-                        -> PackageSpecifier-                             (SourcePackage (PackageLocation (Maybe FilePath)))+                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) mkSpecificSourcePackage location pkg =-    SpecificSourcePackage SourcePackage {-      packageInfoId        = packageId pkg,-      packageDescription   = pkg,-      --TODO: it is silly that we still have to use a Maybe FilePath here-      packageSource        = fmap Just location,-      packageDescrOverride = Nothing-    }+    SpecificSourcePackage SourcePackage+      { srcpkgPackageId     = packageId pkg+      , srcpkgDescription   = pkg+      , srcpkgSource        = fmap Just location+      , srcpkgDescrOverride = Nothing+      }   -- | Errors reported upon failing to parse a @.cabal@ file.@@ -1448,7 +1435,7 @@     "The path to the compiler program (or programs used by the compiler) "  ++ "cannot be specified on a per-package basis in the cabal.project file "  ++ "(i.e. setting the '" ++ progname ++ "-location' for package '"- ++ display pkgname ++ "'). All packages have to use the same compiler, so "+ ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so "  ++ "specify the path in a global 'program-locations' section."  --TODO: [nice to have] better format control so we can pretty-print the  -- offending part of the project file. Currently the line wrapping breaks any
Distribution/Client/ProjectConfig/Legacy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-}  -- | Project configuration, implementation in terms of legacy types. --@@ -23,13 +23,13 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Deprecated.ParseUtils (parseFlagAssignment)+import Distribution.Types.Flag (parsecFlagAssignment)  import Distribution.Client.ProjectConfig.Types-import Distribution.Client.Types-         ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo-         , AllowNewer(..), AllowOlder(..) )-import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)+import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)+import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)+import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))+import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)  import Distribution.Client.Config          ( SavedConfig(..), remoteRepoFields, postProcessRepo )@@ -40,7 +40,9 @@  import Distribution.Solver.Types.ConstraintSource +import Distribution.FieldGrammar import Distribution.Package+import Distribution.Types.SourceRepo (RepoType) import Distribution.PackageDescription          ( dispFlagAssignment ) import Distribution.Simple.Compiler@@ -54,6 +56,8 @@          , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags          , programDbPaths', splitArgs          )+import Distribution.Client.NixStyleOptions (NixStyleFlags (..))+import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -69,24 +73,26 @@ import Distribution.Simple.LocalBuildInfo          ( toPathTemplate, fromPathTemplate ) -import Distribution.Deprecated.Text import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Deprecated.ReadP          ( ReadP, (+++) ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint          ( Doc, ($+$) )-import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field)+import qualified Distribution.Deprecated.ParseUtils as ParseUtils import Distribution.Deprecated.ParseUtils          ( ParseResult(..), PError(..), syntaxError, PWarning(..)-         , simpleField, commaNewLineListField, newLineListField, parseTokenQ-         , parseHaskellString, showToken )+         , commaNewLineListFieldParsec, newLineListField, parseTokenQ+         , parseHaskellString, showToken +         , simpleFieldParsec+         ) import Distribution.Client.ParseUtils import Distribution.Simple.Command          ( CommandUI(commandOptions), ShowOrParseArgs(..)          , OptionField, option, reqArg' ) import Distribution.Types.PackageVersionConstraint          ( PackageVersionConstraint )+import Distribution.Parsec (ParsecParser)  import qualified Data.Map as Map @@ -144,7 +150,8 @@        legacyConfigureShFlags  :: ConfigFlags,        legacyConfigureExFlags  :: ConfigExFlags,        legacyInstallFlags      :: InstallFlags,-       legacyClientInstallFlags:: ClientInstallFlags+       legacyClientInstallFlags:: ClientInstallFlags,+       legacyProjectFlags      :: ProjectFlags      } deriving Generic  instance Monoid LegacySharedConfig where@@ -167,15 +174,10 @@ -- 'LegacyProjectConfig' for an explanation. -- commandLineFlagsToProjectConfig :: GlobalFlags-                                -> ConfigFlags  -> ConfigExFlags-                                -> InstallFlags -> ClientInstallFlags-                                -> HaddockFlags-                                -> TestFlags-                                -> BenchmarkFlags+                                -> NixStyleFlags a+                                -> ClientInstallFlags                                 -> ProjectConfig-commandLineFlagsToProjectConfig globalFlags configFlags configExFlags-                                installFlags clientInstallFlags-                                haddockFlags testFlags benchmarkFlags =+commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =     mempty {       projectConfigBuildOnly     = convertLegacyBuildOnlyFlags                                      globalFlags configFlags@@ -183,7 +185,7 @@                                      haddockFlags testFlags benchmarkFlags,       projectConfigShared        = convertLegacyAllPackageFlags                                      globalFlags configFlags-                                     configExFlags installFlags,+                                     configExFlags installFlags projectFlags,       projectConfigLocalPackages = localConfig,       projectConfigAllPackages   = allConfig     }@@ -237,7 +239,8 @@       savedReportFlags       = _,       savedHaddockFlags      = haddockFlags,       savedTestFlags         = testFlags,-      savedBenchmarkFlags    = benchmarkFlags+      savedBenchmarkFlags    = benchmarkFlags,+      savedProjectFlags      = projectFlags     } =     mempty {       projectConfigBuildOnly   = configBuildOnly,@@ -253,13 +256,14 @@     haddockFlags'       = defaultHaddockFlags       <> haddockFlags     testFlags'          = defaultTestFlags          <> testFlags     benchmarkFlags'     = defaultBenchmarkFlags     <> benchmarkFlags+    projectFlags'       = defaultProjectFlags       <> projectFlags      configAllPackages   = convertLegacyPerPackageFlags                             configFlags installFlags'                             haddockFlags' testFlags' benchmarkFlags'     configShared        = convertLegacyAllPackageFlags                             globalFlags configFlags-                            configExFlags' installFlags'+                            configExFlags' installFlags' projectFlags'     configBuildOnly     = convertLegacyBuildOnlyFlags                             globalFlags configFlags                             installFlags' clientInstallFlags'@@ -279,7 +283,7 @@     legacyPackagesNamed,     legacySharedConfig = LegacySharedConfig globalFlags configShFlags                                             configExFlags installSharedFlags-                                            clientInstallFlags,+                                            clientInstallFlags projectFlags,     legacyAllConfig,     legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags                                              haddockFlags testFlags benchmarkFlags,@@ -307,7 +311,7 @@                             testFlags benchmarkFlags     configPackagesShared= convertLegacyAllPackageFlags                             globalFlags (configFlags <> configShFlags)-                            configExFlags installSharedFlags+                            configExFlags installSharedFlags projectFlags     configBuildOnly     = convertLegacyBuildOnlyFlags                             globalFlags configShFlags                             installSharedFlags clientInstallFlags@@ -324,19 +328,21 @@ -- | Helper used by other conversion functions that returns the -- 'ProjectConfigShared' subset of the 'ProjectConfig'. ---convertLegacyAllPackageFlags :: GlobalFlags -> ConfigFlags-                             -> ConfigExFlags -> InstallFlags-                             -> ProjectConfigShared-convertLegacyAllPackageFlags globalFlags configFlags-                             configExFlags installFlags =+convertLegacyAllPackageFlags+    :: GlobalFlags+    -> ConfigFlags+    -> ConfigExFlags+    -> InstallFlags+    -> ProjectFlags+    -> ProjectConfigShared+convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =     ProjectConfigShared{..}   where     GlobalFlags {       globalConfigFile        = projectConfigConfigFile,-      globalSandboxConfigFile = _, -- ??       globalRemoteRepos       = projectConfigRemoteRepos,-      globalLocalRepos        = projectConfigLocalRepos,       globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,+      globalActiveRepos       = projectConfigActiveRepos,       globalProgPathExtra     = projectConfigProgPathExtra,       globalStoreDir          = projectConfigStoreDir     } = globalFlags@@ -364,7 +370,6 @@     } = configExFlags      InstallFlags {-      installProjectFileName    = projectConfigProjectFile,       installHaddockIndex       = projectConfigHaddockIndex,     --installReinstall          = projectConfigReinstall,     --installAvoidReinstalls    = projectConfigAvoidReinstalls,@@ -384,7 +389,10 @@       installOnlyConstrained    = projectConfigOnlyConstrained     } = installFlags -+    ProjectFlags+        { flagProjectFileName = projectConfigProjectFile+        , flagIgnoreProject   = projectConfigIgnoreProject+        } = projectFlags  -- | Helper used by other conversion functions that returns the -- 'PackageConfig' subset of the 'ProjectConfig'.@@ -555,28 +563,26 @@       }     } = -    LegacySharedConfig {-      legacyGlobalFlags      = globalFlags,-      legacyConfigureShFlags = configFlags,-      legacyConfigureExFlags = configExFlags,-      legacyInstallFlags     = installFlags,-      legacyClientInstallFlags = projectConfigClientInstallFlags-    }+    LegacySharedConfig+      { legacyGlobalFlags        = globalFlags+      , legacyConfigureShFlags   = configFlags+      , legacyConfigureExFlags   = configExFlags+      , legacyInstallFlags       = installFlags+      , legacyClientInstallFlags = projectConfigClientInstallFlags+      , legacyProjectFlags       = projectFlags+      }   where     globalFlags = GlobalFlags {       globalVersion           = mempty,       globalNumericVersion    = mempty,       globalConfigFile        = projectConfigConfigFile,-      globalSandboxConfigFile = mempty,       globalConstraintsFile   = mempty,       globalRemoteRepos       = projectConfigRemoteRepos,       globalCacheDir          = projectConfigCacheDir,-      globalLocalRepos        = projectConfigLocalRepos,       globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,+      globalActiveRepos       = projectConfigActiveRepos,       globalLogsDir           = projectConfigLogsDir,       globalWorldFile         = mempty,-      globalRequireSandbox    = mempty,-      globalIgnoreSandbox     = mempty,       globalIgnoreExpiry      = projectConfigIgnoreExpiry,       globalHttpTransport     = projectConfigHttpTransport,       globalNix               = mempty,@@ -633,11 +639,15 @@       installNumJobs           = projectConfigNumJobs,       installKeepGoing         = projectConfigKeepGoing,       installRunTests          = mempty,-      installOfflineMode       = projectConfigOfflineMode,-      installProjectFileName   = projectConfigProjectFile+      installOfflineMode       = projectConfigOfflineMode     } +    projectFlags = ProjectFlags+        { flagProjectFileName = projectConfigProjectFile+        , flagIgnoreProject   = projectConfigIgnoreProject+        } + convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig convertToLegacyAllPackageConfig     ProjectConfig {@@ -862,8 +872,8 @@         (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ         legacyPackagesOptional         (\v flags -> flags { legacyPackagesOptional = v })-    , commaNewLineListField "extra-packages"-        disp parse+    , commaNewLineListFieldParsec "extra-packages"+        pretty parsec         legacyPackagesNamed         (\v flags -> flags { legacyPackagesNamed = v })     ]@@ -931,17 +941,12 @@   legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig]-legacySharedConfigFieldDescrs =--  ( liftFields+legacySharedConfigFieldDescrs = concat+  [ liftFields       legacyGlobalFlags       (\flags conf -> conf { legacyGlobalFlags = flags })   . addFields-      [ newLineListField "local-repo"-          showTokenQ parseTokenQ-          (fromNubList . globalLocalRepos)-          (\v conf -> conf { globalLocalRepos = toNubList v }),-         newLineListField "extra-prog-path-shared-only"+      [ newLineListField "extra-prog-path-shared-only"           showTokenQ parseTokenQ           (fromNubList . globalProgPathExtra)           (\v conf -> conf { globalProgPathExtra = toNubList v })@@ -949,36 +954,37 @@   . filterFields       [ "remote-repo-cache"       , "logs-dir", "store-dir", "ignore-expiry", "http-transport"+      , "active-repositories"       ]   . commandOptionsToFields-  ) (commandOptions (globalCommand []) ParseArgs)- ++-  ( liftFields+  $ commandOptions (globalCommand []) ParseArgs++  , liftFields       legacyConfigureShFlags       (\flags conf -> conf { legacyConfigureShFlags = flags })   . filterFields ["verbose", "builddir" ]   . commandOptionsToFields-  ) (configureOptions ParseArgs)- ++-  ( liftFields+  $ configureOptions ParseArgs++  , liftFields       legacyConfigureExFlags       (\flags conf -> conf { legacyConfigureExFlags = flags })   . addFields-      [ commaNewLineListField "constraints"-        (disp . fst) (fmap (\constraint -> (constraint, constraintSrc)) parse)+      [ commaNewLineListFieldParsec "constraints"+        (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)         configExConstraints (\v conf -> conf { configExConstraints = v }) -      , commaNewLineListField "preferences"-        disp parse+      , commaNewLineListFieldParsec "preferences"+        pretty parsec         configPreferences (\v conf -> conf { configPreferences = v }) -      , monoidField "allow-older"-        (maybe mempty disp) (fmap Just parse)+      , monoidFieldParsec "allow-older"+        (maybe mempty pretty) (fmap Just parsec)         (fmap unAllowOlder . configAllowOlder)         (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) -      , monoidField "allow-newer"-        (maybe mempty disp) (fmap Just parse)+      , monoidFieldParsec "allow-newer"+        (maybe mempty pretty) (fmap Just parsec)         (fmap unAllowNewer . configAllowNewer)         (\v conf -> conf { configAllowNewer = fmap AllowNewer v })       ]@@ -987,9 +993,9 @@         -- not "constraint" or "preference", we use our own plural ones above       ]   . commandOptionsToFields-  ) (configureExOptions ParseArgs constraintSrc)- ++-  ( liftFields+  $ configureExOptions ParseArgs constraintSrc++  , liftFields       legacyInstallFlags       (\flags conf -> conf { legacyInstallFlags = flags })   . addFields@@ -1011,15 +1017,23 @@       , "reject-unconstrained-dependencies", "index-state"       ]   . commandOptionsToFields-  ) (installOptions ParseArgs)- ++-  ( liftFields+  $ installOptions ParseArgs++  , liftFields       legacyClientInstallFlags       (\flags conf -> conf { legacyClientInstallFlags = flags })   . commandOptionsToFields-  ) (clientInstallOptions ParseArgs)+  $ clientInstallOptions ParseArgs++  , liftFields+      legacyProjectFlags+      (\flags conf -> conf { legacyProjectFlags = flags })+  . commandOptionsToFields+  $ projectFlagsOptions ParseArgs++  ]   where-    constraintSrc = ConstraintSourceProjectConfig "TODO"+    constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath   legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]@@ -1048,8 +1062,8 @@           showTokenQ parseTokenQ           configConfigureArgs           (\v conf -> conf { configConfigureArgs = v })-      , simpleField "flags"-          dispFlagAssignment parseFlagAssignment+      , simpleFieldParsec "flags"+          dispFlagAssignment parsecFlagAssignment           configConfigurationsFlags           (\v conf -> conf { configConfigurationsFlags = v })       ]@@ -1095,9 +1109,9 @@   . mapFieldNames       ("haddock-"++)   . addFields-      [ simpleField "for-hackage"+      [ simpleFieldParsec "for-hackage"           -- TODO: turn this into a library function-          (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse))+          (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)           haddockForHackage (\v conf -> conf { haddockForHackage = v })       ]   . filterFields@@ -1144,9 +1158,9 @@    where     overrideFieldCompiler =-      simpleField "compiler"-        (fromFlagOrDefault Disp.empty . fmap disp)-        (Parse.option mempty (fmap toFlag parse))+      simpleFieldParsec "compiler"+        (fromFlagOrDefault Disp.empty . fmap pretty)+        (toFlag <$> parsec <|> pure mempty)         configHcFlavor (\v flags -> flags { configHcFlavor = v })  @@ -1208,7 +1222,11 @@                     | otherwise = "test-" ++ name  -legacyPackageConfigFGSectionDescrs :: [FGSectionDescr LegacyProjectConfig]+legacyPackageConfigFGSectionDescrs+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType), c (List NoCommaFSep FilePathNT String)+       )+    => [FGSectionDescr g LegacyProjectConfig] legacyPackageConfigFGSectionDescrs =     [ packageRepoSectionDescr     ]@@ -1233,7 +1251,11 @@         remoteRepoSectionDescr     ] -packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig+packageRepoSectionDescr+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType), c (List NoCommaFSep FilePathNT String)+       )+    => FGSectionDescr g LegacyProjectConfig packageRepoSectionDescr = FGSectionDescr   { fgSectionName        = "source-repository-package"   , fgSectionGrammar     = sourceRepositoryPackageGrammar@@ -1280,7 +1302,7 @@       sectionFields      = packageSpecificOptionsFieldDescrs,       sectionSubsections = [],       sectionGet         = \projconf ->-                             [ (display pkgname, pkgconf)+                             [ (prettyShow pkgname, pkgconf)                              | (pkgname, pkgconf) <-                                  Map.toList . getMapMappend                                . legacySpecificConfig $ projconf ]@@ -1291,7 +1313,7 @@                    legacyAllConfig = legacyAllConfig projconf <> pkgconf                  }           _   -> do-            pkgname <- case simpleParse pkgnamestr of+            pkgname <- case simpleParsec pkgnamestr of               Just pkgname -> return pkgname               Nothing      -> syntaxError lineno $                                   "a 'package' section requires a package name "@@ -1397,7 +1419,7 @@ remoteRepoSectionDescr :: SectionDescr GlobalFlags remoteRepoSectionDescr = SectionDescr     { sectionName        = "repository"-    , sectionEmpty       = emptyRemoteRepo ""+    , sectionEmpty       = emptyRemoteRepo (RepoName "")     , sectionFields      = remoteRepoFields     , sectionSubsections = []     , sectionGet         = getS@@ -1406,9 +1428,9 @@   where     getS :: GlobalFlags -> [(String, RemoteRepo)]     getS gf =-        map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))+        map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))         ++-        map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))+        map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))      setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags     setS lineno reponame repo0 conf = do@@ -1432,10 +1454,11 @@  -- | Parser combinator for simple fields which uses the field type's -- 'Monoid' instance for combining multiple occurrences of the field.-monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b-monoidField name showF readF get' set =-  liftField get' set' $ ParseUtils.field name showF readF+monoidFieldParsec+    :: Monoid a => String -> (a -> Doc) -> ParsecParser a+    -> (b -> a) -> (a -> b -> b) -> FieldDescr b+monoidFieldParsec name showF readF get' set =+  liftField get' set' $ ParseUtils.fieldParsec name showF readF   where     set' xs b = set (get' b `mappend` xs) b
Distribution/Client/ProjectConfig/Types.hs view
@@ -23,19 +23,21 @@ import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Types-         ( RemoteRepo, LocalRepo, AllowNewer(..), AllowOlder(..)-         , WriteGhcEnvironmentFilesPolicy )+import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo )+import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) )+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) import Distribution.Client.Dependency.Types          ( PreSolver ) import Distribution.Client.Targets          ( UserConstraint ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) )-import Distribution.Client.SourceRepo (SourceRepoList)+import Distribution.Client.Types.SourceRepo (SourceRepoList) -import Distribution.Client.IndexUtils.Timestamp-         ( IndexState )+import Distribution.Client.IndexUtils.IndexState+         ( TotalIndexState )+import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )  import Distribution.Client.CmdInstall.ClientInstallFlags          ( ClientInstallFlags(..) )@@ -62,8 +64,6 @@          ( PathTemplate ) import Distribution.Utils.NubList          ( NubList )-import Distribution.Verbosity-         ( Verbosity )  import qualified Data.Map as Map @@ -163,6 +163,7 @@        projectConfigDistDir           :: Flag FilePath,        projectConfigConfigFile        :: Flag FilePath,        projectConfigProjectFile       :: Flag FilePath,+       projectConfigIgnoreProject     :: Flag Bool,        projectConfigHcFlavor          :: Flag CompilerFlavor,        projectConfigHcPath            :: Flag FilePath,        projectConfigHcPkg             :: Flag FilePath,@@ -178,9 +179,9 @@         -- configuration used both by the solver and other phases        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.-       projectConfigLocalRepos        :: NubList FilePath,        projectConfigLocalNoIndexRepos :: NubList LocalRepo,-       projectConfigIndexState        :: Flag IndexState,+       projectConfigActiveRepos       :: Flag ActiveRepos,+       projectConfigIndexState        :: Flag TotalIndexState,        projectConfigStoreDir          :: Flag FilePath,         -- solver configuration@@ -388,7 +389,6 @@ data SolverSettings    = SolverSettings {        solverSettingRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.-       solverSettingLocalRepos        :: [FilePath],        solverSettingLocalNoIndexRepos :: [LocalRepo],        solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],        solverSettingPreferences       :: [PackageVersionConstraint],@@ -406,7 +406,8 @@        solverSettingStrongFlags       :: StrongFlags,        solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,        solverSettingOnlyConstrained   :: OnlyConstrained,-       solverSettingIndexState        :: Maybe IndexState,+       solverSettingIndexState        :: Maybe TotalIndexState,+       solverSettingActiveRepos       :: Maybe ActiveRepos,        solverSettingIndependentGoals  :: IndependentGoals        -- Things that only make sense for manual mode, not --local mode        -- too much control!@@ -449,7 +450,6 @@        buildSettingOfflineMode           :: Bool,        buildSettingKeepTempFiles         :: Bool,        buildSettingRemoteRepos           :: [RemoteRepo],-       buildSettingLocalRepos            :: [FilePath],        buildSettingLocalNoIndexRepos     :: [LocalRepo],        buildSettingCacheDir              :: FilePath,        buildSettingHttpTransport         :: Maybe String,
+ Distribution/Client/ProjectFlags.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+module Distribution.Client.ProjectFlags (+    ProjectFlags(..),+    defaultProjectFlags,+    projectFlagsOptions,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.ReadE          (succeedReadE)+import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg)+import Distribution.Simple.Setup   (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)++data ProjectFlags = ProjectFlags+    { flagProjectFileName :: Flag FilePath+      -- ^ The cabal project file name; defaults to @cabal.project@.+      -- The name itself denotes the cabal project file name, but it also+      -- is the base of auxiliary project files, such as+      -- @cabal.project.local@ and @cabal.project.freeze@ which are also+      -- read and written out in some cases.  If the path is not found+      -- in the current working directory, we will successively probe+      -- relative to parent directories until this name is found.++    , flagIgnoreProject   :: Flag Bool+      -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)+      -- The exact interpretation might be slightly different per command.+    }+  deriving (Show, Generic)++defaultProjectFlags :: ProjectFlags+defaultProjectFlags = ProjectFlags+    { flagProjectFileName = mempty+    , flagIgnoreProject   = toFlag False+      -- Should we use 'Last' here?+    }++projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]+projectFlagsOptions showOrParseArgs =+    [ option [] ["project-file"]+        "Set the name of the cabal.project file to search for in parent directories"+        flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf })+        (reqArg "FILE" (succeedReadE Flag) flagToList)+    , option ['z'] ["ignore-project"]+        "Ignore local project configuration"+        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v })+        (yesNoOpt showOrParseArgs)+    ]++instance Monoid ProjectFlags where+    mempty = gmempty+    mappend = (<>)++instance Semigroup ProjectFlags where+    (<>) = gmappend++yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b+yesNoOpt ShowArgs sf lf = trueArg sf lf+yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
Distribution/Client/ProjectOrchestration.hs view
@@ -43,6 +43,7 @@     -- * Discovery phase: what is in the project?     CurrentCommand(..),     establishProjectBaseContext,+    establishProjectBaseContextWithRoot,     ProjectBaseContext(..),     BuildTimeSettings(..),     commandLineFlagsToProjectConfig,@@ -67,7 +68,6 @@     ComponentKind(..),     ComponentTarget(..),     SubComponentTarget(..),-    TargetProblemCommon(..),     selectComponentTargetBasic,     distinctTargetComponents,     -- ** Utils for selecting targets@@ -93,8 +93,9 @@     runProjectPostBuildPhase,     dieOnBuildFailures, -    -- * Shared CLI utils-    cmdCommonHelpTextNewBuildBeta,+    -- * Dummy projects+    establishDummyProjectBaseContext,+    establishDummyDistDirLayout,   ) where  import Prelude ()@@ -110,7 +111,10 @@ import           Distribution.Client.ProjectPlanning.Types import           Distribution.Client.ProjectBuilding import           Distribution.Client.ProjectPlanOutput+import           Distribution.Client.RebuildMonad ( runRebuild ) +import           Distribution.Client.TargetProblem+                   ( TargetProblem (..) ) import           Distribution.Client.Types                    ( GenericReadyPackage(..), UnresolvedSourcePackage                    , PackageSpecifier(..)@@ -136,35 +140,29 @@ import           Distribution.Solver.Types.OptionalStanza  import           Distribution.Package-import           Distribution.PackageDescription-                   ( FlagAssignment, unFlagAssignment, showFlagValue-                   , diffFlagAssignment )+import           Distribution.Types.Flag+                   ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) import           Distribution.Simple.LocalBuildInfo                    ( ComponentName(..), pkgComponents ) import           Distribution.Simple.Flag-                   ( fromFlagOrDefault )+                   ( fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Setup import           Distribution.Simple.Command (commandShowOptions) import           Distribution.Simple.Configure (computeEffectiveProfiling)  import           Distribution.Simple.Utils-                   ( die', warn, notice, noticeNoWrap, debugNoWrap )+                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose ) import           Distribution.Verbosity import           Distribution.Version                    ( mkVersion )-import           Distribution.Pretty-                   ( prettyShow ) import           Distribution.Simple.Compiler                    ( compilerCompatVersion, showCompilerId                    , OptimisationLevel(..)) -import qualified Data.Monoid as Mon import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Map as Map-import           Data.Either-import           Control.Exception (Exception(..), throwIO, assert)-import           System.Exit (ExitCode(..), exitFailure)+import           Control.Exception (assert) #ifdef MIN_VERSION_unix import           System.Posix.Signals (sigKILL, sigSEGV) #endif@@ -187,18 +185,29 @@        currentCommand :: CurrentCommand      } -establishProjectBaseContext :: Verbosity-                            -> ProjectConfig-                            -> CurrentCommand-                            -> IO ProjectBaseContext+establishProjectBaseContext+    :: Verbosity+    -> ProjectConfig+    -> CurrentCommand+    -> IO ProjectBaseContext establishProjectBaseContext verbosity cliConfig currentCommand = do+    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile+    establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand+  where+    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile+    ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig +-- | Like 'establishProjectBaseContext' but doesn't search for project root.+establishProjectBaseContextWithRoot+    :: Verbosity+    -> ProjectConfig+    -> ProjectRoot+    -> CurrentCommand+    -> IO ProjectBaseContext+establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do     cabalDir <- getCabalDir-    projectRoot <- either throwIO return =<<-                   findProjectRoot Nothing mprojectFile -    let distDirLayout  = defaultDistDirLayout projectRoot-                                              mdistDirectory+    let distDirLayout  = defaultDistDirLayout projectRoot mdistDirectory      (projectConfig, localPackages) <-       rebuildProjectConfig verbosity@@ -236,11 +245,7 @@     }   where     mdistDirectory = Setup.flagToMaybe projectConfigDistDir-    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile-    ProjectConfigShared {-      projectConfigDistDir,-      projectConfigProjectFile-    } = projectConfigShared cliConfig+    ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig   -- | This holds the context between the pre-build, build and post-build phases.@@ -292,7 +297,7 @@     -- everything in the project. This is independent of any specific targets     -- the user has asked for.     ---    (elaboratedPlan, _, elaboratedShared) <-+    (elaboratedPlan, _, elaboratedShared, _, _) <-       rebuildInstallPlan verbosity                          distDirLayout cabalDirLayout                          projectConfig@@ -317,7 +322,7 @@     -- everything in the project. This is independent of any specific targets     -- the user has asked for.     ---    (elaboratedPlan, _, elaboratedShared) <-+    (elaboratedPlan, _, elaboratedShared, _, _) <-       rebuildInstallPlan verbosity                          distDirLayout cabalDirLayout                          projectConfig@@ -505,16 +510,15 @@ resolveTargets :: forall err.                   (forall k. TargetSelector                           -> [AvailableTarget k]-                          -> Either err [k])+                          -> Either (TargetProblem err) [k])                -> (forall k. SubComponentTarget                           -> AvailableTarget k-                          -> Either err  k )-               -> (TargetProblemCommon -> err)+                          -> Either (TargetProblem err)  k )                -> ElaboratedInstallPlan                -> Maybe (SourcePackageDb)                -> [TargetSelector]-               -> Either [err] TargetsMap-resolveTargets selectPackageTargets selectComponentTarget liftProblem+               -> Either [TargetProblem err] TargetsMap+resolveTargets selectPackageTargets selectComponentTarget                installPlan mPkgDb =       fmap mkTargetsMap     . either (Left . toList) Right@@ -532,7 +536,7 @@      AvailableTargetIndexes{..} = availableTargetIndexes installPlan -    checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)]+    checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]      -- We can ask to build any whole package, project-local or a dependency     checkTarget bt@(TargetPackage _ [pkgid] mkfilter)@@ -542,10 +546,11 @@       $ selectPackageTargets bt ats        | otherwise-      = Left (liftProblem (TargetProblemNoSuchPackage pkgid))+      = Left (TargetProblemNoSuchPackage pkgid) -    checkTarget (TargetPackage _ _ _)-      = error "TODO: add support for multiple packages in a directory"+    checkTarget (TargetPackage _ pkgids _)+      = error ("TODO: add support for multiple packages in a directory.  Got\n"+              ++ unlines (map prettyShow pkgids))       -- For the moment this error cannot happen here, because it gets       -- detected when the package config is being constructed. This case       -- will need handling properly when we do add support.@@ -568,10 +573,10 @@       $ selectComponentTargets subtarget ats        | Map.member pkgid availableTargetsByPackageId-      = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname))+      = Left (TargetProblemNoSuchComponent pkgid cname)        | otherwise-      = Left (liftProblem (TargetProblemNoSuchPackage pkgid))+      = Left (TargetProblemNoSuchPackage pkgid)      checkTarget (TargetComponentUnknown pkgname ecname subtarget)       | Just ats <- case ecname of@@ -585,10 +590,10 @@       $ selectComponentTargets subtarget ats        | Map.member pkgname availableTargetsByPackageName-      = Left (liftProblem (TargetProblemUnknownComponent pkgname ecname))+      = Left (TargetProblemUnknownComponent pkgname ecname)        | otherwise-      = Left (liftProblem (TargetNotInProject pkgname))+      = Left (TargetNotInProject pkgname)      checkTarget bt@(TargetPackageNamed pkgname mkfilter)       | Just ats <- fmap (maybe id filterTargetsKind mkfilter)@@ -600,10 +605,10 @@       | Just SourcePackageDb{ packageIndex } <- mPkgDb       , let pkg = lookupPackageName packageIndex pkgname       , not (null pkg)-      = Left (liftProblem (TargetAvailableInIndex pkgname))+      = Left (TargetAvailableInIndex pkgname)        | otherwise-      = Left (liftProblem (TargetNotInProject pkgname))+      = Left (TargetNotInProject pkgname)      componentTargets :: SubComponentTarget                      -> [(b, ComponentName)]@@ -613,7 +618,7 @@      selectComponentTargets :: SubComponentTarget                            -> [AvailableTarget k]-                           -> Either err [k]+                           -> Either (TargetProblem err) [k]     selectComponentTargets subtarget =         either (Left . NE.head) Right       . checkErrors@@ -752,7 +757,7 @@ -- selectComponentTargetBasic :: SubComponentTarget                            -> AvailableTarget k-                           -> Either TargetProblemCommon k+                           -> Either (TargetProblem a) k selectComponentTargetBasic subtarget                            AvailableTarget {                              availableTargetPackageId     = pkgid,@@ -775,32 +780,6 @@       TargetBuildable targetKey _ ->         Right targetKey -data TargetProblemCommon-   = TargetNotInProject                   PackageName-   | TargetAvailableInIndex               PackageName--   | TargetComponentNotProjectLocal-     PackageId ComponentName SubComponentTarget--   | TargetComponentNotBuildable-     PackageId ComponentName SubComponentTarget--   | TargetOptionalStanzaDisabledByUser-     PackageId ComponentName SubComponentTarget--   | TargetOptionalStanzaDisabledBySolver-     PackageId ComponentName SubComponentTarget--   | TargetProblemUnknownComponent-     PackageName (Either UnqualComponentName ComponentName)--    -- The target matching stuff only returns packages local to the project,-    -- so these lookups should never fail, but if 'resolveTargets' is called-    -- directly then of course it can.-   | TargetProblemNoSuchPackage           PackageId-   | TargetProblemNoSuchComponent         PackageId ComponentName-  deriving (Eq, Show)- -- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts -- for the extra unneeded info in the 'TargetsMap'. --@@ -871,21 +850,20 @@               | otherwise          = "will"      showPkgAndReason :: ElaboratedReadyPackage -> String-    showPkgAndReason (ReadyPackage elab) =-      " - " ++-      (if verbosity >= deafening+    showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $+      [ " -"+      , if verbosity >= deafening         then prettyShow (installedUnitId elab)         else prettyShow (packageId elab)-        ) ++-      (case elabPkgOrComp elab of+      , case elabPkgOrComp elab of           ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)           ElabComponent comp ->-            " (" ++ showComp elab comp ++ ")"-            ) ++-      showFlagAssignment (nonDefaultFlags elab) ++-      showConfigureFlags elab ++-      let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in-      " (" ++ showBuildStatus buildStatus ++ ")"+            "(" ++ showComp elab comp ++ ")"+      , showFlagAssignment (nonDefaultFlags elab)+      , showConfigureFlags elab+      , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab+        in "(" ++ showBuildStatus buildStatus ++ ")"+      ]      showComp elab comp =         maybe "custom" prettyShow (compComponentName comp) ++@@ -910,14 +888,11 @@     showTargets elab       | null (elabBuildTargets elab) = ""       | otherwise-      = " ("+      = "("         ++ intercalate ", " [ showComponentTarget (packageId elab) t                             | t <- elabBuildTargets elab ]         ++ ")" -    showFlagAssignment :: FlagAssignment -> String-    showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment-     showConfigureFlags elab =         let fullConfigureFlags               = setupHsConfigureFlags@@ -936,7 +911,7 @@               computeEffectiveProfiling fullConfigureFlags              partialConfigureFlags-              = Mon.mempty {+              = mempty {                 configProf    =                     nubFlag False (configProf fullConfigureFlags),                 configProfExe =@@ -1215,15 +1190,66 @@        ShowBuildSummaryOnly   BuildFailureReason      | ShowBuildSummaryAndLog BuildFailureReason FilePath +-------------------------------------------------------------------------------+-- Dummy projects+------------------------------------------------------------------------------- -cmdCommonHelpTextNewBuildBeta :: String-cmdCommonHelpTextNewBuildBeta =-    "Note: this command is part of the new project-based system (aka "- ++ "nix-style\nlocal builds). These features are currently in beta. "- ++ "Please see\n"- ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "- ++ "for\ndetails and advice on what you can expect to work. If you "- ++ "encounter problems\nplease file issues at "- ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "- ++ "to get involved and help with testing, fixing bugs etc then\nthat "- ++ "is very much appreciated.\n"+-- | Create a dummy project context, without a .cabal or a .cabal.project file+-- (a place where to put a temporary dist directory is still needed)+establishDummyProjectBaseContext+  :: Verbosity+  -> ProjectConfig+  -> DistDirLayout+     -- ^ Where to put the dist directory+  -> [PackageSpecifier UnresolvedSourcePackage]+     -- ^ The packages to be included in the project+  -> CurrentCommand+  -> IO ProjectBaseContext+establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do+    cabalDir <- getCabalDir++    globalConfig <- runRebuild ""+                  $ readGlobalConfig verbosity+                  $ projectConfigConfigFile+                  $ projectConfigShared cliConfig+    let projectConfig = globalConfig <> cliConfig++    let ProjectConfigBuildOnly {+          projectConfigLogsDir+        } = projectConfigBuildOnly projectConfig++        ProjectConfigShared {+          projectConfigStoreDir+        } = projectConfigShared projectConfig++        mlogsDir = flagToMaybe projectConfigLogsDir+        mstoreDir = flagToMaybe projectConfigStoreDir+        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir++        buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings,+      currentCommand+    }++establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout+establishDummyDistDirLayout verbosity cliConfig tmpDir = do+    let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory++    -- Create the dist directories+    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout+    createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout++    return distDirLayout+  where+    mdistDirectory = flagToMaybe+                   $ projectConfigDistDir+                   $ projectConfigShared cliConfig+    projectRoot = ProjectRootImplicit tmpDir
Distribution/Client/ProjectPlanOutput.hs view
@@ -18,9 +18,12 @@ import           Distribution.Client.ProjectPlanning.Types import           Distribution.Client.ProjectBuilding.Types import           Distribution.Client.DistDirLayout-import           Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId)+import           Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..))+import           Distribution.Client.Types.PackageLocation (PackageLocation(..))+import           Distribution.Client.Types.ConfiguredId (confInstId)+import           Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import           Distribution.Client.HashValue (showHashValue, hashValue)-import           Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))+import           Distribution.Client.Utils (cabalInstallVersion)  import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J@@ -41,13 +44,13 @@                    ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)                    , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile                    , writeGhcEnvironmentFile )-import           Distribution.Deprecated.Text+import           Distribution.Simple.BuildPaths+                   ( dllExtension, exeExtension ) import qualified Distribution.Compat.Graph as Graph import           Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary import           Distribution.Simple.Utils import           Distribution.Verbosity-import qualified Paths_cabal_install as Our (version)  import Prelude () import Distribution.Client.Compat.Prelude@@ -88,7 +91,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =     --TODO: [nice to have] include all of the sharedPackageConfig and all of     --      the parts of the elaboratedInstallPlan-    J.object [ "cabal-version"     J..= jdisplay Our.version+    J.object [ "cabal-version"     J..= jdisplay cabalInstallVersion              , "cabal-lib-version" J..= jdisplay cabalVersion              , "compiler-id"       J..= (J.String . showCompilerId . pkgConfigCompiler)                                         elaboratedSharedConfig@@ -97,7 +100,7 @@              , "install-plan"      J..= installPlanToJ elaboratedInstallPlan              ]   where-    Platform arch os = pkgConfigPlatform elaboratedSharedConfig+    plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig      installPlanToJ :: ElaboratedInstallPlan -> [J.Value]     installPlanToJ = map planPackageToJ . InstallPlan.toList@@ -199,10 +202,6 @@       repoToJ :: Repo -> J.Value       repoToJ repo =         case repo of-          RepoLocal{..} ->-            J.object [ "type" J..= J.String "local-repo"-                     , "path" J..= J.String repoLocalDir-                     ]           RepoLocalNoIndex{..} ->             J.object [ "type" J..= J.String "local-repo-no-index"                      , "path" J..= J.String repoLocalDir@@ -233,33 +232,32 @@         ComponentDeps.ComponentExe s   -> bin_file' s         ComponentDeps.ComponentTest s  -> bin_file' s         ComponentDeps.ComponentBench s -> bin_file' s+        ComponentDeps.ComponentFLib s  -> flib_file' s         _ -> []       bin_file' s =         ["bin-file" J..= J.String bin]        where         bin = if elabBuildStyle elab == BuildInplaceOnly-               then dist_dir </> "build" </> display s </> display s-               else InstallDirs.bindir (elabInstallDirs elab) </> display s+               then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat+               else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat -    -- TODO: maybe move this helper to "ComponentDeps" module?-    --       Or maybe define a 'Text' instance?+      flib_file' s =+        ["bin-file" J..= J.String bin]+       where+        bin = if elabBuildStyle elab == BuildInplaceOnly+               then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat+               else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat+     comp2str :: ComponentDeps.Component -> String-    comp2str c = case c of-        ComponentDeps.ComponentLib     -> "lib"-        ComponentDeps.ComponentSubLib s -> "lib:"   <> display s-        ComponentDeps.ComponentFLib s  -> "flib:"  <> display s-        ComponentDeps.ComponentExe s   -> "exe:"   <> display s-        ComponentDeps.ComponentTest s  -> "test:"  <> display s-        ComponentDeps.ComponentBench s -> "bench:" <> display s-        ComponentDeps.ComponentSetup   -> "setup"+    comp2str = prettyShow      style2str :: Bool -> BuildStyle -> String     style2str True  _                = "local"     style2str False BuildInplaceOnly = "inplace"     style2str False BuildAndInstall  = "global" -    jdisplay :: Text a => a -> J.Value-    jdisplay = J.String . display+    jdisplay :: Pretty a => a -> J.Value+    jdisplay = J.String . prettyShow   -----------------------------------------------------------------------------@@ -694,7 +692,7 @@      return currentBuildStatus   where-    displayPackageIdSet = intercalate ", " . map display . Set.toList+    displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList  -- | Helper for reading the cache file. --@@ -838,7 +836,7 @@                  selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan     -- TODO use proper flags? but packageDbArgsDb is private     clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]-    packageIdFlag uid = ["-package-id", display uid]+    packageIdFlag uid = ["-package-id", prettyShow uid]   -- We're producing an environment for users to use in ghci, so of course
Distribution/Client/ProjectPlanning.hs view
@@ -110,6 +110,7 @@ import           Distribution.Solver.Types.SourcePackage import           Distribution.Solver.Types.Settings +import           Distribution.CabalSpecVersion import           Distribution.ModuleName import           Distribution.Package import           Distribution.Types.AnnotatedId@@ -125,7 +126,7 @@ import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import           Distribution.Simple.PackageIndex (InstalledPackageIndex)-import           Distribution.Simple.Compiler hiding (Flag)+import           Distribution.Simple.Compiler import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate import           Distribution.Simple.Program@@ -152,24 +153,18 @@  import           Distribution.Simple.Utils import           Distribution.Version-import           Distribution.Verbosity-import           Distribution.Deprecated.Text  import qualified Distribution.Compat.Graph as Graph import           Distribution.Compat.Graph(IsNode(..)) -import           Text.PrettyPrint hiding ((<>))+import           Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map import qualified Data.Set as Set-import           Control.Monad-import qualified Data.Traversable as T import           Control.Monad.State as State-import           Control.Exception+import           Control.Exception (assert) import           Data.List (groupBy) import qualified Data.List.NonEmpty as NE-import           Data.Either-import           Data.Function import           System.FilePath  ------------------------------------------------------------------------------@@ -396,8 +391,11 @@                    -> [PackageSpecifier UnresolvedSourcePackage]                    -> IO ( ElaboratedInstallPlan  -- with store packages                          , ElaboratedInstallPlan  -- with source packages-                         , ElaboratedSharedConfig )-                      -- ^ @(improvedPlan, elaboratedPlan, _, _)@+                         , ElaboratedSharedConfig+                         , IndexUtils.TotalIndexState+                         , IndexUtils.ActiveRepos+                         )+                      -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ rebuildInstallPlan verbosity                    distDirLayout@DistDirLayout {                      distProjectRootDirectory,@@ -417,14 +415,14 @@                    (projectConfigMonitored, localPackages, progsearchpath) $ do        -- And so is the elaborated plan that the improved plan based on-      (elaboratedPlan, elaboratedShared) <-+      (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-         rerunIfChanged verbosity fileMonitorElaboratedPlan                        (projectConfigMonitored, localPackages,                         progsearchpath) $ do            compilerEtc   <- phaseConfigureCompiler projectConfig           _             <- phaseConfigurePrograms projectConfig compilerEtc-          (solverPlan, pkgConfigDB)+          (solverPlan, pkgConfigDB, totalIndexState, activeRepos)                         <- phaseRunSolver         projectConfig                                                   compilerEtc                                                   localPackages@@ -435,14 +433,14 @@                                                    localPackages            phaseMaintainPlanOutputs elaboratedPlan elaboratedShared-          return (elaboratedPlan, elaboratedShared)+          return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)        -- The improved plan changes each time we install something, whereas       -- the underlying elaborated plan only changes when input config       -- changes, so it's worth caching them separately.       improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared -      return (improvedPlan, elaboratedPlan, elaboratedShared)+      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)    where     fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"@@ -543,10 +541,11 @@     -- Run the solver to get the initial install plan.     -- This is expensive so we cache it independently.     ---    phaseRunSolver :: ProjectConfig-                   -> (Compiler, Platform, ProgramDb)-                   -> [PackageSpecifier UnresolvedSourcePackage]-                   -> Rebuild (SolverInstallPlan, PkgConfigDb)+    phaseRunSolver+        :: ProjectConfig+        -> (Compiler, Platform, ProgramDb)+        -> [PackageSpecifier UnresolvedSourcePackage]+        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)     phaseRunSolver projectConfig@ProjectConfig {                      projectConfigShared,                      projectConfigBuildOnly@@ -561,8 +560,9 @@           installedPkgIndex <- getInstalledPackages verbosity                                                     compiler progdb platform                                                     corePackageDbs-          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx-                                 (solverSettingIndexState solverSettings)+          (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx+              (solverSettingIndexState solverSettings)+              (solverSettingActiveRepos solverSettings)           pkgConfigDB       <- getPkgConfigDb verbosity progdb            --TODO: [code cleanup] it'd be better if the Compiler contained the@@ -580,7 +580,7 @@               planPackages verbosity compiler platform solver solverSettings                            installedPkgIndex sourcePkgDb pkgConfigDB                            localPackages localPackagesEnabledStanzas-            return (plan, pkgConfigDB)+            return (plan, pkgConfigDB, tis, ar)       where         corePackageDbs = [GlobalPackageDB]         withRepoCtx    = projectConfigWithSolverRepoContext verbosity@@ -593,6 +593,10 @@           Map.fromList             [ (pkgname, stanzas)             | pkg <- localPackages+              -- TODO: misnormer: we should separate+              -- builtin/global/inplace/local packages+              -- and packages explicitly mentioned in the project+              --             , let pkgname            = pkgSpecifierTarget pkg                   testsEnabled       = lookupLocalPackageConfig                                          packageConfigTests@@ -600,12 +604,14 @@                   benchmarksEnabled  = lookupLocalPackageConfig                                          packageConfigBenchmarks                                          projectConfig pkgname-                  stanzas =-                    Map.fromList $+                  isLocal = isJust (shouldBeLocal pkg)+                  stanzas+                    | isLocal = Map.fromList $                       [ (TestStanzas, enabled)-                      | enabled <- flagToList testsEnabled ]-                   ++ [ (BenchStanzas , enabled)+                      | enabled <- flagToList testsEnabled ] +++                      [ (BenchStanzas , enabled)                       | enabled <- flagToList benchmarksEnabled ]+                    | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ]             ]      -- Elaborate the solver's install plan to get a fully detailed plan. This@@ -757,20 +763,23 @@                                  packagedb progdb -} -getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)-                  -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb-getSourcePackages verbosity withRepoCtx idxState = do-    (sourcePkgDb, repos) <-+getSourcePackages+    :: Verbosity+    -> (forall a. (RepoContext -> IO a) -> IO a)+    -> Maybe IndexUtils.TotalIndexState+    -> Maybe IndexUtils.ActiveRepos+    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)+getSourcePackages verbosity withRepoCtx idxState activeRepos = do+    (sourcePkgDbWithTIS, repos) <-       liftIO $         withRepoCtx $ \repoctx -> do-          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity-                                                                  repoctx idxState-          return (sourcePkgDb, repoContextRepos repoctx)+          sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos+          return (sourcePkgDbWithTIS, repoContextRepos repoctx) -    mapM_ needIfExists+    traverse_ needIfExists         . IndexUtils.getSourcePackagesMonitorFiles         $ repos-    return sourcePkgDb+    return sourcePkgDbWithTIS   getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb@@ -778,7 +787,7 @@     dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb     -- Just monitor the dirs so we'll notice new .pc files.     -- Alternatively we could monitor all the .pc files too.-    mapM_ monitorDirectoryStatus dirs+    traverse_ monitorDirectoryStatus dirs     liftIO $ readPkgConfigDb verbosity progdb  @@ -786,7 +795,7 @@ packageLocationsSignature :: SolverInstallPlan                           -> [(PackageId, PackageLocation (Maybe FilePath))] packageLocationsSignature solverPlan =-    [ (packageId pkg, packageSource pkg)+    [ (packageId pkg, srcpkgSource pkg)     | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})         <- SolverInstallPlan.toList solverPlan     ]@@ -807,7 +816,7 @@     --     let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]         allPkgLocations =-          [ (packageId pkg, packageSource pkg)+          [ (packageId pkg, srcpkgSource pkg)           | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})               <- SolverInstallPlan.toList solverPlan ] @@ -820,11 +829,15 @@          -- Tarballs from remote URLs. We must have downloaded these already         -- (since we extracted the .cabal file earlier)-        --TODO: [required eventually] finish remote tarball functionality---        allRemoteTarballPkgs =---          [ (pkgid, )---          | (pkgid, RemoteTarballPackage ) <- allPkgLocations ]+        remoteTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] +        -- tarballs from source-repository-package stanzas+        sourceRepoTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ]+         -- Tarballs from repositories, either where the repository provides         -- hashes as part of the repo metadata, or where we will have to         -- download and hash the tarball.@@ -903,6 +916,8 @@     --     let allTarballFilePkgs :: [(PackageId, FilePath)]         allTarballFilePkgs = localTarballPkgs+                          ++ remoteTarballPkgs+                          ++ sourceRepoTarballPkgs                           ++ repoTarballPkgsDownloaded                           ++ repoTarballPkgsNewlyDownloaded     hashesFromTarballFiles <- liftIO $@@ -992,7 +1007,7 @@        . addDefaultSetupDependencies (defaultSetupDeps comp platform                                    . PD.packageDescription-                                   . packageDescription)+                                   . srcpkgDescription)        . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint       . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint@@ -1085,6 +1100,8 @@     -- respective major Cabal version bundled with the respective GHC     -- release).     --+    -- GHC 9.0   needs  Cabal >= 3.4+    -- GHC 8.10  needs  Cabal >= 3.2     -- GHC 8.8   needs  Cabal >= 3.0     -- GHC 8.6   needs  Cabal >= 2.4     -- GHC 8.4   needs  Cabal >= 2.2@@ -1098,6 +1115,7 @@     -- TODO: long-term, this compatibility matrix should be     --       stored as a field inside 'Distribution.Compiler.Compiler'     setupMinCabalVersionConstraint+      | isGHC, compVer >= mkVersion [9,0]  = mkVersion [3,4]       | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]       | isGHC, compVer >= mkVersion [8,8]  = mkVersion [3,0]       | isGHC, compVer >= mkVersion [8,6]  = mkVersion [2,4]@@ -1287,7 +1305,7 @@             let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace"                             | otherwise                  = Disp.empty             in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+>-                             quotes (disp (packageId pkg))) $+                             quotes (pretty (packageId pkg))) $                map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg      -- NB: We don't INSTANTIATE packages at this point.  That's@@ -1300,7 +1318,7 @@         = case mkComponentsGraph (elabEnabledSpec elab0) pd of            Right g -> do             let src_comps = componentsGraphToList g-            infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon)+            infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon)                             4 (dispComponentsWithDeps src_comps)             (_, comps) <- mapAccumM buildComponent                             (Map.empty, Map.empty, Map.empty)@@ -1340,7 +1358,7 @@             -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8             -- see, https://github.com/haskell/cabal/issues/4121             cuz_spec-                | PD.specVersion pd >= mkVersion [1,8] = []+                | PD.specVersion pd >= CabalSpecV1_8 = []                 | otherwise = cuz "cabal-version is less than 1.8"             -- In the odd corner case that a package has no components at all             -- then keep it as a whole package, since otherwise it turns into@@ -1461,10 +1479,10 @@                 cid = case elabBuildStyle elab0 of                         BuildInplaceOnly ->                           mkComponentId $-                            display pkgid ++ "-inplace" +++                            prettyShow pkgid ++ "-inplace" ++                               (case Cabal.componentNameString cname of                                   Nothing -> ""-                                  Just s -> "-" ++ display s)+                                  Just s -> "-" ++ prettyShow s)                         BuildAndInstall ->                           hashedInstalledPackageId                             (packageHashInputs@@ -1477,7 +1495,7 @@             let lookup_uid def_uid =                     case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of                         Just full -> full-                        Nothing -> error ("lookup_uid: " ++ display def_uid)+                        Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)             lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)                         (Map.union external_lc_map lc_map) cc             infoProgress $ dispLinkedComponent lc@@ -1555,8 +1573,8 @@              compPkgConfigDependencies =                 [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "-                                            ++ display pn ++ " from "-                                            ++ display (elabPkgSourceId elab0))+                                            ++ prettyShow pn ++ " from "+                                            ++ prettyShow (elabPkgSourceId elab0))                                  (pkgConfigDbPkgVersion pkgConfigDB pn))                 | PkgconfigDependency pn _ <- PD.pkgconfigDepends                                                 (Cabal.componentBuildInfo comp) ]@@ -1567,7 +1585,7 @@                     elaboratedSharedConfig                     elab $                     case Cabal.componentNameString cname of-                             Just n -> display n+                             Just n -> prettyShow n                              Nothing -> ""  @@ -1599,7 +1617,7 @@                     ElabComponent comp ->                         case fmap Cabal.componentNameString                                   (compComponentName comp) of-                            Just (Just n) -> [display n]+                            Just (Just n) -> [prettyShow n]                             _ -> [""]             in               binDirectoryFor@@ -1613,7 +1631,7 @@                              -> [ElaboratedConfiguredPackage]                              -> ElaboratedConfiguredPackage     elaborateSolverToPackage-        pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride)+        pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride)                            _flags _stanzas _deps0 _exe_deps0)         compGraph comps =         -- Knot tying: the final elab includes the@@ -1643,7 +1661,7 @@          pkgInstalledId           | shouldBuildInplaceOnly pkg-          = mkComponentId (display pkgid ++ "-inplace")+          = mkComponentId (prettyShow pkgid ++ "-inplace")            | otherwise           = assert (isJust elabPkgSourceHash) $@@ -1654,7 +1672,7 @@            | otherwise           = error $ "elaborateInstallPlan: non-inplace package "-                 ++ " is missing a source hash: " ++ display pkgid+                 ++ " is missing a source hash: " ++ prettyShow pkgid          -- Need to filter out internal dependencies, because they don't         -- correspond to anything real anymore.@@ -1922,16 +1940,6 @@         Set.fromList (catMaybes (map shouldBeLocal localPackages))         --TODO: localPackages is a misnomer, it's all project packages         -- here is where we decide which ones will be local!-      where-        shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId-        shouldBeLocal NamedPackage{}              = Nothing-        shouldBeLocal (SpecificSourcePackage pkg)-          | LocalTarballPackage _ <- packageSource pkg = Nothing-          | otherwise = Just (packageId pkg)-        -- TODO: Is it only LocalTarballPackages we can know about without-        -- them being "local" in the sense meant here?-        ---        -- Also, review use of SourcePackage's loc vs ProjectPackageLocation      pkgsUseSharedLibrary :: Set PackageId     pkgsUseSharedLibrary =@@ -1992,6 +2000,12 @@  -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping +shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId+shouldBeLocal NamedPackage{}              = Nothing+shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of+    LocalUnpackedPackage _ -> Just (packageId pkg)+    _                      -> Nothing+ -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)@@ -2020,7 +2034,7 @@                 (Cabal.pkgBuildableComponents (elabPkgDescription elab))  -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName'--- and 'ComponentName' to the 'ComponentId' that that should be used+-- and 'ComponentName' to the 'ComponentId' that should be used -- in this case. mkCCMapping :: ElaboratedPlanPackage             -> (PackageName, Map ComponentName (AnnotatedId ComponentId))@@ -2087,9 +2101,9 @@   BuildAndInstall -> [installedBinDirectory package]   BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of     ElabComponent comp -> case compSolverName comp of-      CD.ComponentExe n -> [display n]+      CD.ComponentExe n -> [prettyShow n]       _ -> []-    ElabPackage _ -> map (display . PD.exeName)+    ElabPackage _ -> map (prettyShow . PD.exeName)                    . PD.executables                    . elabPkgDescription                    $ package@@ -2155,7 +2169,7 @@       = case planpkg of           InstallPlan.Configured (elab0@ElaboratedConfiguredPackage                                     { elabPkgOrComp = ElabComponent comp }) -> do-            deps <- mapM (substUnitId insts)+            deps <- traverse (substUnitId insts)                          (compLinkedLibDependencies comp)             let getDep (Module dep_uid _) = [dep_uid]                 elab1 = elab0 {@@ -2178,7 +2192,7 @@                   }             return $ InstallPlan.Configured elab           _ -> return planpkg-      | otherwise = error ("instantiateComponent: " ++ display cid)+      | otherwise = error ("instantiateComponent: " ++ prettyShow cid)      substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId     substUnitId _ (DefiniteUnitId uid) =@@ -2191,7 +2205,7 @@     substSubst :: Map ModuleName Module                -> Map ModuleName OpenModule                -> InstM (Map ModuleName Module)-    substSubst subst insts = T.mapM (substModule subst) insts+    substSubst subst insts = traverse (substModule subst) insts      substModule :: Map ModuleName Module -> OpenModule -> InstM Module     substModule subst (OpenModuleVar mod_name)@@ -2228,7 +2242,7 @@            -- we initially created the ElaboratedPlanPackage because            -- we have no way of actually refiying the UnitId into a            -- DefiniteUnitId (that's what substUnitId does!)-           new_deps <- forM (compLinkedLibDependencies elab_comp) $ \uid ->+           new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->              if Set.null (openUnitIdFreeHoles uid)                 then fmap DefiniteUnitId (substUnitId Map.empty uid)                 else return uid@@ -2246,11 +2260,11 @@            }       | Just planpkg <- Map.lookup cid cmap       = return planpkg-      | otherwise = error ("indefiniteComponent: " ++ display cid)+      | otherwise = error ("indefiniteComponent: " ++ prettyShow cid)      ready_map = execState work Map.empty -    work = forM_ pkgs $ \pkg ->+    work = for_ pkgs $ \pkg ->             case pkg of                 InstallPlan.Configured elab                     | not (Map.null (elabLinkedInstantiatedWith elab))@@ -2466,7 +2480,7 @@               (Nothing,   True)  -> TargetBuildable (elabUnitId elab, cname)                                                     TargetNotRequestedByDefault               (Just True, False) ->-                error "componentAvailableTargetStatus: impossible"+                error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname       where         cname      = componentName component         buildable  = PD.buildable (componentBuildInfo component)@@ -2975,10 +2989,11 @@ -- less than 1.23. -- -- In cases 1 and 2 we obviously have to build an external Setup.hs script,--- while in case 4 we can use the internal library API. In case 3 we also have--- to build an external Setup.hs script because the package needs a later--- Cabal lib version than we can support internally.+-- while in case 4 we can use the internal library API. --+-- TODO:In case 3 we should fail. We don't know how to talk to+-- newer ./Setup.hs+-- -- data SetupScriptStyle = ...  -- see ProjectPlanning.Types  -- | Work out the 'SetupScriptStyle' given the package description.@@ -2999,7 +3014,8 @@   , Nothing <- PD.setupBuildInfo pkg      -- we get this case pre-solver   = SetupCustomImplicitDeps -  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against+  -- here we should fail.+  | PD.specVersion pkg > cabalSpecLatest  -- one cabal-install is built against   = SetupNonCustomExternalLib    | otherwise@@ -3038,9 +3054,9 @@       -- of other packages.       SetupCustomImplicitDeps ->         Just $-        [ Dependency depPkgname anyVersion (Set.singleton LMainLibName)+        [ Dependency depPkgname anyVersion mainLibSet         | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++-        [ Dependency cabalPkgname cabalConstraint (Set.singleton LMainLibName)+        [ Dependency cabalPkgname cabalConstraint mainLibSet         | packageName pkg /= cabalPkgname ]         where           -- The Cabal dep is slightly special:@@ -3050,7 +3066,7 @@           -- Note: we also add a global constraint to require Cabal >= 1.20           -- for Setup scripts (see use addSetupCabalMinVersionConstraint).           ---          cabalConstraint   = orLaterVersion (PD.specVersion pkg)+          cabalConstraint   = orLaterVersion (csvToVersion (PD.specVersion pkg))                                 `intersectVersionRanges`                               earlierVersion cabalCompatMaxVer           -- The idea here is that at some point we will make significant@@ -3063,10 +3079,10 @@       -- external Setup.hs, it'll be one of the simple ones that only depends       -- on Cabal and base.       SetupNonCustomExternalLib ->-        Just [ Dependency cabalPkgname cabalConstraint (Set.singleton LMainLibName)-             , Dependency basePkgname  anyVersion (Set.singleton LMainLibName)]+        Just [ Dependency cabalPkgname cabalConstraint mainLibSet+             , Dependency basePkgname  anyVersion mainLibSet]         where-          cabalConstraint = orLaterVersion (PD.specVersion pkg)+          cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))        -- The internal setup wrapper method has no deps at all.       SetupNonCustomInternalLib -> Just []@@ -3075,10 +3091,15 @@       -- above in the SetupCustomImplicitDeps case.       SetupCustomExplicitDeps ->         error $ "defaultSetupDeps: called for a package with explicit "-             ++ "setup deps: " ++ display (packageId pkg)-+             ++ "setup deps: " ++ prettyShow (packageId pkg)+  where+    -- we require one less+    --+    -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5]+    csvToVersion :: CabalSpecVersion -> Version+    csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion --- | Work out which version of the Cabal spec we will be using to talk to the+-- | Work out which version of the Cabal we will be using to talk to the -- Setup.hs interface for this package. -- -- This depends somewhat on the 'SetupScriptStyle' but most cases are a result@@ -3109,7 +3130,7 @@ packageSetupScriptSpecVersion _ pkg libDepGraph deps =     case find ((cabalPkgname ==) . packageName) setupLibDeps of       Just dep -> packageVersion dep-      Nothing  -> PD.specVersion pkg+      Nothing  -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg))   where     setupLibDeps = map packageId $ fromMaybe [] $                    Graph.closure libDepGraph (CD.setupDeps deps)@@ -3124,14 +3145,18 @@ legacyCustomSetupPkgs compiler (Platform _ os) =     map mkPackageName $         [ "array", "base", "binary", "bytestring", "containers"-        , "deepseq", "directory", "filepath", "old-time", "pretty"+        , "deepseq", "directory", "filepath", "pretty"         , "process", "time", "transformers" ]      ++ [ "Win32" | os == Windows ]      ++ [ "unix"  | os /= Windows ]      ++ [ "ghc-prim"         | isGHC ]      ++ [ "template-haskell" | isGHC ]+     ++ [ "old-time" | notGHC710 ]   where     isGHC = compilerCompatFlavor GHC compiler+    notGHC710 = case compilerCompatVersion GHC compiler of+        Nothing -> False+        Just v  -> v <= mkVersion [7,9]  -- The other aspects of our Setup.hs policy lives here where we decide on -- the 'SetupScriptOptions'.@@ -3291,7 +3316,7 @@      configDeterministic       = mempty -- doesn't matter, configIPID/configCID overridese     configIPID                = case elabPkgOrComp of-                                  ElabPackage pkg -> toFlag (display (pkgInstalledId pkg))+                                  ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg))                                   ElabComponent _ -> mempty     configCID                 = case elabPkgOrComp of                                   ElabPackage _ -> mempty@@ -3377,7 +3402,7 @@     configConstraints         =         case elabPkgOrComp of             ElabPackage _ ->-                [ thisPackageVersion srcid+                [ thisPackageVersionConstraint srcid                 | ConfiguredId srcid _ _uid <- elabLibDependencies elab ]             ElabComponent _ -> [] @@ -3400,9 +3425,7 @@     configUserInstall         = mempty -- don't rely on defaults     configPrograms_           = mempty -- never use, shouldn't exist     configUseResponseFiles    = mempty-    -- TODO set to true when the solver can prevent private-library-deps by itself-    -- (issue #6039)-    configAllowDependingOnPrivateLibs = mempty+    configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler  setupHsConfigureArgs :: ElaboratedConfiguredPackage                      -> [String]@@ -3671,7 +3694,7 @@  packageHashInputs _ pkg =     error $ "packageHashInputs: only for packages with source hashes. "-         ++ display (packageId pkg)+         ++ prettyShow (packageId pkg)  packageHashConfigInputs :: ElaboratedSharedConfig                         -> ElaboratedConfiguredPackage
Distribution/Client/ProjectPlanning/Types.hs view
@@ -78,8 +78,7 @@ import           Distribution.Backpack import           Distribution.Backpack.ModuleShape -import           Distribution.Pretty-import           Distribution.Verbosity+import           Distribution.Verbosity (normal) import           Distribution.Types.ComponentRequestedSpec import           Distribution.Types.PkgconfigVersion import           Distribution.Types.PackageDescription (PackageDescription(..))@@ -108,7 +107,6 @@ import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LBS import qualified Data.Monoid as Mon-import           Control.Monad (guard) import           System.FilePath ((</>))  @@ -307,6 +305,9 @@        -- | The version of the Cabal command line interface that we are using        -- for this package. This is typically the version of the Cabal lib        -- that the Setup.hs is built against.+       --+       -- TODO: We might want to turn this into a enum,+       -- yet different enum than 'CabalSpecVersion'.        elabSetupScriptCliVersion :: Version,         -- Build time related:
Distribution/Client/RebuildMonad.hs view
@@ -63,7 +63,6 @@ import qualified Distribution.Client.Glob as Glob (matchFileGlob)  import Distribution.Simple.Utils (debug)-import Distribution.Verbosity    (Verbosity)  import qualified Data.Map.Strict as Map import Control.Monad.State as State
Distribution/Client/Reconfigure.hs view
@@ -5,8 +5,6 @@ import Data.Monoid ( Any(..) ) import System.Directory ( doesFileExist ) -import Distribution.Verbosity- import Distribution.Simple.Configure ( localBuildInfoFile ) import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) import Distribution.Simple.Utils@@ -15,16 +13,11 @@ import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Configure ( readConfigFlags ) import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate )-import Distribution.Client.Sandbox-       ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath-       , maybeReinstallAddSourceDeps, updateInstallDirs )+import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) import Distribution.Client.Sandbox.PackageEnvironment        ( userPackageEnvironmentFile )-import Distribution.Client.Sandbox.Types ( UseSandbox(..) ) import Distribution.Client.Setup-       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..)-       , SkipAddSourceDepsCheck(..) )-+       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) )  -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed.@@ -82,10 +75,6 @@      -- ^ Verbosity setting   -> FilePath      -- ^ \"dist\" prefix-  -> UseSandbox-  -> SkipAddSourceDepsCheck-     -- ^ Should we skip the timestamp check for modified-     -- add-source dependencies?   -> Flag (Maybe Int)      -- ^ -j flag for reinstalling add-source deps.   -> Check (ConfigFlags, ConfigExFlags)@@ -100,9 +89,7 @@   configureAction   verbosity   dist-  useSandbox-  skipAddSourceDepsCheck-  numJobsFlag+  _numJobsFlag   check   extraArgs   globalFlags@@ -137,15 +124,11 @@             <> checkDist             <> checkOutdated             <> check-            <> checkAddSourceDeps-      (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags+      (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags -      let (_, config') =-            updateInstallDirs-            (configUserInstall configFlags)-            (useSandbox, config)+      let config' = updateInstallDirs (configUserInstall configFlags) config -      when force $ configureAction flags extraArgs globalFlags+      when frc $ configureAction flags extraArgs globalFlags       return config'    where@@ -174,13 +157,6 @@       configured <- doesFileExist buildConfig       unless configured $ info verbosity "package has never been configured" -      -- Is the configuration older than the sandbox configuration file?-      -- If so, reconfiguration is required.-      sandboxConfig <- getSandboxConfigFilePath globalFlags-      sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig-      when sandboxConfigNewer $-        info verbosity "sandbox was created after the package was configured"-       -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need       -- to force reconfigure. Note that it's possible to use @cabal.config@       -- even without sandboxes.@@ -199,35 +175,5 @@       let failed =             Any outdated             <> Any userPackageEnvironmentFileModified-            <> Any sandboxConfigNewer             <> Any (not configured)       return (failed, flags)--    checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do-      let (_, config') =-            updateInstallDirs-            (configUserInstall configFlags)-            (useSandbox, config)--          skipAddSourceDepsCheck'-            | force'    = SkipAddSourceDepsCheck-            | otherwise = skipAddSourceDepsCheck--      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $-        info verbosity "skipping add-source deps check"--      -- Were any add-source dependencies reinstalled in the sandbox?-      depsReinstalled <--        case skipAddSourceDepsCheck' of-          DontSkipAddSourceDepsCheck ->-            maybeReinstallAddSourceDeps-            verbosity numJobsFlag configFlags globalFlags-            (useSandbox, config')-          SkipAddSourceDepsCheck -> do-            return NoDepsReinstalled--      case depsReinstalled of-        NoDepsReinstalled -> return (mempty, flags)-        ReinstalledSomeDeps -> do-          info verbosity "some add-source dependencies were reinstalled"-          return (Any True, flags)
Distribution/Client/Run.hs view
@@ -34,8 +34,6 @@                                               rawSystemExitWithEnv,                                               addLibraryPath) import Distribution.System                   (Platform (..))-import Distribution.Verbosity                (Verbosity)-import Distribution.Deprecated.Text                     (display)  import qualified Distribution.Simple.GHCJS as GHCJS @@ -91,16 +89,16 @@       where         components :: [(UnqualComponentName, String)] -- Component name, message.         components =-          [ (name, "The executable '" ++ display name ++ "' is disabled.")+          [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.")           | e <- executables pkg_descr           , not . buildable . buildInfo $ e, let name = exeName e] -          ++ [ (name, "There is a test-suite '" ++ display name ++ "',"+          ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "',"                       ++ " but the `run` command is only for executables.")              | t <- testSuites pkg_descr              , let name = testName t] -          ++ [ (name, "There is a benchmark '" ++ display name ++ "',"+          ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "',"                       ++ " but the `run` command is only for executables.")              | b <- benchmarks pkg_descr              , let name = benchmarkName b]@@ -115,7 +113,7 @@                        curDir </> dataDir pkg_descr)    (path, runArgs) <--    let exeName' = display $ exeName exe+    let exeName' = prettyShow $ exeName exe     in case compilerFlavor (compiler lbi) of       GHCJS -> do         let (script, cmd, cmdArgs) =@@ -139,5 +137,5 @@                      paths <- depLibraryPaths True False lbi clbi                      return (addLibraryPath os paths env)              else return env-  notice verbosity $ "Running " ++ display (exeName exe) ++ "..."+  notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."   rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
Distribution/Client/Sandbox.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox@@ -10,33 +11,9 @@ -----------------------------------------------------------------------------  module Distribution.Client.Sandbox (-    sandboxInit,-    sandboxDelete,-    sandboxAddSource,-    sandboxAddSourceSnapshot,-    sandboxDeleteSource,-    sandboxListSources,-    sandboxHcPkg,-    dumpPackageEnvironment,-    withSandboxBinDirOnSearchPath,--    getSandboxConfigFilePath,     loadConfigOrSandboxConfig,     findSavedDistPref,-    initPackageDBIfNeeded,-    maybeWithSandboxDirOnSearchPath, -    WereDepsReinstalled(..),-    reinstallAddSourceDeps,-    maybeReinstallAddSourceDeps,--    SandboxPackageInfo(..),-    maybeWithSandboxPackageInfo,--    tryGetIndexFilePath,-    sandboxBuildDir,-    getInstalledPackagesInSandbox,-    updateSandboxConfigFileFlag,     updateInstallDirs,      getPersistOrConfigCompiler@@ -44,529 +21,41 @@  import Prelude () import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic(safeLast)  import Distribution.Client.Setup-  ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)-  , GlobalFlags(..), configCompilerAux', configPackageDB'-  , defaultConfigExFlags, defaultInstallFlags-  , defaultSandboxLocation, withRepoContext )-import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps-                                              , maybeAddCompilerTimestampRecord-                                              , withAddTimestamps-                                              , removeTimestamps )+  ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) import Distribution.Client.Config   ( SavedConfig(..), defaultUserInstall, loadConfig )-import Distribution.Client.Dependency         ( foldProgress )-import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) )-import Distribution.Client.Install            ( InstallArgs,-                                                makeInstallContext,-                                                makeInstallPlan,-                                                processInstallPlan )-import Distribution.Utils.NubList            ( fromNubList )  import Distribution.Client.Sandbox.PackageEnvironment-  ( PackageEnvironment(..), PackageEnvironmentType(..)-  , createPackageEnvironmentFile, classifyPackageEnvironment-  , tryLoadSandboxPackageEnvironmentFile, loadUserConfig-  , commentPackageEnvironment, showPackageEnvironmentWithComments-  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile-  , sandboxPackageDBPath )-import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)-                                              , UseSandbox(..) )+  (  PackageEnvironmentType(..)+  , classifyPackageEnvironment+  , loadUserConfig+  ) import Distribution.Client.SetupWrapper   ( SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Types              ( PackageLocation(..) )-import Distribution.Client.Utils              ( inDir, tryCanonicalizePath-                                              , tryFindAddSourcePackageDesc)-import Distribution.PackageDescription.Configuration-                                              ( flattenPackageDescription )-import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )-import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..) )-import Distribution.Simple.Configure          ( configCompilerAuxEx-                                              , getPackageDBContents-                                              , maybeGetPersistBuildConfig+import Distribution.Simple.Compiler           ( Compiler(..) )+import Distribution.Simple.Configure          ( maybeGetPersistBuildConfig                                               , findDistPrefOrDefault                                               , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo-import Distribution.Simple.PreProcess         ( knownSuffixHandlers ) import Distribution.Simple.Program            ( ProgramDb )-import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)-                                              , emptyTestFlags, emptyBenchmarkFlags+import Distribution.Simple.Setup              ( Flag(..)                                               , fromFlagOrDefault, flagToMaybe )-import Distribution.Simple.SrcDist            ( prepareTree )-import Distribution.Simple.Utils              ( die', debug, notice, info, warn-                                              , debugNoWrap, defaultPackageDesc-                                              , topHandlerWith-                                              , createDirectoryIfMissingVerbose )-import Distribution.Package                   ( Package(..) ) import Distribution.System                    ( Platform )-import Distribution.Deprecated.Text                      ( display )-import Distribution.Verbosity                 ( Verbosity )-import Distribution.Compat.Environment        ( lookupEnv, setEnv )-import Distribution.Client.Compat.FilePerms   ( setFileHidden )-import qualified Distribution.Client.Sandbox.Index as Index-import Distribution.Simple.PackageIndex       ( InstalledPackageIndex )-import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex-import qualified Distribution.Simple.Register      as Register -import Distribution.Solver.Types.SourcePackage+import System.Directory                       ( getCurrentDirectory ) -import qualified Data.Map                          as M-import qualified Data.Set                          as S-import Data.Either                            (partitionEithers)-import Control.Exception                      ( assert, bracket_ )-import Control.Monad                          ( forM, mapM, mapM_ )-import Data.Bits                              ( shiftL, shiftR, xor )-import Data.IORef                             ( newIORef, writeIORef, readIORef )-import Data.List                              ( delete-                                              , groupBy )-import Data.Maybe                             ( fromJust )-import Numeric                                ( showHex )-import System.Directory                       ( canonicalizePath-                                              , createDirectory-                                              , doesDirectoryExist-                                              , doesFileExist-                                              , getCurrentDirectory-                                              , removeDirectoryRecursive-                                              , removeFile-                                              , renameDirectory )-import System.FilePath                        ( (</>), equalFilePath-                                              , getSearchPath-                                              , searchPathSeparator-                                              , splitSearchPath-                                              , takeDirectory ) ------ * Constants------- | The name of the sandbox subdirectory where we keep snapshots of add-source--- dependencies.-snapshotDirectoryName :: FilePath-snapshotDirectoryName = "snapshots"---- | Non-standard build dir that is used for building add-source deps instead of--- "dist". Fixes surprising behaviour in some cases (see issue #1281).-sandboxBuildDir :: FilePath -> FilePath-sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""-  where-    sandboxDirHash = jenkins sandboxDir--    -- See http://en.wikipedia.org/wiki/Jenkins_hash_function-    jenkins :: String -> Word32-    jenkins str = loop_finish $ foldl' loop 0 str-      where-        loop :: Word32 -> Char -> Word32-        loop hash key_i' = hash'''-          where-            key_i   = toEnum . ord $ key_i'-            hash'   = hash + key_i-            hash''  = hash' + (shiftL hash' 10)-            hash''' = hash'' `xor` (shiftR hash'' 6)--        loop_finish :: Word32 -> Word32-        loop_finish hash = hash'''-          where-            hash'   = hash + (shiftL hash 3)-            hash''  = hash' `xor` (shiftR hash' 11)-            hash''' = hash'' + (shiftL hash'' 15)---- -- * Basic sandbox functions. -- --- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the--- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to--- 'NoFlag'.-updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags-updateSandboxConfigFileFlag globalFlags =-  case globalSandboxConfigFile globalFlags of-    Flag _ -> return globalFlags-    NoFlag -> do-      f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG"-      return globalFlags { globalSandboxConfigFile = f' }---- | Return the path to the sandbox config file - either the default or the one--- specified with @--sandbox-config-file@.-getSandboxConfigFilePath :: GlobalFlags -> IO FilePath-getSandboxConfigFilePath globalFlags = do-  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags-  case sandboxConfigFileFlag of-    NoFlag -> do pkgEnvDir <- getCurrentDirectory-                 return (pkgEnvDir </> sandboxPackageEnvironmentFile)-    Flag path -> return path---- | Load the @cabal.sandbox.config@ file (and possibly the optional--- @cabal.config@). In addition to a @PackageEnvironment@, also return a--- canonical path to the sandbox. Exit with error if the sandbox directory or--- the package environment file do not exist.-tryLoadSandboxConfig :: Verbosity -> GlobalFlags-                        -> IO (FilePath, PackageEnvironment)-tryLoadSandboxConfig verbosity globalFlags = do-  path <- getSandboxConfigFilePath globalFlags-  tryLoadSandboxPackageEnvironmentFile verbosity path-    (globalConfigFile globalFlags)---- | Return the name of the package index file for this package environment.-tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath-tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config)---- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of--- 'SavedConfig'.-tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath-tryGetIndexFilePath' verbosity globalFlags = do-  let paths = fromNubList $ globalLocalRepos globalFlags-  case safeLast paths of-    Nothing   -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++-           "no local repos found. " ++ checkConfiguration-    Just lp   -> return $ lp </> Index.defaultIndexFileName-  where-    checkConfiguration = "Please check your configuration ('"-                         ++ userPackageEnvironmentFile ++ "')."---- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error--- message than just pattern-matching.-getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB-getSandboxPackageDB verbosity configFlags = do-  case configPackageDBs configFlags of-    [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB-    -- TODO: should we allow multiple package DBs (e.g. with 'inherit')?--    []                                     ->-      die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt-    [_]                                    ->-      die' verbosity $ "Unexpected contents of the 'package-db' field. "-            ++ sandboxConfigCorrupt-    _                                      ->-      die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt--  where-    sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."----- | Which packages are installed in the sandbox package DB?-getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags-                                 -> Compiler -> ProgramDb-                                 -> IO InstalledPackageIndex-getInstalledPackagesInSandbox verbosity configFlags comp progdb = do-    sandboxDB <- getSandboxPackageDB verbosity configFlags-    getPackageDBContents verbosity comp sandboxDB progdb---- | Temporarily add $SANDBOX_DIR/bin to $PATH.-withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a-withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir-  where-    -- TODO: Instead of modifying the global process state, it'd be better to-    -- set the environment individually for each subprocess invocation. This-    -- will have to wait until the Shell monad is implemented; without it the-    -- required changes are too intrusive.-    addBinDir :: IO ()-    addBinDir = do-      mbOldPath <- lookupEnv "PATH"-      let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)-                    mbOldPath-      setEnv "PATH" newPath--    rmBinDir :: IO ()-    rmBinDir = do-      oldPath <- getSearchPath-      let newPath = intercalate [searchPathSeparator]-                    (delete sandboxBin oldPath)-      setEnv "PATH" newPath--    sandboxBin = sandboxDir </> "bin"---- | Initialise a package DB for this compiler if it doesn't exist.-initPackageDBIfNeeded :: Verbosity -> ConfigFlags-                         -> Compiler -> ProgramDb-                         -> IO ()-initPackageDBIfNeeded verbosity configFlags comp progdb = do-  SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags-  packageDBExists <- doesDirectoryExist dbPath-  unless packageDBExists $-    Register.initPackageDB verbosity comp progdb dbPath-  when packageDBExists $-    debug verbosity $ "The package database already exists: " ++ dbPath---- | Entry point for the 'cabal sandbox dump-pkgenv' command.-dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()-dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  commentPkgEnv        <- commentPackageEnvironment sandboxDir-  putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv---- | Entry point for the 'cabal sandbox init' command.-sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()-sandboxInit verbosity sandboxFlags globalFlags = do-  -- Warn if there's a 'cabal-dev' sandbox.-  isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")-                       (doesFileExist $ "cabal-dev" </> "cabal.config")-  when isCabalDevSandbox $-    warn verbosity $-    "You are apparently using a legacy (cabal-dev) sandbox. "-    ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "-    ++ "You may want to delete the 'cabal-dev' directory to prevent issues."--  -- Create the sandbox directory.-  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation-                    (sandboxLocation sandboxFlags)-  createDirectoryIfMissingVerbose verbosity True sandboxDir'-  sandboxDir <- tryCanonicalizePath sandboxDir'-  setFileHidden sandboxDir--  -- Determine which compiler to use (using the value from ~/.cabal/config).-  userConfig <- loadConfig verbosity (globalConfigFile globalFlags)-  (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig)--  -- Create the package environment file.-  pkgEnvFile <- getSandboxConfigFilePath globalFlags-  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform-  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  let config      = pkgEnvSavedConfig pkgEnv-      configFlags = savedConfigureFlags config--  -- Create the index file if it doesn't exist.-  indexFile <- tryGetIndexFilePath verbosity config-  indexFileExists <- doesFileExist indexFile-  if indexFileExists-    then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir-    else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir-  Index.createEmpty verbosity indexFile--  -- Create the package DB for the default compiler.-  initPackageDBIfNeeded verbosity configFlags comp progdb-  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-    (compilerId comp) platform---- | Entry point for the 'cabal sandbox delete' command.-sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()-sandboxDelete verbosity _sandboxFlags globalFlags = do-  (useSandbox, _) <- loadConfigOrSandboxConfig-                       verbosity-                       globalFlags { globalRequireSandbox = Flag False }-  case useSandbox of-    NoSandbox -> warn verbosity "Not in a sandbox."-    UseSandbox sandboxDir -> do-      curDir     <- getCurrentDirectory-      pkgEnvFile <- getSandboxConfigFilePath globalFlags--      -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard-      -- location.-      let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $-                                       curDir </> sandboxPackageEnvironmentFile--      if isNonDefaultConfigLocation-        then warn verbosity $ "Sandbox config file is in non-default location: '"-                    ++ pkgEnvFile ++ "'.\n Please delete manually."-        else removeFile pkgEnvFile--      -- Remove the sandbox directory, unless we're using a shared sandbox.-      let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $-                                        curDir </> defaultSandboxLocation--      when isNonDefaultSandboxLocation $-        die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir-        ++ "'.\nAssuming a shared sandbox. Please delete '"-        ++ sandboxDir ++ "' manually."--      absSandboxDir <- canonicalizePath sandboxDir-      notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir-      removeDirectoryRecursive absSandboxDir--      let-        pathInsideSandbox = isPrefixOf absSandboxDir--        -- Warn the user if deleting the sandbox deleted a package database-        -- referenced in the current environment.-        checkPackagePaths var = do-          let-            checkPath path = do-              absPath <- canonicalizePath path-              (when (pathInsideSandbox absPath) . warn verbosity)-                (var ++ " refers to package database " ++ path-                 ++ " inside the deleted sandbox.")-          liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath--      checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH"-      checkPackagePaths "GHC_PACKAGE_PATH"-      checkPackagePaths "GHCJS_PACKAGE_PATH"---- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.-doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment-               -> BuildTreeRefType-               -> IO ()-doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do-  let savedConfig       = pkgEnvSavedConfig pkgEnv-  indexFile            <- tryGetIndexFilePath verbosity savedConfig--  -- If we're running 'sandbox add-source' for the first time for this compiler,-  -- we need to create an initial timestamp record.-  (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig-  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-    (compilerId comp) platform--  withAddTimestamps verbosity sandboxDir $ do-    -- Path canonicalisation is done in addBuildTreeRefs, but we do it-    -- twice because of the timestamps file.-    buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs-    Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType-    return buildTreeRefs'---- | Entry point for the 'cabal sandbox add-source' command.-sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags-                    -> IO ()-sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags--  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)-    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv-    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef---- | Entry point for the 'cabal sandbox add-source --snapshot' command.-sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath-                            -> PackageEnvironment-                            -> IO ()-sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do-  let snapshotDir = sandboxDir </> snapshotDirectoryName--  -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private-  -- location.-  createDirectoryIfMissingVerbose verbosity True snapshotDir--  -- Collect the package descriptions first, so that if some path does not refer-  -- to a cabal package, we fail immediately.-  pkgs      <- forM buildTreeRefs $ \buildTreeRef ->-    inDir (Just buildTreeRef) $-    return . flattenPackageDescription-            =<< readGenericPackageDescription verbosity-            =<< defaultPackageDesc     verbosity--  -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If-  -- 'prepareTree' throws an error at any point, the old snapshots will still be-  -- in consistent state.-  tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->-    inDir (Just buildTreeRef) $ do-      let targetDir    = snapshotDir </> (display . packageId $ pkg)-          targetTmpDir = targetDir ++ "-tmp"-      dirExists <- doesDirectoryExist targetTmpDir-      when dirExists $-        removeDirectoryRecursive targetDir-      createDirectory targetTmpDir-      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers-      return (targetTmpDir, targetDir)--  -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to-  -- "snapshots/$PKGNAME-$VERSION".-  snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do-    dirExists <- doesDirectoryExist targetDir-    when dirExists $-      removeDirectoryRecursive targetDir-    renameDirectory targetTmpDir targetDir-    return targetDir--  -- Once the packages are copied, just 'add-source' them as usual.-  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef---- | Entry point for the 'cabal sandbox delete-source' command.-sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags-                       -> IO ()-sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)--  (results, convDict) <--    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs--  let (failedPaths, removedPaths) = partitionEithers results-      removedRefs = fmap convDict removedPaths--  unless (null removedPaths) $ do-    removeTimestamps verbosity sandboxDir removedPaths--    notice verbosity $ "Success deleting sources: " ++-      showL removedRefs ++ "\n\n"--  unless (null failedPaths) $ do-    let groupedFailures = groupBy errorType failedPaths-    mapM_ handleErrors groupedFailures-    die' verbosity $ "The sources with the above errors were skipped. (" ++-      showL (fmap getPath failedPaths) ++ ")"--  notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++-    "source dependency, but does not remove the package " ++-    "from the sandbox package DB.\n\n" ++-    "Use 'sandbox hc-pkg -- unregister' to do that."-  where-    getPath (Index.ErrNonregisteredSource p) = p-    getPath (Index.ErrNonexistentSource p) = p--    showPaths f = concat . intersperse " " . fmap (show . f)--    showL = showPaths id--    showE [] = return ' '-    showE errs = showPaths getPath errs--    errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =-      True-    errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True-    errorType _ _ = False--    handleErrors [] = return ()-    handleErrors errs@(Index.ErrNonregisteredSource{}:_) =-      warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")-    handleErrors errs@(Index.ErrNonexistentSource{}:_)   =-      warn verbosity-      ("Source directory not found for paths: " ++ showE errs ++ "\n"-       ++ "If you are trying to delete a reference to a removed directory, "-       ++ "please provide the full absolute path "-       ++ "(as given by `sandbox list-sources`).\n\n")---- | Entry point for the 'cabal sandbox list-sources' command.-sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags-                      -> IO ()-sandboxListSources verbosity _sandboxFlags globalFlags = do-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)--  refs <- Index.listBuildTreeRefs verbosity-          Index.ListIgnored Index.LinksAndSnapshots indexFile-  when (null refs) $-    notice verbosity $ "Index file '" ++ indexFile-    ++ "' has no references to local build trees."-  when (not . null $ refs) $ do-    notice verbosity $ "Source dependencies registered "-      ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n"-    mapM_ putStrLn refs-    notice verbosity $ "\nTo unregister source dependencies, "-                       ++ "use the 'sandbox delete-source' command."---- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@--- tool with provided arguments, restricted to the sandbox.-sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()-sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv-  -- Invoke hc-pkg for the most recently configured compiler (if any),-  -- using the right package-db for the compiler (see #1935).-  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags-  let dir         = sandboxPackageDBPath sandboxDir comp platform-      dbStack     = [GlobalPackageDB, SpecificPackageDB dir]-  Register.invokeHcPkg verbosity comp progdb dbStack extraArgs--updateInstallDirs :: Flag Bool-                  -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)-updateInstallDirs userInstallFlag (useSandbox, savedConfig) =-  case useSandbox of-    NoSandbox ->-      let savedConfig' = savedConfig {-            savedConfigureFlags = configureFlags {-                configInstallDirs = installDirs-            }-          }-      in (useSandbox, savedConfig')-    _ -> (useSandbox, savedConfig)+updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig+updateInstallDirs userInstallFlag savedConfig = savedConfig+    { savedConfigureFlags = configureFlags+        { configInstallDirs = installDirs+        }+    }   where     configureFlags = savedConfigureFlags savedConfig     userInstallDirs = savedUserInstallDirs savedConfig@@ -582,30 +71,19 @@ loadConfigOrSandboxConfig :: Verbosity                           -> GlobalFlags  -- ^ For @--config-file@ and                                           -- @--sandbox-config-file@.-                          -> IO (UseSandbox, SavedConfig)+                          -> IO SavedConfig loadConfigOrSandboxConfig verbosity globalFlags = do   let configFileFlag        = globalConfigFile        globalFlags-      sandboxConfigFileFlag = globalSandboxConfigFile globalFlags-      ignoreSandboxFlag     = globalIgnoreSandbox     globalFlags -  pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag-  pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag-                                           ignoreSandboxFlag+  pkgEnvDir  <- getCurrentDirectory+  pkgEnvType <- classifyPackageEnvironment pkgEnvDir   case pkgEnvType of-    -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.-    SandboxPackageEnvironment -> do-      (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-                              -- Prints an error message and exits on error.-      let config = pkgEnvSavedConfig pkgEnv-      return (UseSandbox sandboxDir, config)-     -- Only @cabal.config@ is present.     UserPackageEnvironment    -> do       config <- loadConfig verbosity configFileFlag       userConfig <- loadUserConfig verbosity pkgEnvDir Nothing       let config' = config `mappend` userConfig-      dieIfSandboxRequired config'-      return (NoSandbox, config')+      return config'      -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.     AmbientPackageEnvironment -> do@@ -615,30 +93,7 @@       globalConstraintConfig <-         loadUserConfig verbosity pkgEnvDir globalConstraintsOpt       let config' = config `mappend` globalConstraintConfig-      dieIfSandboxRequired config-      return (NoSandbox, config')--  where-    -- Return the path to the package environment directory - either the-    -- current directory or the one that @--sandbox-config-file@ resides in.-    getPkgEnvDir :: (Flag FilePath) -> IO FilePath-    getPkgEnvDir sandboxConfigFileFlag = do-      case sandboxConfigFileFlag of-        NoFlag    -> getCurrentDirectory-        Flag path -> tryCanonicalizePath . takeDirectory $ path--    -- Die if @--require-sandbox@ was specified and we're not inside a sandbox.-    dieIfSandboxRequired :: SavedConfig -> IO ()-    dieIfSandboxRequired config = checkFlag flag-      where-        flag = (globalRequireSandbox . savedGlobalFlags $ config)-               `mappend` (globalRequireSandbox globalFlags)-        checkFlag (Flag True)  =-          die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. "-             ++ "Use '--no-require-sandbox' if you want to override "-             ++ "'require-sandbox' temporarily."-        checkFlag (Flag False) = return ()-        checkFlag (NoFlag)     = return ()+      return config'  -- | Return the saved \"dist/\" prefix, or the default prefix. findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath@@ -648,208 +103,6 @@                         `mappend` flagDistPref     findDistPref defDistPref flagDistPref' --- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do--- nothing.-maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a-maybeWithSandboxDirOnSearchPath NoSandbox               act = act-maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =-  withSandboxBinDirOnSearchPath sandboxDir $ act---- | Had reinstallAddSourceDeps actually reinstalled any dependencies?-data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled---- | Reinstall those add-source dependencies that have been modified since--- we've last installed them. Assumes that we're working inside a sandbox.-reinstallAddSourceDeps :: Verbosity-                          -> ConfigFlags  -> ConfigExFlags-                          -> InstallFlags -> GlobalFlags-                          -> FilePath-                          -> IO WereDepsReinstalled-reinstallAddSourceDeps verbosity configFlags' configExFlags-                       installFlags globalFlags sandboxDir = topHandler' $ do-  let sandboxDistPref     = sandboxBuildDir sandboxDir-      configFlags         = configFlags'-                            { configDistPref  = Flag sandboxDistPref }-      haddockFlags        = mempty-                            { haddockDistPref = Flag sandboxDistPref }-  (comp, platform, progdb) <- configCompilerAux' configFlags-  retVal                   <- newIORef NoDepsReinstalled--  withSandboxPackageInfo verbosity configFlags globalFlags-                         comp platform progdb sandboxDir $ \sandboxPkgInfo ->-    unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do--      withRepoContext verbosity globalFlags $ \repoContext -> do-        let args :: InstallArgs-            args = ((configPackageDB' configFlags)-                  ,repoContext-                  ,comp, platform, progdb-                  ,UseSandbox sandboxDir, Just sandboxPkgInfo-                  ,globalFlags, configFlags, configExFlags, installFlags-                  ,haddockFlags, emptyTestFlags, emptyBenchmarkFlags)--        -- This can actually be replaced by a call to 'install', but we use a-        -- lower-level API because of layer separation reasons. Additionally, we-        -- might want to use some lower-level features this in the future.-        withSandboxBinDirOnSearchPath sandboxDir $ do-          installContext <- makeInstallContext verbosity args Nothing-          installPlan    <- foldProgress logMsg die'' return =<<-                            makeInstallPlan verbosity args installContext--          processInstallPlan verbosity args installContext installPlan-          writeIORef retVal ReinstalledSomeDeps--  readIORef retVal--    where-      die'' message = die' verbosity (message ++ installFailedInSandbox)-      -- TODO: use a better error message, remove duplication.-      installFailedInSandbox =-        "Note: when using a sandbox, all packages are required to have "-        ++ "consistent dependencies. Try reinstalling/unregistering the "-        ++ "offending packages or recreating the sandbox."-      logMsg message rest = debugNoWrap verbosity message >> rest--      topHandler' = topHandlerWith $ \_ -> do-        warn verbosity "Couldn't reinstall some add-source dependencies."-        -- Here we can't know whether any deps have been reinstalled, so we have-        -- to be conservative.-        return ReinstalledSomeDeps---- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that--- we don't update the timestamp file here - this is done in--- 'postInstallActions'.-withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                          -> Compiler -> Platform -> ProgramDb-                          -> FilePath-                          -> (SandboxPackageInfo -> IO ())-                          -> IO ()-withSandboxPackageInfo verbosity configFlags globalFlags-                       comp platform progdb sandboxDir cont = do-  -- List all add-source deps.-  indexFile              <- tryGetIndexFilePath' verbosity globalFlags-  buildTreeRefs          <- Index.listBuildTreeRefs verbosity-                            Index.DontListIgnored Index.OnlyLinks indexFile-  let allAddSourceDepsSet = S.fromList buildTreeRefs--  -- List all packages installed in the sandbox.-  installedPkgIndex <- getInstalledPackagesInSandbox verbosity-                       configFlags comp progdb-  let err = "Error reading sandbox package information."-  -- Get the package descriptions for all add-source deps.-  depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs-  depsPkgDescs   <- mapM (readGenericPackageDescription verbosity) depsCabalFiles-  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)-      isInstalled pkgid = not . null-        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid-      installedDepsMap  = M.filter (isInstalled . packageId) depsMap--  -- Get the package ids of modified (and installed) add-source deps.-  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir-                           (compilerId comp) platform installedDepsMap-  -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to-  -- be a subset of the keys of 'depsMap'.-  let modifiedDeps    = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap)-                        | modDepPath <- modifiedAddSourceDeps ]-      modifiedDepsMap = M.fromList modifiedDeps--  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())-  if (null modifiedDeps)-    then info   verbosity $ "Found no modified add-source deps."-    else notice verbosity $ "Some add-source dependencies have been modified. "-                            ++ "They will be reinstalled..."--  -- Get the package ids of the remaining add-source deps (some are possibly not-  -- installed).-  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)--  -- Finally, assemble a 'SandboxPackageInfo'.-  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)-    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet--  where-    toSourcePackage (path, pkgDesc) = SourcePackage-      (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing---- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the--- identity otherwise.-maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                               -> Compiler -> Platform -> ProgramDb-                               -> UseSandbox-                               -> (Maybe SandboxPackageInfo -> IO ())-                               -> IO ()-maybeWithSandboxPackageInfo verbosity configFlags globalFlags-                            comp platform progdb useSandbox cont =-  case useSandbox of-    NoSandbox             -> cont Nothing-    UseSandbox sandboxDir -> withSandboxPackageInfo verbosity-                             configFlags globalFlags-                             comp platform progdb sandboxDir-                             (\spi -> cont (Just spi))---- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that--- case.-maybeReinstallAddSourceDeps :: Verbosity-                               -> Flag (Maybe Int) -- ^ The '-j' flag-                               -> ConfigFlags      -- ^ Saved configure flags-                                                   -- (from dist/setup-config)-                               -> GlobalFlags-                               -> (UseSandbox, SavedConfig)-                               -> IO WereDepsReinstalled-maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags'-                            globalFlags' (useSandbox, config) = do-  case useSandbox of-    NoSandbox             -> return NoDepsReinstalled-    UseSandbox sandboxDir -> do-      -- Reinstall the modified add-source deps.-      let configFlags    = savedConfigureFlags config-                           `mappendSomeSavedFlags`-                           configFlags'-          configExFlags  = defaultConfigExFlags-                           `mappend` savedConfigureExFlags config-          installFlags'  = defaultInstallFlags-                           `mappend` savedInstallFlags config-          installFlags   = installFlags' {-            installNumJobs    = installNumJobs installFlags'-                                `mappend` numJobsFlag-            }-          globalFlags    = savedGlobalFlags config-          -- This makes it possible to override things like 'remote-repo-cache'-          -- from the command line. These options are hidden, and are only-          -- useful for debugging, so this should be fine.-                           `mappend` globalFlags'-      reinstallAddSourceDeps-        verbosity configFlags configExFlags-        installFlags globalFlags sandboxDir--  where--    -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@-    -- because we don't want to auto-enable things like 'library-profiling' for-    -- all add-source dependencies even if the user has passed-    -- '--enable-library-profiling' to 'cabal configure'. These options are-    -- supposed to be set in 'cabal.config'.-    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags-    mappendSomeSavedFlags sandboxConfigFlags savedFlags =-      sandboxConfigFlags {-        configHcFlavor     = configHcFlavor sandboxConfigFlags-                             `mappend` configHcFlavor savedFlags,-        configHcPath       = configHcPath sandboxConfigFlags-                             `mappend` configHcPath savedFlags,-        configHcPkg        = configHcPkg sandboxConfigFlags-                             `mappend` configHcPkg savedFlags,-        configProgramPaths = configProgramPaths sandboxConfigFlags-                             `mappend` configProgramPaths savedFlags,-        configProgramArgs  = configProgramArgs sandboxConfigFlags-                             `mappend` configProgramArgs savedFlags,-        -- NOTE: Unconditionally choosing the value from-        -- 'dist/setup-config'. Sandbox package DB location may have been-        -- changed by 'configure -w'.-        configPackageDBs   = configPackageDBs savedFlags-        -- FIXME: Is this compatible with the 'inherit' feature?-        }---- -- Utils (transitionary) --
− Distribution/Client/Sandbox/Index.hs 
@@ -1,285 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Sandbox.Index--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Querying and modifying local build tree references in the package index.--------------------------------------------------------------------------------module Distribution.Client.Sandbox.Index (-    createEmpty,-    addBuildTreeRefs,-    removeBuildTreeRefs,-    ListIgnoredBuildTreeRefs(..), RefTypesToList(..),-    DeleteSourceError(..),-    listBuildTreeRefs,-    validateIndexPath,--    defaultIndexFileName-  ) where--import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Archive.Tar.Index as Tar-import qualified Distribution.Client.Tar as Tar-import Distribution.Client.IndexUtils ( BuildTreeRefType(..)-                                      , refTypeFromTypeCode-                                      , typeCodeFromRefType-                                      , updatePackageIndexCacheFile-                                      , readCacheStrict-                                      , Index(..) )-import qualified Distribution.Client.IndexUtils as IndexUtils-import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString-                                 , makeAbsoluteToCwd, tryCanonicalizePath-                                 , tryFindAddSourcePackageDesc  )--import Distribution.Simple.Utils ( die', debug )-import Distribution.Compat.Exception   ( tryIO )-import Distribution.Verbosity    ( Verbosity )--import qualified Data.ByteString.Lazy as BS-import Control.DeepSeq           ( NFData(rnf) )-import Control.Exception         ( evaluate, throw, Exception )-import Control.Monad             ( liftM, unless )-import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)-import Data.List                 ( (\\), intersect, nub, find )-import Data.Maybe                ( catMaybes )-import Data.Either               (partitionEithers)-import System.Directory          ( createDirectoryIfMissing,-                                   doesDirectoryExist, doesFileExist,-                                   renameFile, canonicalizePath)-import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )-import System.IO                 ( IOMode(..), withBinaryFile )---- | A reference to a local build tree.-data BuildTreeRef = BuildTreeRef {-  buildTreeRefType :: !BuildTreeRefType,-  buildTreePath     :: !FilePath-  }--instance NFData BuildTreeRef where-  rnf (BuildTreeRef _ fp) = rnf fp--defaultIndexFileName :: FilePath-defaultIndexFileName = "00-index.tar"---- | Given a path, ensure that it refers to a local build tree.-buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef)-buildTreeRefFromPath verbosity refType dir = do-  dirExists <- doesDirectoryExist dir-  unless dirExists $-    die' verbosity $ "directory '" ++ dir ++ "' does not exist"-  _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference."-  return . Just $ BuildTreeRef refType dir---- | Given a tar archive entry, try to parse it as a local build tree reference.-readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef-readBuildTreeRef entry = case Tar.entryContent entry of-  (Tar.OtherEntryType typeCode bs size)-    | (Tar.isBuildTreeRefTypeCode typeCode)-      && (size == BS.length bs) -> Just $! BuildTreeRef-                                   (refTypeFromTypeCode typeCode)-                                   (byteStringToFilePath bs)-    | otherwise                 -> Nothing-  _ -> Nothing---- | Given a sequence of tar archive entries, extract all references to local--- build trees.-readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef]-readBuildTreeRefs =-  catMaybes-  . Tar.foldEntries (\e r -> readBuildTreeRef e : r)-                    [] throw---- | Given a path to a tar archive, extract all references to local build trees.-readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef]-readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile---- | Read build tree references from an index cache-readBuildTreeRefsFromCache :: Verbosity -> FilePath -> IO [BuildTreeRef]-readBuildTreeRefsFromCache verbosity indexPath = do-    (mRefs, _prefs) <- readCacheStrict verbosity (SandboxIndex indexPath) buildTreeRef-    return (catMaybes mRefs)-  where-    buildTreeRef pkgEntry =-      case pkgEntry of-         IndexUtils.NormalPackage _ _ _ _ -> Nothing-         IndexUtils.BuildTreeRef typ _ _ path _ -> Just $ BuildTreeRef typ path---- | Given a local build tree ref, serialise it to a tar archive entry.-writeBuildTreeRef :: BuildTreeRef -> Tar.Entry-writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content-  where-    bs       = filePathToByteString path-    -- Provide a filename for tools that treat custom entries as ordinary files.-    tarPath' = "local-build-tree-reference"-    -- fromRight can't fail because the path is shorter than 255 characters.-    tarPath  = fromRight $ Tar.toTarPath True tarPath'-    content  = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs)--    -- TODO: Move this to D.C.Utils?-    fromRight (Left err) = error err-    fromRight (Right a)  = a---- | Check that the provided path is either an existing directory, or a tar--- archive in an existing directory.-validateIndexPath :: Verbosity -> FilePath -> IO FilePath-validateIndexPath verbosity path' = do-   path <- makeAbsoluteToCwd path'-   if (== ".tar") . takeExtension $ path-     then return path-     else do dirExists <- doesDirectoryExist path-             unless dirExists $-               die' verbosity $ "directory does not exist: '" ++ path ++ "'"-             return $ path </> defaultIndexFileName---- | Create an empty index file.-createEmpty :: Verbosity -> FilePath -> IO ()-createEmpty verbosity path = do-  indexExists <- doesFileExist path-  if indexExists-    then debug verbosity $ "Package index already exists: " ++ path-    else do-    debug verbosity $ "Creating the index file '" ++ path ++ "'"-    createDirectoryIfMissing True (takeDirectory path)-    -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.-    let zeros = BS.replicate (512*20) 0-    BS.writeFile path zeros---- | Add given local build tree references to the index.-addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType-                    -> IO ()-addBuildTreeRefs _         _   []  _ =-  error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected"-addBuildTreeRefs verbosity path l' refType = do-  checkIndexExists verbosity path-  l <- liftM nub . mapM tryCanonicalizePath $ l'-  treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path)-  -- Add only those paths that aren't already in the index.-  treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex)-  let entries = map writeBuildTreeRef (catMaybes treesToAdd)-  unless (null entries) $ do-    withBinaryFile path ReadWriteMode $ \h -> do-      block <- Tar.hSeekEndEntryOffset h Nothing-      debug verbosity $ "Writing at tar block: " ++ show block-      BS.hPut h (Tar.write entries)-      debug verbosity $ "Successfully appended to '" ++ path ++ "'"-    updatePackageIndexCacheFile verbosity $ SandboxIndex path--data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }-                       | ErrNonexistentSource   { nePath :: FilePath } deriving Show---- | Remove given local build tree references from the index.------ Returns a tuple with either removed build tree refs or errors and a function--- that converts from a provided build tree ref to corresponding full directory path.-removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath]-                       -> IO ([Either DeleteSourceError FilePath],-                              (FilePath -> FilePath))-removeBuildTreeRefs _         _   [] =-  error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"-removeBuildTreeRefs verbosity indexPath l = do-  checkIndexExists verbosity indexPath-  let tmpFile = indexPath <.> "tmp"--  canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr-                               return $ case res of-                                 Right pth -> Right (btr, pth)-                                 Left _ -> Left $ ErrNonexistentSource btr) l-  let (failures, convDict) = partitionEithers canonRes-      allRefs = fmap snd convDict--  -- Performance note: on my system, it takes 'index --remove-source'-  -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be-  -- much smaller.-  removedRefs <- doRemove convDict tmpFile--  renameFile tmpFile indexPath-  debug verbosity $ "Successfully renamed '" ++ tmpFile-    ++ "' to '" ++ indexPath ++ "'"--  unless (null removedRefs) $-    updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath--  let results = fmap Right removedRefs-                ++ fmap Left failures-                ++ fmap (Left . ErrNonregisteredSource)-                        (fmap (convertWith convDict) (allRefs \\ removedRefs))--  return (results, convertWith convDict)--    where-      doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath]-      doRemove srcRefs tmpFile = do-        (newIdx, changedPaths) <--          Tar.read `fmap` BS.readFile indexPath-          >>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs)-        BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx-        return changedPaths--      p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool-      p refs entry = case readBuildTreeRef entry of-        Nothing -> return True-        -- FIXME: removing snapshot deps is done with `delete-source-        -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to-        -- support removing snapshots by providing the original path.-        (Just (BuildTreeRef _ pth)) -> if pth `elem` refs-                                       then tell [pth] >> return False-                                       else return True--      convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict---- | A build tree ref can become ignored if the user later adds a build tree ref--- with the same package ID. We display ignored build tree refs when the user--- runs 'cabal sandbox list-sources', but do not look at their timestamps in--- 'reinstallAddSourceDeps'.-data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored---- | Which types of build tree refs should be listed?-data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots---- | List the local build trees that are referred to from the index.-listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList-                     -> FilePath-                     -> IO [FilePath]-listBuildTreeRefs verbosity listIgnored refTypesToList path = do-  checkIndexExists verbosity path-  buildTreeRefs <--    case listIgnored of-      DontListIgnored -> do-        paths <- listWithoutIgnored-        case refTypesToList of-          LinksAndSnapshots -> return paths-          _                 -> do-            allPathsFiltered <- fmap (map buildTreePath . filter predicate)-                                listWithIgnored-            _ <- evaluate (length allPathsFiltered)-            return (paths `intersect` allPathsFiltered)--      ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored--  _ <- evaluate (length buildTreeRefs)-  return buildTreeRefs--    where-      predicate :: BuildTreeRef -> Bool-      predicate = case refTypesToList of-        OnlySnapshots     -> (==) SnapshotRef . buildTreeRefType-        OnlyLinks         -> (==) LinkRef     . buildTreeRefType-        LinksAndSnapshots -> const True--      listWithIgnored :: IO [BuildTreeRef]-      listWithIgnored = readBuildTreeRefsFromFile path--      listWithoutIgnored :: IO [FilePath]-      listWithoutIgnored = fmap (map buildTreePath)-                         $ readBuildTreeRefsFromCache verbosity path----- | Check that the package index file exists and exit with error if it does not.-checkIndexExists :: Verbosity -> FilePath -> IO ()-checkIndexExists verbosity path = do-  indexExists <- doesFileExist path-  unless indexExists $-    die' verbosity $ "index does not exist: '" ++ path ++ "'"
Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -14,71 +14,47 @@     PackageEnvironment(..)   , PackageEnvironmentType(..)   , classifyPackageEnvironment-  , createPackageEnvironmentFile-  , tryLoadSandboxPackageEnvironmentFile   , readPackageEnvironmentFile   , showPackageEnvironment   , showPackageEnvironmentWithComments-  , setPackageDB-  , sandboxPackageDBPath   , loadUserConfig -  , basePackageEnvironment-  , initialPackageEnvironment-  , commentPackageEnvironment-  , sandboxPackageEnvironmentFile   , userPackageEnvironmentFile   ) where -import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig-                                       , loadConfig, configFieldDescriptions+import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Config      ( SavedConfig(..) +                                       , configFieldDescriptions                                        , haddockFlagsFields                                        , installDirsFields, withProgramsFields                                        , withProgramOptionsFields-                                       , defaultCompiler )+                                       ) import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )-import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)-                                       , InstallFlags(..)-                                       , defaultSandboxLocation )+import Distribution.Client.Setup       ( ConfigExFlags(..)+                                       ) import Distribution.Client.Targets     ( userConstraintPackageName )-import Distribution.Utils.NubList      ( toNubList )-import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)-                                       , compilerFlavor, showCompilerIdWithAbi )-import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate-                                       , defaultInstallDirs, combineInstallDirs-                                       , fromPathTemplate, toPathTemplate )+import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) import Distribution.Simple.Setup       ( Flag(..)                                        , ConfigFlags(..), HaddockFlags(..)-                                       , fromFlagOrDefault, toFlag, flagToMaybe )-import Distribution.Simple.Utils       ( die', info, notice, warn, debug )+                                       )+import Distribution.Simple.Utils       ( warn, debug ) import Distribution.Solver.Types.ConstraintSource import Distribution.Deprecated.ParseUtils         ( FieldDescr(..), ParseResult(..)-                                       , commaListField, commaNewLineListField+                                       , commaListFieldParsec, commaNewLineListFieldParsec                                        , liftField, lineNo, locatedErrorMsg-                                       , parseFilePathQ, readFields-                                       , showPWarning, simpleField+                                       , readFields+                                       , showPWarning                                         , syntaxError, warning )-import Distribution.System             ( Platform )-import Distribution.Verbosity          ( Verbosity, normal )-import Control.Monad                   ( foldM, liftM2, unless )-import Data.List                       ( partition, sortBy )-import Data.Maybe                      ( isJust )-import Data.Ord                        ( comparing )-import Distribution.Compat.Exception   ( catchIO )-import Distribution.Compat.Semigroup-import System.Directory                ( doesDirectoryExist, doesFileExist-                                       , renameFile )-import System.FilePath                 ( (<.>), (</>), takeDirectory )+import System.Directory                ( doesFileExist )+import System.FilePath                 ( (</>) ) import System.IO.Error                 ( isDoesNotExistError ) import Text.PrettyPrint                ( ($+$) )  import qualified Text.PrettyPrint          as Disp-import qualified Distribution.Deprecated.ReadP as Parse import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )-import qualified Distribution.Deprecated.Text         as Text-import GHC.Generics ( Generic ) - -- -- * Configuration saved in the package environment file --@@ -86,9 +62,6 @@ -- TODO: would be nice to remove duplication between -- D.C.Sandbox.PackageEnvironment and D.C.Config. data PackageEnvironment = PackageEnvironment {-  -- The 'inherit' feature is not used ATM, but could be useful in the future-  -- for constructing nested sandboxes (see discussion in #1196).-  pkgEnvInherit       :: Flag FilePath,   pkgEnvSavedConfig   :: SavedConfig } deriving Generic @@ -99,182 +72,29 @@ instance Semigroup PackageEnvironment where   (<>) = gmappend --- | The automatically-created package environment file that should not be--- touched by the user.-sandboxPackageEnvironmentFile :: FilePath-sandboxPackageEnvironmentFile = "cabal.sandbox.config"- -- | Optional package environment file that can be used to customize the default -- settings. Created by the user. userPackageEnvironmentFile :: FilePath userPackageEnvironmentFile = "cabal.config"  -- | Type of the current package environment.-data PackageEnvironmentType =-  SandboxPackageEnvironment   -- ^ './cabal.sandbox.config'-  | UserPackageEnvironment    -- ^ './cabal.config'+data PackageEnvironmentType+  = UserPackageEnvironment    -- ^ './cabal.config'   | AmbientPackageEnvironment -- ^ '~/.cabal/config' --- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this--- directory?-classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool-                              -> IO PackageEnvironmentType-classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag =-  do isSandbox <- liftM2 (||) (return forceSandboxConfig)-                  (configExists sandboxPackageEnvironmentFile)-     isUser    <- configExists userPackageEnvironmentFile-     return (classify isSandbox isUser)+-- | Is there a 'cabal.config' in this directory?+classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType+classifyPackageEnvironment pkgEnvDir = do+     isUser <- configExists userPackageEnvironmentFile+     return (classify isUser)   where     configExists fname   = doesFileExist (pkgEnvDir </> fname)-    ignoreSandbox        = fromFlagOrDefault False ignoreSandboxFlag-    forceSandboxConfig   = isJust . flagToMaybe $ sandboxConfigFileFlag -    classify :: Bool -> Bool -> PackageEnvironmentType-    classify True _-      | not ignoreSandbox = SandboxPackageEnvironment-    classify _    True    = UserPackageEnvironment-    classify _    False   = AmbientPackageEnvironment+    classify :: Bool -> PackageEnvironmentType+    classify True    = UserPackageEnvironment+    classify False   = AmbientPackageEnvironment --- | Defaults common to 'initialPackageEnvironment' and--- 'commentPackageEnvironment'.-commonPackageEnvironmentConfig :: FilePath -> SavedConfig-commonPackageEnvironmentConfig sandboxDir =-  mempty {-    savedConfigureFlags = mempty {-       -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in-       -- the config file. In the future we may want to distinguish between-       -- global, sandbox and user install types.-       configUserInstall = toFlag False,-       configInstallDirs = installDirs-       },-    savedUserInstallDirs   = installDirs,-    savedGlobalInstallDirs = installDirs,-    savedGlobalFlags = mempty {-      globalLogsDir = toFlag $ sandboxDir </> "logs",-      -- Is this right? cabal-dev uses the global world file.-      globalWorldFile = toFlag $ sandboxDir </> "world"-      }-    }-  where-    installDirs = sandboxInstallDirs sandboxDir --- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'.-commonPackageEnvironment :: FilePath -> PackageEnvironment-commonPackageEnvironment sandboxDir = mempty {-  pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir-  }---- | Given a path to a sandbox, return the corresponding InstallDirs record.-sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate)-sandboxInstallDirs sandboxDir = mempty {-  prefix = toFlag (toPathTemplate sandboxDir)-  }---- | These are the absolute basic defaults, the fields that must be--- initialised. When we load the package environment from the file we layer the--- loaded values over these ones.-basePackageEnvironment :: PackageEnvironment-basePackageEnvironment =-    mempty {-      pkgEnvSavedConfig = mempty {-         savedConfigureFlags = mempty {-            configHcFlavor    = toFlag defaultCompiler,-            configVerbosity   = toFlag normal-            }-         }-      }---- | Initial configuration that we write out to the package environment file if--- it does not exist. When the package environment gets loaded this--- configuration gets layered on top of 'basePackageEnvironment'.-initialPackageEnvironment :: FilePath -> Compiler -> Platform-                             -> IO PackageEnvironment-initialPackageEnvironment sandboxDir compiler platform = do-  defInstallDirs <- defaultInstallDirs (compilerFlavor compiler)-                    {- userInstall= -} False {- _hasLibs= -} False-  let initialConfig = commonPackageEnvironmentConfig sandboxDir-      installDirs   = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f)-                      defInstallDirs (savedUserInstallDirs initialConfig)-  return $ mempty {-    pkgEnvSavedConfig = initialConfig {-       savedUserInstallDirs   = installDirs,-       savedGlobalInstallDirs = installDirs,-       savedGlobalFlags = (savedGlobalFlags initialConfig) {-          globalLocalRepos = toNubList [sandboxDir </> "packages"]-          },-       savedConfigureFlags = setPackageDB sandboxDir compiler platform-                             (savedConfigureFlags initialConfig),-       savedInstallFlags = (savedInstallFlags initialConfig) {-         installSummaryFile = toNubList [toPathTemplate (sandboxDir </>-                                               "logs" </> "build.log")]-         }-       }-    }---- | Return the path to the sandbox package database.-sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String-sandboxPackageDBPath sandboxDir compiler platform =-    sandboxDir-         </> (Text.display platform ++ "-"-             ++ showCompilerIdWithAbi compiler-             ++ "-packages.conf.d")--- The path in sandboxPackageDBPath should be kept in sync with the--- path in the bootstrap.sh which is used to bootstrap cabal-install--- into a sandbox.---- | Use the package DB location specific for this compiler.-setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags-setPackageDB sandboxDir compiler platform configFlags =-  configFlags {-    configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath-                                                      sandboxDir-                                                      compiler-                                                      platform)]-    }---- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are--- overridden instead of mappend'ed.-overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment ->-                           PackageEnvironment-overrideSandboxSettings pkgEnv0 pkgEnv =-  pkgEnv {-    pkgEnvSavedConfig = mappendedConf {-         savedConfigureFlags = (savedConfigureFlags mappendedConf) {-          configPackageDBs = configPackageDBs pkgEnvConfigureFlags-          }-       , savedInstallFlags = (savedInstallFlags mappendedConf) {-          installSummaryFile = installSummaryFile pkgEnvInstallFlags-          }-       },-    pkgEnvInherit = pkgEnvInherit pkgEnv0-    }-  where-    pkgEnvConf           = pkgEnvSavedConfig pkgEnv-    mappendedConf        = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf-    pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf-    pkgEnvInstallFlags   = savedInstallFlags pkgEnvConf---- | Default values that get used if no value is given. Used here to include in--- comments when we write out the initial package environment.-commentPackageEnvironment :: FilePath -> IO PackageEnvironment-commentPackageEnvironment sandboxDir = do-  commentConf  <- commentSavedConfig-  let baseConf =  commonPackageEnvironmentConfig sandboxDir-  return $ mempty {-    pkgEnvSavedConfig = commentConf `mappend` baseConf-    }---- | If this package environment inherits from some other package environment,--- return that package environment; otherwise return mempty.-inheritedPackageEnvironment :: Verbosity -> PackageEnvironment-                               -> IO PackageEnvironment-inheritedPackageEnvironment verbosity pkgEnv = do-  case (pkgEnvInherit pkgEnv) of-    NoFlag                -> return mempty-    confPathFlag@(Flag _) -> do-      conf <- loadConfig verbosity confPathFlag-      return $ mempty { pkgEnvSavedConfig = conf }- -- | Load the user package environment if it exists (the optional "cabal.config" -- file). If it does not exist locally, attempt to load an optional global one. userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath@@ -312,121 +132,26 @@     fmap pkgEnvSavedConfig $     userPackageEnvironment verbosity pkgEnvDir globalConfigLocation --- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and--- 'updatePackageEnvironment'.-handleParseResult :: Verbosity -> FilePath-                     -> Maybe (ParseResult PackageEnvironment)-                     -> IO PackageEnvironment-handleParseResult verbosity path minp =-  case minp of-    Nothing -> die' verbosity $-      "The package environment file '" ++ path ++ "' doesn't exist"-    Just (ParseOk warns parseResult) -> do-      unless (null warns) $ warn verbosity $-        unlines (map (showPWarning path) warns)-      return parseResult-    Just (ParseFailed err) -> do-      let (line, msg) = locatedErrorMsg err-      die' verbosity $ "Error parsing package environment file " ++ path-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg --- | Try to load the given package environment file, exiting with error if it--- doesn't exist. Also returns the path to the sandbox directory. The path--- parameter should refer to an existing file.-tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)-                                        -> IO (FilePath, PackageEnvironment)-tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do-  let pkgEnvDir = takeDirectory pkgEnvFile-  minp   <- readPackageEnvironmentFile-            (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile-  pkgEnv <- handleParseResult verbosity pkgEnvFile minp -  -- Get the saved sandbox directory.-  -- TODO: Use substPathTemplate with-  -- compilerTemplateEnv ++ platformTemplateEnv ++ abiTemplateEnv.-  let sandboxDir = fromFlagOrDefault defaultSandboxLocation-                   . fmap fromPathTemplate . prefix . savedUserInstallDirs-                   . pkgEnvSavedConfig $ pkgEnv--  -- Do some sanity checks-  dirExists            <- doesDirectoryExist sandboxDir-  -- TODO: Also check for an initialised package DB?-  unless dirExists $-    die' verbosity ("No sandbox exists at " ++ sandboxDir)-  info verbosity $ "Using a sandbox located at " ++ sandboxDir--  let base   = basePackageEnvironment-  let common = commonPackageEnvironment sandboxDir-  user      <- userPackageEnvironment verbosity pkgEnvDir Nothing --TODO-  inherited <- inheritedPackageEnvironment verbosity user--  -- Layer the package environment settings over settings from ~/.cabal/config.-  cabalConfig <- fmap unsetSymlinkBinDir $ loadConfig verbosity configFileFlag-  return (sandboxDir,-          updateInstallDirs $-          (base `mappend` (toPkgEnv cabalConfig) `mappend`-           common `mappend` inherited `mappend` user)-          `overrideSandboxSettings` pkgEnv)-    where-      toPkgEnv config = mempty { pkgEnvSavedConfig = config }--      updateInstallDirs pkgEnv =-        let config         = pkgEnvSavedConfig    pkgEnv-            configureFlags = savedConfigureFlags  config-            installDirs    = savedUserInstallDirs config-        in pkgEnv {-          pkgEnvSavedConfig = config {-             savedConfigureFlags = configureFlags {-                configInstallDirs = installDirs-                }-             }-          }--      -- We don't want to inherit the value of 'symlink-bindir' from-      -- '~/.cabal/config'. See #1514.-      unsetSymlinkBinDir config =-        let installFlags = savedInstallFlags config-        in config {-          savedInstallFlags = installFlags {-             installSymlinkBinDir = NoFlag-             }-          }---- | Create a new package environment file, replacing the existing one if it--- exists. Note that the path parameters should point to existing directories.-createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath-                                -> Compiler-                                -> Platform-                                -> IO ()-createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do-  notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile-  initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform-  writePackageEnvironmentFile pkgEnvFile initialPkgEnv- -- | Descriptions of all fields in the package environment file. pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]-pkgEnvFieldDescrs src = [-  simpleField "inherit"-    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)-    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })--  , commaNewLineListField "constraints"-    (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)+pkgEnvFieldDescrs src =+  [ commaNewLineListFieldParsec "constraints"+    (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)     (sortConstraints . configExConstraints      . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configExConstraints = v })) -  , commaListField "preferences"-    Text.disp Text.parse+  , commaListFieldParsec "preferences"+    pretty parsec     (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configPreferences = v }))   ]   ++ map toPkgEnv configFieldDescriptions'   where-    optional = Parse.option mempty . fmap toFlag-     configFieldDescriptions' :: [FieldDescr SavedConfig]     configFieldDescriptions' = filter       (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")@@ -538,21 +263,7 @@ type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)                      , [(String, FilePath)], [(String, [String])]) --- | Write out the package environment file.-writePackageEnvironmentFile :: FilePath -> PackageEnvironment -> IO ()-writePackageEnvironmentFile path pkgEnv = do-  let tmpPath = (path <.> "tmp")-  writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"-  renameFile tmpPath path-  where-    pkgEnvStr = showPackageEnvironment pkgEnv-    explanation = unlines-      ["-- This is a Cabal package environment file."-      ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."-      ,"-- Please create a 'cabal.config' file in the same directory"-      ,"-- if you want to change the default settings for this sandbox."-      ,"",""-      ]+  -- | Pretty-print the package environment. showPackageEnvironment :: PackageEnvironment -> String
− Distribution/Client/Sandbox/Timestamp.hs 
@@ -1,273 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Sandbox.Timestamp--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Timestamp file handling (for add-source dependencies).--------------------------------------------------------------------------------module Distribution.Client.Sandbox.Timestamp (-  AddSourceTimestamp,-  withAddTimestamps,-  withUpdateTimestamps,-  maybeAddCompilerTimestampRecord,-  listModifiedDeps,-  removeTimestamps,--  -- * For testing-  TimestampFileRecord,-  readTimestampFile,-  writeTimestampFile-  ) where--import Control.Monad                                 (filterM, forM, when)-import Data.Char                                     (isSpace)-import Data.List                                     (partition)-import System.Directory                              (renameFile)-import System.FilePath                               ((<.>), (</>))-import qualified Data.Map as M--import Distribution.Compiler                         (CompilerId)-import Distribution.Simple.Utils                     (debug, die', warn)-import Distribution.System                           (Platform)-import Distribution.Deprecated.Text                             (display)-import Distribution.Verbosity                        (Verbosity)--import Distribution.Client.SrcDist (allPackageSourceFiles)-import Distribution.Client.Sandbox.Index-  (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)-  ,listBuildTreeRefs)-import Distribution.Client.SetupWrapper--import Distribution.Compat.Exception                 (catchIO)-import Distribution.Compat.Time               (ModTime, getCurTime,-                                                      getModTime,-                                                      posixSecondsToModTime)----- | Timestamp of an add-source dependency.-type AddSourceTimestamp  = (FilePath, ModTime)--- | Timestamp file record - a string identifying the compiler & platform plus a--- list of add-source timestamps.-type TimestampFileRecord = (String, [AddSourceTimestamp])--timestampRecordKey :: CompilerId -> Platform -> String-timestampRecordKey compId platform = display platform ++ "-" ++ display compId---- | The 'add-source-timestamps' file keeps the timestamps of all add-source--- dependencies. It is initially populated by 'sandbox add-source' and kept--- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install--- add-source deps manually with 'cabal install' after having edited them, so we--- can err on the side of caution sometimes.--- FIXME: We should keep this info in the index file, together with build tree--- refs.-timestampFileName :: FilePath-timestampFileName = "add-source-timestamps"---- | Read the timestamp file. Exits with error if the timestamp file is--- corrupted. Returns an empty list if the file doesn't exist.-readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord]-readTimestampFile verbosity timestampFile = do-  timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"-  case reads timestampString of-    [(version, s)]-      | version == (2::Int) ->-        case reads s of-          [(timestamps, s')] | all isSpace s' -> return timestamps-          _                                   -> dieCorrupted-      | otherwise   -> dieWrongFormat--    -- Old format (timestamps are POSIX seconds). Convert to new format.-    [] ->-      case reads timestampString of-        [(timestamps, s)] | all isSpace s -> do-          let timestamps' = map (\(i, ts) ->-                                  (i, map (\(p, t) ->-                                            (p, posixSecondsToModTime t)) ts))-                            timestamps-          writeTimestampFile timestampFile timestamps'-          return timestamps'-        _ -> dieCorrupted-    _ -> dieCorrupted-  where-    dieWrongFormat    = die' verbosity $ wrongFormat ++ deleteAndRecreate-    dieCorrupted      = die' verbosity $ corrupted ++ deleteAndRecreate-    wrongFormat       = "The timestamps file is in the wrong format."-    corrupted         = "The timestamps file is corrupted."-    deleteAndRecreate = " Please delete and recreate the sandbox."---- | Write the timestamp file, atomically.-writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()-writeTimestampFile timestampFile timestamps = do-  writeFile  timestampTmpFile "2\n" -- version-  appendFile timestampTmpFile (show timestamps ++ "\n")-  renameFile timestampTmpFile timestampFile-  where-    timestampTmpFile = timestampFile <.> "tmp"---- | Read, process and write the timestamp file in one go.-withTimestampFile :: Verbosity -> FilePath-                     -> ([TimestampFileRecord] -> IO [TimestampFileRecord])-                     -> IO ()-withTimestampFile verbosity sandboxDir process = do-  let timestampFile = sandboxDir </> timestampFileName-  timestampRecords <- readTimestampFile verbosity timestampFile >>= process-  writeTimestampFile timestampFile timestampRecords---- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps--- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list--- for each path. If a timestamp for a given path already exists in the list,--- update it.-addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]-                 -> [AddSourceTimestamp]-addTimestamps initial timestamps newPaths =-  [ (p, initial) | p <- newPaths ] ++ oldTimestamps-  where-    (oldTimestamps, _toBeUpdated) =-      partition (\(path, _) -> path `notElem` newPaths) timestamps---- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps--- we've reinstalled and a new timestamp value, update the timestamp value for--- the deps in the list. If there are new paths in the list, ignore them.-updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime-                    -> [AddSourceTimestamp]-updateTimestamps timestamps pathsToUpdate newTimestamp =-  foldr updateTimestamp [] timestamps-  where-    updateTimestamp t@(path, _oldTimestamp) rest-      | path `elem` pathsToUpdate = (path, newTimestamp) : rest-      | otherwise                 = t : rest---- | Given a list of 'TimestampFileRecord's and a list of paths to add-source--- deps we've removed, remove those deps from the list.-removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]-removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l-  where-    removeTimestamp t@(path, _oldTimestamp) rest =-      if path `elem` pathsToRemove-      then rest-      else t : rest---- | If a timestamp record for this compiler doesn't exist, add a new one.-maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath-                                   -> CompilerId -> Platform-                                   -> IO ()-maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-                                compId platform = do-  let key = timestampRecordKey compId platform-  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do-    case lookup key timestampRecords of-      Just _  -> return timestampRecords-      Nothing -> do-        buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks-                         indexFile-        now <- getCurTime-        let timestamps = map (\p -> (p, now)) buildTreeRefs-        return $ (key, timestamps):timestampRecords---- | Given an IO action that returns a list of build tree refs, add those--- build tree refs to the timestamps file (for all compilers).-withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO ()-withAddTimestamps verbosity sandboxDir act = do-  let initialTimestamp = minBound-  withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act---- | Given a list of build tree refs, remove those--- build tree refs from the timestamps file (for all compilers).-removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO ()-removeTimestamps verbosity idxFile =-  withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return---- | Given an IO action that returns a list of build tree refs, update the--- timestamps of the returned build tree refs to the current time (only for the--- given compiler & platform).-withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform-                        ->([AddSourceTimestamp] -> IO [FilePath])-                        -> IO ()-withUpdateTimestamps =-  withActionOnCompilerTimestamps updateTimestamps---- | Helper for implementing 'withAddTimestamps' and--- 'withRemoveTimestamps'. Runs a given action on the list of--- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then--- updates the timestamp file. The IO action is run only once.-withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]-                              -> [AddSourceTimestamp])-                             -> Verbosity-                             -> FilePath-                             -> IO [FilePath]-                             -> IO ()-withActionOnAllTimestamps f verbosity sandboxDir act =-  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do-    paths <- act-    return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords]---- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the--- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result--- and then updates the timestamp file record. The IO action is run only once.-withActionOnCompilerTimestamps :: ([AddSourceTimestamp]-                                   -> [FilePath] -> ModTime-                                   -> [AddSourceTimestamp])-                                  -> Verbosity-                                  -> FilePath-                                  -> CompilerId-                                  -> Platform-                                  -> ([AddSourceTimestamp] -> IO [FilePath])-                                  -> IO ()-withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do-  let needle = timestampRecordKey compId platform-  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do-    timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->-      if key == needle-      then do paths <- act timestamps-              now   <- getCurTime-              return (key, f timestamps paths now)-      else return r-    return timestampRecords'---- | Has this dependency been modified since we have last looked at it?-isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool-isDepModified verbosity now (packageDir, timestamp) = do-  debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)-  -- TODO: we should properly plumb the correct options through-  -- instead of using defaultSetupScriptOptions-  depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir-  go depSources--  where-    go []         = return False-    go (dep0:rest) = do-      -- FIXME: What if the clock jumps backwards at any point? For now we only-      -- print a warning.-      let dep = packageDir </> dep0-      modTime <- getModTime dep-      when (modTime > now) $-        warn verbosity $ "File '" ++ dep-                         ++ "' has a modification time that is in the future."-      if modTime >= timestamp-        then do-          debug verbosity ("Dependency has a modified source file: " ++ dep)-          return True-        else go rest---- | List all modified dependencies.-listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform-                    -> M.Map FilePath a-                       -- ^ The set of all installed add-source deps.-                    -> IO [FilePath]-listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do-  timestampRecords <- readTimestampFile verbosity (sandboxDir </> timestampFileName)-  let needle        = timestampRecordKey compId platform-  timestamps       <- maybe noTimestampRecord return-                      (lookup needle timestampRecords)-  now <- getCurTime-  fmap (map fst) . filterM (isDepModified verbosity now)-    . filter (\ts -> fst ts `M.member` installedDepsMap)-    $ timestamps--  where-    noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given "-                        ++ "compiler/platform pair. "-                        ++ "Please report this on the Cabal bug tracker: "-                        ++ "https://github.com/haskell/cabal/issues/new ."
− Distribution/Client/Sandbox/Types.hs 
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Sandbox.Types--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Helpers for writing code that works both inside and outside a sandbox.--------------------------------------------------------------------------------module Distribution.Client.Sandbox.Types (-  UseSandbox(..), isUseSandbox, whenUsingSandbox,-  SandboxPackageInfo(..)-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import Distribution.Client.Types (UnresolvedSourcePackage)--import qualified Data.Set as S---- | Are we using a sandbox?-data UseSandbox = UseSandbox FilePath | NoSandbox--instance Monoid UseSandbox where-  mempty = NoSandbox-  mappend = (<>)--instance Semigroup UseSandbox where-  NoSandbox         <> s                 = s-  u0@(UseSandbox _) <> NoSandbox         = u0-  (UseSandbox _)    <> u1@(UseSandbox _) = u1---- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with--- @when@.-isUseSandbox :: UseSandbox -> Bool-isUseSandbox (UseSandbox _) = True-isUseSandbox NoSandbox      = False---- | Execute an action only if we're in a sandbox, feeding to it the path to the--- sandbox directory.-whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()-whenUsingSandbox NoSandbox               _   = return ()-whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir---- | Data about the packages installed in the sandbox that is passed from--- 'reinstallAddSourceDeps' to the solver.-data SandboxPackageInfo = SandboxPackageInfo {-  modifiedAddSourceDependencies :: ![UnresolvedSourcePackage],-  -- ^ Modified add-source deps that we want to reinstall. These are guaranteed-  -- to be already installed in the sandbox.--  otherAddSourceDependencies    :: ![UnresolvedSourcePackage],-  -- ^ Remaining add-source deps. Some of these may be not installed in the-  -- sandbox.--  otherInstalledSandboxPackages :: !InstalledPackageIndex.InstalledPackageIndex,-  -- ^ All packages installed in the sandbox. Intersection with-  -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be-  -- non-empty.--  allAddSourceDependencies      :: !(S.Set FilePath)-  -- ^ A set of paths to all add-source dependencies, for convenience.-  }
Distribution/Client/SavedFlags.hs view
@@ -5,17 +5,15 @@        , readSavedArgs, writeSavedArgs        ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Simple.Command import Distribution.Simple.UserHooks ( Args ) import Distribution.Simple.Utils        ( createDirectoryIfMissingVerbose, unintersperse ) import Distribution.Verbosity -import Control.Exception ( Exception, throwIO )-import Control.Monad ( liftM )-import Data.List ( intercalate )-import Data.Maybe ( fromMaybe )-import Data.Typeable import System.Directory ( doesFileExist ) import System.FilePath ( takeDirectory ) @@ -41,7 +39,7 @@ readSavedArgs path = do   exists <- doesFileExist path   if exists-     then liftM (Just . unintersperse '\0') (readFile path)+     then fmap (Just . unintersperse '\0') (readFile path)     else return Nothing  @@ -49,7 +47,7 @@ -- Returns the default flags if the file does not exist. readCommandFlags :: FilePath -> CommandUI flags -> IO flags readCommandFlags path command = do-  savedArgs <- liftM (fromMaybe []) (readSavedArgs path)+  savedArgs <- fmap (fromMaybe []) (readSavedArgs path)   case (commandParseArgs command True savedArgs) of     CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)     CommandList _ -> throwIO (SavedArgsErrorList savedArgs)
Distribution/Client/Security/DNS.hs view
@@ -7,12 +7,8 @@ import Prelude () import Distribution.Client.Compat.Prelude import Network.URI (URI(..), URIAuth(..), parseURI)-import Distribution.Verbosity-import Control.Monad-import Control.DeepSeq (force)-import Control.Exception (SomeException, evaluate, try)+import Control.Exception (try) import Distribution.Simple.Utils-import Distribution.Compat.Exception (displayException)  #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) import Network.DNS (queryTXT, Name(..), CharStr(..))@@ -70,7 +66,7 @@          then warn verbosity ("No mirrors found for " ++ show repoUri)          else do info verbosity ("located " ++ show (length mirrors) ++                                  " mirrors for " ++ show repoUri ++ " :")-                 forM_ mirrors $ \url -> info verbosity ("- " ++ show url)+                 for_ mirrors $ \url -> info verbosity ("- " ++ show url)           return mirrors @@ -117,7 +113,7 @@               then warn verbosity ("No mirrors found for " ++ show repoUri)               else do info verbosity ("located " ++ show (length mirrors) ++                                       " mirrors for " ++ show repoUri ++ " :")-                      forM_ mirrors $ \url -> info verbosity ("- " ++ show url)+                      for_ mirrors $ \url -> info verbosity ("- " ++ show url)                return mirrors
Distribution/Client/Security/HTTP.hs view
@@ -8,13 +8,10 @@ -- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ -- stdlibs-import Control.Exception-         ( Exception(..), IOException )-import Data.List-         ( intercalate )-import Data.Typeable-         ( Typeable ) import System.Directory          ( getTemporaryDirectory ) import Network.URI@@ -31,10 +28,11 @@          ( withTempFileName )  -- hackage-security-import Hackage.Security.Client-import Hackage.Security.Client.Repository.HttpLib-import Hackage.Security.Util.Checked-import Hackage.Security.Util.Pretty+import           Hackage.Security.Client.Repository.HttpLib (HttpLib (..))+import qualified Hackage.Security.Client as HC+import qualified Hackage.Security.Client.Repository.HttpLib as HC+import qualified Hackage.Security.Util.Checked as HC+import qualified Hackage.Security.Util.Pretty as HC  {-------------------------------------------------------------------------------   'HttpLib' implementation@@ -62,49 +60,50 @@ transportAdapter verbosity getTransport = HttpLib{       httpGet      = \headers uri callback -> do                         transport <- getTransport-                        get verbosity transport headers uri callback+                        httpGetImpl verbosity transport headers uri callback     , httpGetRange = \headers uri range callback -> do                         transport <- getTransport                         getRange verbosity transport headers uri range callback     } -get :: Throws SomeRemoteError+httpGetImpl+    :: HC.Throws HC.SomeRemoteError     => Verbosity     -> HttpTransport-    -> [HttpRequestHeader] -> URI-    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> [HC.HttpRequestHeader] -> URI+    -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)     -> IO a-get verbosity transport reqHeaders uri callback = wrapCustomEx $ do+httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do   get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->     case code of       200 -> callback respHeaders br-      _   -> throwChecked $ UnexpectedResponse uri code+      _   -> HC.throwChecked $ UnexpectedResponse uri code -getRange :: Throws SomeRemoteError+getRange :: HC.Throws HC.SomeRemoteError          => Verbosity          -> HttpTransport-         -> [HttpRequestHeader] -> URI -> (Int, Int)-         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> [HC.HttpRequestHeader] -> URI -> (Int, Int)+         -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)          -> IO a getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do   get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->     case code of-       200 -> callback HttpStatus200OK             respHeaders br-       206 -> callback HttpStatus206PartialContent respHeaders br-       _   -> throwChecked $ UnexpectedResponse uri code+       200 -> callback HC.HttpStatus200OK             respHeaders br+       206 -> callback HC.HttpStatus206PartialContent respHeaders br+       _   -> HC.throwChecked $ UnexpectedResponse uri code  -- | Internal generalization of 'get' and 'getRange' get' :: Verbosity      -> HttpTransport-     -> [HttpRequestHeader] -> URI -> Maybe (Int, Int)-     -> (HttpCode -> [HttpResponseHeader] -> BodyReader -> IO a)+     -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)+     -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)      -> IO a get' verbosity transport reqHeaders uri mRange callback = do     tempDir <- getTemporaryDirectory     withTempFileName tempDir "transportAdapterGet" $ \temp -> do       (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'-      br <- bodyReaderFromBS =<< BS.L.readFile temp-      callback code [HttpResponseAcceptRangesBytes] br+      br <- HC.bodyReaderFromBS =<< BS.L.readFile temp+      callback code [HC.HttpResponseAcceptRangesBytes] br   where     reqHeaders' = mkReqHeaders reqHeaders mRange @@ -119,24 +118,24 @@     -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>     rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) -mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]+mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] mkReqHeaders reqHeaders mRange = concat [       tr [] reqHeaders     , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]     ]   where-    tr :: [(HTTP.HeaderName, [String])] -> [HttpRequestHeader] -> [HTTP.Header]+    tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]     tr acc [] =       concatMap finalize acc-    tr acc (HttpRequestMaxAge0:os) =+    tr acc (HC.HttpRequestMaxAge0:os) =       tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os-    tr acc (HttpRequestNoTransform:os) =+    tr acc (HC.HttpRequestNoTransform:os) =       tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os      -- Some headers are comma-separated, others need multiple headers for     -- multiple options.     ---    -- TODO: Right we we just comma-separate all of them.+    -- TODO: Right we just comma-separate all of them.     finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]     finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] @@ -157,24 +156,24 @@ data UnexpectedResponse = UnexpectedResponse URI Int   deriving (Typeable) -instance Pretty UnexpectedResponse where+instance HC.Pretty UnexpectedResponse where   pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code                                       ++ " for " ++ show uri  #if MIN_VERSION_base(4,8,0) deriving instance Show UnexpectedResponse-instance Exception UnexpectedResponse where displayException = pretty+instance Exception UnexpectedResponse where displayException = HC.pretty #else-instance Show UnexpectedResponse where show = pretty+instance Show UnexpectedResponse where show = HC.pretty instance Exception UnexpectedResponse #endif -wrapCustomEx :: ( ( Throws UnexpectedResponse-                  , Throws IOException+wrapCustomEx :: ( ( HC.Throws UnexpectedResponse+                  , HC.Throws IOException                   ) => IO a)-             -> (Throws SomeRemoteError => IO a)-wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)-                 $ handleChecked (\(ex :: IOException)        -> go ex)+             -> (HC.Throws HC.SomeRemoteError => IO a)+wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ HC.handleChecked (\(ex :: IOException)        -> go ex)                  $ act   where-    go ex = throwChecked (SomeRemoteError ex)+    go ex = HC.throwChecked (HC.SomeRemoteError ex)
Distribution/Client/Setup.hs view
@@ -21,17 +21,15 @@     , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags     , configPackageDB', configCompilerAux'     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags-    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+    , buildCommand, BuildFlags(..)     , filterTestFlags     , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions                         , configureExOptions, reconfigureCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , filterHaddockArgs, filterHaddockFlags, haddockOptions     , defaultSolver, defaultMaxBackjumps-    , listCommand, ListFlags(..)+    , listCommand, ListFlags(..), listNeedsCompiler     , updateCommand, UpdateFlags(..), defaultUpdateFlags-    , upgradeCommand-    , uninstallCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)@@ -44,10 +42,7 @@     , reportCommand, ReportFlags(..)     , runCommand     , initCommand, initOptions, IT.InitFlags(..)-    , sdistCommand, SDistFlags(..)-    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)     , actAsSetupCommand, ActAsSetupFlags(..)-    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)     , execCommand, ExecFlags(..), defaultExecFlags     , userConfigCommand, UserConfigFlags(..)     , manpageCommand@@ -60,31 +55,26 @@     , parsePackageArgs     , liftOptions     , yesNoOpt-    --TODO: stop exporting these:-    , showRemoteRepo-    , parseRemoteRepo-    , readRemoteRepo     ) where  import Prelude () import Distribution.Client.Compat.Prelude hiding (get) -import Distribution.Deprecated.ReadP (readP_to_E)+import Distribution.Client.Types.Credentials (Username (..), Password (..))+import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..))+import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..))+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy -import Distribution.Client.Types-         ( Username(..), Password(..), RemoteRepo(..)-         , LocalRepo (..), emptyLocalRepo-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)-         , WriteGhcEnvironmentFilesPolicy(..)-         ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types          ( PreSolver(..) )-import Distribution.Client.IndexUtils.Timestamp-         ( IndexState(..) )+import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )+import Distribution.Client.IndexUtils.IndexState+         ( TotalIndexState, headTotalIndexState ) import qualified Distribution.Client.Init.Types as IT-         ( InitFlags(..), PackageType(..) )+         ( InitFlags(..), PackageType(..), defaultInitFlags ) import Distribution.Client.Targets          ( UserConstraint, readUserConstraint ) import Distribution.Utils.NubList@@ -100,14 +90,17 @@ import Distribution.Simple.Configure        ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) import qualified Distribution.Simple.Setup as Cabal+import Distribution.Simple.Flag+         ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag+         , flagElim, fromFlagOrDefault+         ) import Distribution.Simple.Setup          ( ConfigFlags(..), BuildFlags(..), ReplFlags          , TestFlags, BenchmarkFlags-         , SDistFlags(..), HaddockFlags(..)+         , HaddockFlags(..)          , CleanFlags(..), DoctestFlags(..)          , CopyFlags(..), RegisterFlags(..)          , readPackageDbList, showPackageDbList-         , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag          , BooleanFlag(..), optionVerbosity          , boolOpt, boolOpt', trueArg, falseArg          , optionNumJobs )@@ -115,10 +108,9 @@          ( PathTemplate, InstallDirs(..)          , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version-         ( Version, mkVersion, nullVersion, anyVersion, thisVersion )+         ( Version, mkVersion ) import Distribution.Package-         ( PackageName, PackageIdentifier, packageName, packageVersion )-import Distribution.Types.Dependency+         ( PackageName ) import Distribution.Types.GivenComponent          ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint@@ -128,30 +120,24 @@ import Distribution.PackageDescription          ( BuildType(..), RepoKind(..), LibraryName(..) ) import Distribution.System ( Platform )-import Distribution.Deprecated.Text-         ( Text(..), display ) import Distribution.ReadE-         ( ReadE(..), succeedReadE )-import qualified Distribution.Deprecated.ReadP as Parse-         ( ReadP, char, munch1, pfail, sepBy1, (+++) )-import Distribution.Deprecated.ParseUtils-         ( readPToMaybe )+         ( ReadE(..), succeedReadE, parsecToReadE )+import qualified Distribution.Compat.CharParsing as P import Distribution.Verbosity-         ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )+         ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils-         ( wrapText, wrapLine )+         ( wrapText ) import Distribution.Client.GlobalFlags          ( GlobalFlags(..), defaultGlobalFlags          , RepoContext(..), withRepoContext          )+import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)+import Distribution.FieldGrammar.Newtypes (SpecVersion (..))  import Data.List          ( deleteFirstsBy )-import qualified Data.Set as Set import System.FilePath          ( (</>) )-import Network.URI-         ( parseAbsoluteURI, uriToString )  globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI {@@ -212,6 +198,7 @@           , "new-install"           , "new-clean"           , "new-sdist"+          , "list-bin"           -- v1 commands, stateful style           , "v1-build"           , "v1-configure"@@ -230,7 +217,6 @@           , "v1-copy"           , "v1-register"           , "v1-reconfigure"-          , "v1-sandbox"           -- v2 commands, nix-style           , "v2-build"           , "v2-configure"@@ -290,21 +276,7 @@         , addCmd "haddock"         , addCmd "hscolour"         , addCmd "exec"-        , par-        , startGroup "new-style projects (beta)"-        , addCmd "new-build"-        , addCmd "new-configure"-        , addCmd "new-repl"-        , addCmd "new-run"-        , addCmd "new-test"-        , addCmd "new-bench"-        , addCmd "new-freeze"-        , addCmd "new-haddock"-        , addCmd "new-exec"-        , addCmd "new-update"-        , addCmd "new-install"-        , addCmd "new-clean"-        , addCmd "new-sdist"+        , addCmd "list-bin"         , par         , startGroup "new-style projects (forwards-compatible aliases)"         , addCmd "v2-build"@@ -339,7 +311,6 @@         , addCmd "v1-copy"         , addCmd "v1-register"         , addCmd "v1-reconfigure"-        , addCmd "v1-sandbox"         ] ++ if null otherCmds then [] else par                                            :startGroup "other"                                            :[addCmd n | n <- otherCmds])@@ -380,26 +351,11 @@          globalConfigFile (\v flags -> flags { globalConfigFile = v })          (reqArgFlag "FILE") -      ,option [] ["sandbox-config-file"]-         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"-         globalSandboxConfigFile (\v flags -> flags { globalSandboxConfigFile = v })-         (reqArgFlag "FILE")-       ,option [] ["default-user-config"]          "Set a location for a cabal.config file for projects without their own cabal.config freeze file."          globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})          (reqArgFlag "FILE") -      ,option [] ["require-sandbox"]-         "requiring the presence of a sandbox for sandbox-aware commands"-         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })-         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))--      ,option [] ["ignore-sandbox"]-         "Ignore any existing sandbox"-         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })-         trueArg-       ,option [] ["ignore-expiry"]          "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"          globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })@@ -413,6 +369,7 @@          "Nix integration: run commands through nix-shell if a 'shell.nix' file exists"          globalNix (\v flags -> flags { globalNix = v })          (boolOpt [] [])+       ]      -- arguments we don't want shown in the help@@ -433,11 +390,6 @@          globalCacheDir (\v flags -> flags { globalCacheDir = v })          (reqArgFlag "DIR") -      ,option [] ["local-repo"]-         "The location of a local repository"-         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })-         (reqArg' "DIR" (\x -> toNubList [x]) fromNubList)-       ,option [] ["logs-dir", "logsdir"]          "The location to put log files"          globalLogsDir (\v flags -> flags { globalLogsDir = v })@@ -452,6 +404,13 @@          "The location of the nix-local-build store"          globalStoreDir (\v flags -> flags { globalStoreDir = v })          (reqArgFlag "DIR")++      , option [] ["active-repositories"]+         "The active package repositories"+         globalActiveRepos (\v flags ->  flags { globalActiveRepos = v })+         (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)+                                        (toFlag `fmap` parsec))+                         (map prettyShow . flagToList))       ]  -- ------------------------------------------------------------@@ -540,6 +499,8 @@               convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =                 Just $ GivenComponent pn LMainLibName cid           in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags+        -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.+      , configAllowDependingOnPrivateLibs = NoFlag         -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.       , configFullyStaticExe = NoFlag       }@@ -649,7 +610,7 @@     configWriteGhcEnvironmentFilesPolicy       :: Flag WriteGhcEnvironmentFilesPolicy   }-  deriving (Eq, Generic)+  deriving (Eq, Show, Generic)  defaultConfigExFlags :: ConfigExFlags defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }@@ -676,23 +637,23 @@       ("Select which version of the Cabal lib to use to build packages "       ++ "(useful for testing).")       configCabalVersion (\v flags -> flags { configCabalVersion = v })-      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)-                                    (fmap toFlag parse))-                        (map display . flagToList))+      (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)+                                    (fmap toFlag parsec))+                        (map prettyShow. flagToList))   , option [] ["constraint"]       "Specify constraints on a package (version, installed/source, flags)"       configExConstraints (\v flags -> flags { configExConstraints = v })       (reqArg "CONSTRAINT"               ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)-              (map $ display . fst))+              (map $ prettyShow . fst))    , option [] ["preference"]       "Specify preferences (soft constraints) on the version of a package"       configPreferences (\v flags -> flags { configPreferences = v })       (reqArg "CONSTRAINT"-              (readP_to_E (const "dependency expected")-                          (fmap (\x -> [x]) parse))-              (map display))+              (parsecToReadE (const "dependency expected")+                          (fmap (\x -> [x]) parsec))+              (map prettyShow))    , optionSolver configSolver (\v flags -> flags { configSolver = v }) @@ -701,7 +662,7 @@     (fmap unAllowOlder . configAllowOlder)     (\v flags -> flags { configAllowOlder = fmap AllowOlder v})     (optArg "DEPS"-     (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)      (Just RelaxDepsAll) relaxDepsPrinter)    , option [] ["allow-newer"]@@ -709,7 +670,7 @@     (fmap unAllowNewer . configAllowNewer)     (\v flags -> flags { configAllowNewer = fmap AllowNewer v})     (optArg "DEPS"-     (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)      (Just RelaxDepsAll) relaxDepsPrinter)    , option [] ["write-ghc-environment-files"]@@ -740,14 +701,14 @@   NoFlag                                               -> []  -relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)+relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) relaxDepsParser =-  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')+  (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')  relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] relaxDepsPrinter Nothing                     = [] relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]-relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs   instance Monoid ConfigExFlags where@@ -783,39 +744,18 @@ -- * Build flags -- ------------------------------------------------------------ -data SkipAddSourceDepsCheck =-  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck-  deriving Eq--data BuildExFlags = BuildExFlags {-  buildOnly     :: Flag SkipAddSourceDepsCheck-} deriving Generic--buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]-buildExOptions _showOrParseArgs =-  option [] ["only"]-  "Don't reinstall add-source dependencies (sandbox-only)"-  buildOnly (\v flags -> flags { buildOnly = v })-  (noArg (Flag SkipAddSourceDepsCheck))--  : []--buildCommand :: CommandUI (BuildFlags, BuildExFlags)+buildCommand :: CommandUI BuildFlags buildCommand = parent {     commandName = "build",     commandDescription  = Just $ \_ -> wrapText $       "Components encompass executables, tests, and benchmarks.\n"         ++ "\n"         ++ "Affected by configuration options, see `v1-configure`.\n",-    commandDefaultFlags = (commandDefaultFlags parent, mempty),+    commandDefaultFlags = commandDefaultFlags parent,     commandUsage        = usageAlternatives "v1-build" $       [ "[FLAGS]", "COMPONENTS [FLAGS]" ],-    commandOptions      =-      \showOrParseArgs -> liftOptions fst setFst-                          (commandOptions parent showOrParseArgs)-                          ++-                          liftOptions snd setSnd (buildExOptions showOrParseArgs)-    , commandNotes        = Just $ \pname ->+    commandOptions      = commandOptions parent+    , commandNotes      = Just $ \pname ->       "Examples:\n"         ++ "  " ++ pname ++ " v1-build           "         ++ "    All the components in the package\n"@@ -824,18 +764,8 @@         ++ Cabal.programFlagsDescription defaultProgramDb   }   where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)-     parent = Cabal.buildCommand defaultProgramDb -instance Monoid BuildExFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup BuildExFlags where-  (<>) = gmappend- -- ------------------------------------------------------------ -- * Test flags -- ------------------------------------------------------------@@ -871,13 +801,12 @@ -- * Repl command -- ------------------------------------------------------------ -replCommand :: CommandUI (ReplFlags, BuildExFlags)+replCommand :: CommandUI ReplFlags replCommand = parent {     commandName = "repl",     commandDescription  = Just $ \pname -> wrapText $          "If the current directory contains no package, ignores COMPONENT "-      ++ "parameters and opens an interactive interpreter session; if a "-      ++ "sandbox is present, its package database will be used.\n"+      ++ "parameters and opens an interactive interpreter session;\n"       ++ "\n"       ++ "Otherwise, (re)configures with the given or default flags, and "       ++ "loads the interpreter with the relevant modules. For executables, "@@ -893,12 +822,8 @@       ++ "not (re)configure and you will have to specify the location of "       ++ "other modules, if required.\n",     commandUsage =  \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n",-    commandDefaultFlags = (commandDefaultFlags parent, mempty),-    commandOptions      =-      \showOrParseArgs -> liftOptions fst setFst-                          (commandOptions parent showOrParseArgs)-                          ++-                          liftOptions snd setSnd (buildExOptions showOrParseArgs),+    commandDefaultFlags = commandDefaultFlags parent,+    commandOptions      = commandOptions parent,     commandNotes        = Just $ \pname ->       "Examples:\n"     ++ "  " ++ pname ++ " v1-repl           "@@ -909,16 +834,13 @@     ++ "  Specifying flags for interpreter\n"   }   where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)-     parent = Cabal.replCommand defaultProgramDb  -- ------------------------------------------------------------ -- * Test command -- ------------------------------------------------------------ -testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)+testCommand :: CommandUI (BuildFlags, TestFlags) testCommand = parent {   commandName = "test",   commandDescription  = Just $ \pname -> wrapText $@@ -933,21 +855,17 @@       ++ " define actions to be executed before and after running tests.\n",   commandUsage = usageAlternatives "v1-test"       [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ],-  commandDefaultFlags = (commandDefaultFlags parent,-                         Cabal.defaultBuildFlags, mempty),+  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),   commandOptions      =     \showOrParseArgs -> liftOptions get1 set1-                        (commandOptions parent showOrParseArgs)-                        ++-                        liftOptions get2 set2                         (Cabal.buildOptions progDb showOrParseArgs)                         ++-                        liftOptions get3 set3 (buildExOptions showOrParseArgs)+                        liftOptions get2 set2+                        (commandOptions parent showOrParseArgs)   }   where-    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)-    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)-    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)+    get1 (a,_) = a; set1 a (_,b) = (a,b)+    get2 (_,b) = b; set2 b (a,_) = (a,b)      parent = Cabal.testCommand     progDb = defaultProgramDb@@ -956,7 +874,7 @@ -- * Bench command -- ------------------------------------------------------------ -benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)+benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) benchmarkCommand = parent {   commandName = "bench",   commandUsage = usageAlternatives "v1-bench"@@ -972,21 +890,17 @@       ++ "By defining UserHooks in a custom Setup.hs, the package can"       ++ " define actions to be executed before and after running"       ++ " benchmarks.\n",-  commandDefaultFlags = (commandDefaultFlags parent,-                         Cabal.defaultBuildFlags, mempty),+  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),   commandOptions      =     \showOrParseArgs -> liftOptions get1 set1-                        (commandOptions parent showOrParseArgs)-                        ++-                        liftOptions get2 set2                         (Cabal.buildOptions progDb showOrParseArgs)                         ++-                        liftOptions get3 set3 (buildExOptions showOrParseArgs)+                        liftOptions get2 set2+                        (commandOptions parent showOrParseArgs)   }   where-    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)-    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)-    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)+    get1 (a,_) = a; set1 a (_,b) = (a,b)+    get2 (_,b) = b; set2 b (a,_) = (a,b)      parent = Cabal.benchmarkCommand     progDb = defaultProgramDb@@ -1305,7 +1219,7 @@    ,option [] ["ignore"]     "Packages to ignore"     outdatedIgnore (\v flags -> flags { outdatedIgnore = v })-    (reqArg "PKGS" pkgNameListParser (map display))+    (reqArg "PKGS" pkgNameListParser (map prettyShow))     ,option [] ["minor"]     "Ignore major version bumps for these packages"@@ -1321,14 +1235,14 @@     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]     ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =-      map (Just . display) $ pkgs+      map (Just . prettyShow) $ pkgs      ignoreMajorVersionBumpsParser  =       (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser -    pkgNameListParser = readP_to_E+    pkgNameListParser = parsecToReadE       ("Couldn't parse the list of package names: " ++)-      (Parse.sepBy1 parse (Parse.char ','))+      (fmap toList (P.sepByNonEmpty parsec (P.char ',')))  -- ------------------------------------------------------------ -- * Update command@@ -1337,14 +1251,14 @@ data UpdateFlags     = UpdateFlags {         updateVerbosity  :: Flag Verbosity,-        updateIndexState :: Flag IndexState+        updateIndexState :: Flag TotalIndexState     } deriving Generic  defaultUpdateFlags :: UpdateFlags defaultUpdateFlags     = UpdateFlags {         updateVerbosity  = toFlag normal,-        updateIndexState = toFlag IndexStateHead+        updateIndexState = toFlag headTotalIndexState     }  updateCommand  :: CommandUI UpdateFlags@@ -1366,12 +1280,12 @@            "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++            "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")           updateIndexState (\v flags -> flags { updateIndexState = v })-          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " +++          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++                                        "unix-timestamps (e.g. '@1474732068'), " ++                                        "a ISO8601 UTC timestamp " ++                                        "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))     ]   } @@ -1379,18 +1293,6 @@ -- * Other commands -- ------------------------------------------------------------ -upgradeCommand  :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                             , HaddockFlags, TestFlags, BenchmarkFlags-                             )-upgradeCommand = configureCommand {-    commandName         = "upgrade",-    commandSynopsis     = "(command disabled, use install instead)",-    commandDescription  = Nothing,-    commandUsage        = usageFlagsOrPackages "upgrade",-    commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty),-    commandOptions      = commandOptions installCommand-  }- cleanCommand :: CommandUI CleanFlags cleanCommand = Cabal.cleanCommand   { commandUsage = \pname ->@@ -1424,30 +1326,19 @@     commandOptions      = \_ -> []   } -uninstallCommand  :: CommandUI (Flag Verbosity)-uninstallCommand = CommandUI {-    commandName         = "uninstall",-    commandSynopsis     = "Warn about 'uninstall' not being implemented.",-    commandDescription  = Nothing,-    commandNotes        = Nothing,-    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> []-  }--manpageCommand :: CommandUI (Flag Verbosity)+manpageCommand :: CommandUI ManpageFlags manpageCommand = CommandUI {-    commandName         = "manpage",+    commandName         = "man",     commandSynopsis     = "Outputs manpage source.",     commandDescription  = Just $ \_ ->       "Output manpage source to STDOUT.\n",     commandNotes        = Nothing,-    commandUsage        = usageFlags "manpage",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]+    commandUsage        = usageFlags "man",+    commandDefaultFlags = defaultManpageFlags,+    commandOptions      = manpageOptions   } -runCommand :: CommandUI (BuildFlags, BuildExFlags)+runCommand :: CommandUI BuildFlags runCommand = CommandUI {     commandName         = "run",     commandSynopsis     = "Builds and runs an executable.",@@ -1467,17 +1358,9 @@     commandUsage        = usageAlternatives "v1-run"         ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],     commandDefaultFlags = mempty,-    commandOptions      =-      \showOrParseArgs -> liftOptions fst setFst-                          (commandOptions parent showOrParseArgs)-                          ++-                          liftOptions snd setSnd-                          (buildExOptions showOrParseArgs)+    commandOptions      = commandOptions parent   }   where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)-     parent = Cabal.buildCommand defaultProgramDb  -- ------------------------------------------------------------@@ -1537,7 +1420,8 @@ data GetFlags = GetFlags {     getDestDir          :: Flag FilePath,     getPristine         :: Flag Bool,-    getIndexState       :: Flag IndexState,+    getIndexState       :: Flag TotalIndexState,+    getActiveRepos      :: Flag ActiveRepos,     getSourceRepository :: Flag (Maybe RepoKind),     getVerbosity        :: Flag Verbosity   } deriving Generic@@ -1547,6 +1431,7 @@     getDestDir          = mempty,     getPristine         = mempty,     getIndexState       = mempty,+    getActiveRepos      = mempty,     getSourceRepository = mempty,     getVerbosity        = toFlag normal    }@@ -1579,8 +1464,8 @@        ,option "s" ["source-repository"]          "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."          getSourceRepository (\v flags -> flags { getSourceRepository = v })-        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")-                                              (fmap (toFlag . Just) parse))+        (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository")+                                              (fmap (toFlag . Just) parsec))                                   (Flag Nothing)                                   (map (fmap show) . flagToList)) @@ -1591,12 +1476,12 @@            "This determines which package versions are available as well as " ++            ".cabal file revision is selected (unless --pristine is used).")           getIndexState (\v flags -> flags { getIndexState = v })-          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " +++          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++                                        "unix-timestamps (e.g. '@1474732068'), " ++                                        "a ISO8601 UTC timestamp " ++                                        "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))         , option [] ["pristine"]            ("Unpack the original pristine tarball, rather than updating the "@@ -1624,20 +1509,25 @@ -- * List flags -- ------------------------------------------------------------ -data ListFlags = ListFlags {-    listInstalled    :: Flag Bool,-    listSimpleOutput :: Flag Bool,-    listVerbosity    :: Flag Verbosity,-    listPackageDBs   :: [Maybe PackageDB]-  } deriving Generic+data ListFlags = ListFlags+    { listInstalled       :: Flag Bool+    , listSimpleOutput    :: Flag Bool+    , listCaseInsensitive :: Flag Bool+    , listVerbosity       :: Flag Verbosity+    , listPackageDBs      :: [Maybe PackageDB]+    , listHcPath          :: Flag FilePath+    }+  deriving Generic  defaultListFlags :: ListFlags-defaultListFlags = ListFlags {-    listInstalled    = Flag False,-    listSimpleOutput = Flag False,-    listVerbosity    = toFlag normal,-    listPackageDBs   = []-  }+defaultListFlags = ListFlags+    { listInstalled       = Flag False+    , listSimpleOutput    = Flag False+    , listCaseInsensitive = Flag True+    , listVerbosity       = toFlag normal+    , listPackageDBs      = []+    , listHcPath          = mempty+    }  listCommand  :: CommandUI ListFlags listCommand = CommandUI {@@ -1647,9 +1537,7 @@          "List all packages, or all packages matching one of the search"       ++ " strings.\n"       ++ "\n"-      ++ "If there is a sandbox in the current directory and "-      ++ "config:ignore-sandbox is False, use the sandbox package database. "-      ++ "Otherwise, use the package database specified with --package-db. "+      ++ "Use the package database specified with --package-db. "       ++ "If not specified, use the user package database.\n",     commandNotes        = Just $ \pname ->          "Examples:\n"@@ -1658,32 +1546,48 @@     commandUsage        = usageAlternatives "list" [ "[FLAGS]"                                                    , "[FLAGS] STRINGS"],     commandDefaultFlags = defaultListFlags,-    commandOptions      = \_ -> [-        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })+    commandOptions      = const listOptions+  } -        , option [] ["installed"]-            "Only print installed packages"-            listInstalled (\v flags -> flags { listInstalled = v })-            trueArg+listOptions :: [OptionField ListFlags]+listOptions =+    [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) -        , option [] ["simple-output"]-            "Print in a easy-to-parse format"-            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })-            trueArg+    , option [] ["installed"]+        "Only print installed packages"+        listInstalled (\v flags -> flags { listInstalled = v })+        trueArg -        , option "" ["package-db"]-          (   "Append the given package database to the list of package"-           ++ " databases used (to satisfy dependencies and register into)."-           ++ " May be a specific file, 'global' or 'user'. The initial list"-           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"-           ++ " depending on context. Use 'clear' to reset the list to empty."-           ++ " See the user guide for details.")-          listPackageDBs (\v flags -> flags { listPackageDBs = v })-          (reqArg' "DB" readPackageDbList showPackageDbList)+    , option [] ["simple-output"]+        "Print in a easy-to-parse format"+        listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+        trueArg+    , option ['i'] ["ignore-case"]+        "Ignore case destictions"+        listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v })+        (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) -        ]-  }+    , option "" ["package-db"]+      (   "Append the given package database to the list of package"+       ++ " databases used (to satisfy dependencies and register into)."+       ++ " May be a specific file, 'global' or 'user'. The initial list"+       ++ " is ['global'], ['global', 'user'],"+       ++ " depending on context. Use 'clear' to reset the list to empty."+       ++ " See the user guide for details.")+      listPackageDBs (\v flags -> flags { listPackageDBs = v })+      (reqArg' "DB" readPackageDbList showPackageDbList) +    , option "w" ["with-compiler"]+      "give the path to a particular compiler"+      listHcPath (\v flags -> flags { listHcPath = v })+      (reqArgFlag "PATH")+    ]++listNeedsCompiler :: ListFlags -> Bool+listNeedsCompiler f =+    flagElim False (const True) (listHcPath f)+    || fromFlagOrDefault False (listInstalled f)+ instance Monoid ListFlags where   mempty = gmempty   mappend = (<>)@@ -1711,9 +1615,7 @@     commandName         = "info",     commandSynopsis     = "Display detailed information about a particular package.",     commandDescription  = Just $ \_ -> wrapText $-         "If there is a sandbox in the current directory and "-      ++ "config:ignore-sandbox is False, use the sandbox package database. "-      ++ "Otherwise, use the package database specified with --package-db. "+      "Use the package database specified with --package-db. "       ++ "If not specified, use the user package database.\n",     commandNotes        = Nothing,     commandUsage        = usageAlternatives "info" ["[FLAGS] PACKAGES"],@@ -1725,7 +1627,7 @@           (   "Append the given package database to the list of package"            ++ " databases used (to satisfy dependencies and register into)."            ++ " May be a specific file, 'global' or 'user'. The initial list"-           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+           ++ " is ['global'], ['global', 'user'],"            ++ " depending on context. Use 'clear' to reset the list to empty."            ++ " See the user guide for details.")           infoPackageDBs (\v flags -> flags { infoPackageDBs = v })@@ -1768,7 +1670,7 @@     installUpgradeDeps      :: Flag Bool,     installOnly             :: Flag Bool,     installOnlyDeps         :: Flag Bool,-    installIndexState       :: Flag IndexState,+    installIndexState       :: Flag TotalIndexState,     installRootCmd          :: Flag String,     installSummaryFile      :: NubList PathTemplate,     installLogFile          :: Flag PathTemplate,@@ -1782,17 +1684,9 @@     installNumJobs          :: Flag (Maybe Int),     installKeepGoing        :: Flag Bool,     installRunTests         :: Flag Bool,-    installOfflineMode      :: Flag Bool,-    -- | The cabal project file name; defaults to @cabal.project@.-    -- Th name itself denotes the cabal project file name, but it also-    -- is the base of auxiliary project files, such as-    -- @cabal.project.local@ and @cabal.project.freeze@ which are also-    -- read and written out in some cases.  If the path is not found-    -- in the current working directory, we will successively probe-    -- relative to parent directories until this name is found.-    installProjectFileName   :: Flag FilePath+    installOfflineMode      :: Flag Bool   }-  deriving (Eq, Generic)+  deriving (Eq, Show, Generic)  instance Binary InstallFlags @@ -1830,8 +1724,7 @@     installNumJobs         = mempty,     installKeepGoing       = Flag False,     installRunTests        = mempty,-    installOfflineMode     = Flag False,-    installProjectFileName = mempty+    installOfflineMode     = Flag False   }   where     docIndexFile = toPathTemplate ("$datadir" </> "doc"@@ -1844,7 +1737,7 @@ defaultSolver = AlwaysModular  allSolvers :: String-allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))+allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))  installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags                             , HaddockFlags, TestFlags, BenchmarkFlags@@ -1857,31 +1750,22 @@                                                     ],   commandDescription  = Just $ \_ -> wrapText $         "Installs one or more packages. By default, the installed package"-     ++ " will be registered in the user's package database or, if a sandbox"-     ++ " is present in the current directory, inside the sandbox.\n"+     ++ " will be registered in the user's package database."      ++ "\n"      ++ "If PACKAGES are specified, downloads and installs those packages."      ++ " Otherwise, install the package in the current directory (and/or its"      ++ " dependencies) (there must be exactly one .cabal file in the current"      ++ " directory).\n"      ++ "\n"-     ++ "When using a sandbox, the flags for `v1-install` only affect the"-     ++ " current command and have no effect on future commands. (To achieve"-     ++ " that, `v1-configure` must be used.)\n"-     ++ " In contrast, without a sandbox, the flags to `v1-install` are saved and"+     ++ "The flags to `v1-install` are saved and"      ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"      ++ " `v1-configure` for a list of commands being affected.\n"      ++ "\n"-     ++ "Installed executables will by default (and without a sandbox)"+     ++ "Installed executables will by default"      ++ " be put into `~/.cabal/bin/`."      ++ " If you want installed executable to be available globally, make"      ++ " sure that the PATH environment variable contains that directory.\n"-     ++ "When using a sandbox, executables will be put into"-     ++ " `$SANDBOX/bin/` (by default: `./.cabal-sandbox/bin/`).\n"-     ++ "\n"-     ++ "When specifying --bindir, consider also specifying --datadir;"-     ++ " this way the sandbox can be deleted and the executable should"-     ++ " continue working as long as bindir and datadir are left untouched.",+     ++ "\n",   commandNotes        = Just $ \pname ->         ( case commandNotes                $ Cabal.configureCommand defaultProgramDb@@ -2080,12 +1964,12 @@            "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++            "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")           installIndexState (\v flags -> flags { installIndexState = v })-          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " +++          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++                                        "unix-timestamps (e.g. '@1474732068'), " ++                                        "a ISO8601 UTC timestamp " ++                                        "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))        , option [] ["root-cmd"]           "(No longer supported, do not use.)"@@ -2111,10 +1995,10 @@       , option [] ["remote-build-reporting"]           "Generate build reports to send to a remote server (none, anonymous or detailed)."           installBuildReports (\v flags -> flags { installBuildReports = v })-          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "+          (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', "                                             ++ "'anonymous' or 'detailed'")-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))        , option [] ["report-planning-failure"]           "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."@@ -2149,10 +2033,6 @@           installOfflineMode (\v flags -> flags { installOfflineMode = v })           (yesNoOpt showOrParseArgs) -      , option [] ["project-file"]-          "Set the name of the cabal.project file to search for in parent directories"-          installProjectFileName (\v flags -> flags {installProjectFileName = v})-          (reqArgFlag "FILE")       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"                                         -- avoids           ParseArgs ->@@ -2204,7 +2084,7 @@     commandDescription  = Nothing,     commandNotes        = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n"-      ++ relevantConfigValuesText ["username", "password"],+      ++ relevantConfigValuesText ["username", "password", "password-command"],     commandUsage        = \pname ->          "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",     commandDefaultFlags = defaultUploadFlags,@@ -2255,12 +2135,6 @@ -- * Init flags -- ------------------------------------------------------------ -emptyInitFlags :: IT.InitFlags-emptyInitFlags  = mempty--defaultInitFlags :: IT.InitFlags-defaultInitFlags  = emptyInitFlags { IT.initVerbosity = toFlag normal }- initCommand :: CommandUI IT.InitFlags initCommand = CommandUI {     commandName = "init",@@ -2278,7 +2152,7 @@     commandNotes = Nothing,     commandUsage = \pname ->          "Usage: " ++ pname ++ " init [FLAGS]\n",-    commandDefaultFlags = defaultInitFlags,+    commandDefaultFlags = IT.defaultInitFlags,     commandOptions = initOptions   } @@ -2317,30 +2191,30 @@   , option ['p'] ["package-name"]     "Name of the Cabal package to create."     IT.packageName (\v flags -> flags { IT.packageName = v })-    (reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++)-                                  (toFlag `fmap` parse))-                      (flagToList . fmap display))+    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))    , option [] ["version"]     "Initial version of the package."     IT.version (\v flags -> flags { IT.version = v })-    (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)-                                  (toFlag `fmap` parse))-                      (flagToList . fmap display))+    (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))    , option [] ["cabal-version"]     "Version of the Cabal specification."     IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })-    (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal specification version: "++)-                                        (toFlag `fmap` parse))-                            (flagToList . fmap display))+    (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++)+                                        (fmap (toFlag . getSpecVersion) parsec))+                            (flagToList . fmap (prettyShow . SpecVersion)))    , option ['l'] ["license"]     "Project license."     IT.license (\v flags -> flags { IT.license = v })-    (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)-                                  (toFlag `fmap` parse))-                      (flagToList . fmap display))+    (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))    , option ['a'] ["author"]     "Name of the project's author."@@ -2419,32 +2293,32 @@     "Specify the default language."     IT.language     (\v flags -> flags { IT.language = v })-    (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++)-                                   (toFlag `fmap` parse))-                      (flagToList . fmap display))+    (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++)+                                   (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))    , option ['o'] ["expose-module"]     "Export a module from the package."     IT.exposedModules     (\v flags -> flags { IT.exposedModules = v })-    (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)-                                 ((Just . (:[])) `fmap` parse))-                     (maybe [] (fmap display)))+    (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)+                                 ((Just . (:[])) `fmap` parsec))+                     (maybe [] (fmap prettyShow)))    , option [] ["extension"]     "Use a LANGUAGE extension (in the other-extensions field)."     IT.otherExts     (\v flags -> flags { IT.otherExts = v })-    (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++)-                                    ((Just . (:[])) `fmap` parse))-                        (maybe [] (fmap display)))+    (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)+                                    ((Just . (:[])) `fmap` parsec))+                        (maybe [] (fmap prettyShow)))    , option ['d'] ["dependency"]     "Package dependency."     IT.dependencies (\v flags -> flags { IT.dependencies = v })-    (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)-                                  ((Just . (:[])) `fmap` parse))-                      (maybe [] (fmap display)))+    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++)+                                  ((Just . (:[])) `fmap` parsec))+                      (maybe [] (fmap prettyShow)))    , option [] ["application-dir"]     "Directory containing package application executable."@@ -2479,18 +2353,6 @@ -- * SDist flags -- ------------------------------------------------------------ --- | Extra flags to @sdist@ beyond runghc Setup sdist----sdistCommand :: CommandUI SDistFlags-sdistCommand = Cabal.sdistCommand {-    commandUsage        = \pname ->-        "Usage: " ++ pname ++ " v1-sdist [FLAGS]\n",-    commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand)-  }------ doctestCommand :: CommandUI DoctestFlags doctestCommand = Cabal.doctestCommand   { commandUsage = \pname ->  "Usage: " ++ pname ++ " v1-doctest [FLAGS]\n" }@@ -2514,41 +2376,6 @@  { commandUsage = \pname ->  "Usage: " ++ pname ++ " v1-register [FLAGS]\n" }  -- --------------------------------------------------------------- * Win32SelfUpgrade flags--- --------------------------------------------------------------data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags {-  win32SelfUpgradeVerbosity :: Flag Verbosity-} deriving Generic--defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags-defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags {-  win32SelfUpgradeVerbosity = toFlag normal-}--win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags-win32SelfUpgradeCommand = CommandUI {-  commandName         = "win32selfupgrade",-  commandSynopsis     = "Self-upgrade the executable on Windows",-  commandDescription  = Nothing,-  commandNotes        = Nothing,-  commandUsage        = \pname ->-    "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n",-  commandDefaultFlags = defaultWin32SelfUpgradeFlags,-  commandOptions      = \_ ->-      [optionVerbosity win32SelfUpgradeVerbosity-       (\v flags -> flags { win32SelfUpgradeVerbosity = v})-      ]-}--instance Monoid Win32SelfUpgradeFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup Win32SelfUpgradeFlags where-  (<>) = gmappend---- ------------------------------------------------------------ -- * ActAsSetup flags -- ------------------------------------------------------------ @@ -2574,9 +2401,9 @@       [option "" ["build-type"]          "Use the given build type."          actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })-         (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++)-                               (fmap toFlag parse))-                              (map display . flagToList))+         (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++)+                               (fmap toFlag parsec))+                              (map prettyShow . flagToList))       ] } @@ -2588,128 +2415,6 @@   (<>) = gmappend  -- --------------------------------------------------------------- * Sandbox-related flags--- --------------------------------------------------------------data SandboxFlags = SandboxFlags {-  sandboxVerbosity :: Flag Verbosity,-  sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only-                                 -- flag.-  sandboxLocation  :: Flag FilePath-} deriving Generic--defaultSandboxLocation :: FilePath-defaultSandboxLocation = ".cabal-sandbox"--defaultSandboxFlags :: SandboxFlags-defaultSandboxFlags = SandboxFlags {-  sandboxVerbosity = toFlag normal,-  sandboxSnapshot  = toFlag False,-  sandboxLocation  = toFlag defaultSandboxLocation-  }--sandboxCommand :: CommandUI SandboxFlags-sandboxCommand = CommandUI {-  commandName         = "sandbox",-  commandSynopsis     = "Create/modify/delete a sandbox.",-  commandDescription  = Just $ \pname -> concat-    [ paragraph $ "Sandboxes are isolated package databases that can be used"-      ++ " to prevent dependency conflicts that arise when many different"-      ++ " packages are installed in the same database (i.e. the user's"-      ++ " database in the home directory)."-    , paragraph $ "A sandbox in the current directory (created by"-      ++ " `v1-sandbox init`) will be used instead of the user's database for"-      ++ " commands such as `v1-install` and `v1-build`. Note that (a directly"-      ++ " invoked) GHC will not automatically be aware of sandboxes;"-      ++ " only if called via appropriate " ++ pname-      ++ " commands, e.g. `v1-repl`, `v1-build`, `v1-exec`."-    , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox"-      ++ " in folders above the current one, so cabal will not see the sandbox"-      ++ " if you are in a subfolder of a sandbox."-    , paragraph "Subcommands:"-    , headLine "init:"-    , indentParagraph $ "Initialize a sandbox in the current directory."-      ++ " An existing package database will not be modified, but settings"-      ++ " (such as the location of the database) can be modified this way."-    , headLine "delete:"-    , indentParagraph $ "Remove the sandbox; deleting all the packages"-      ++ " installed inside."-    , headLine "add-source:"-    , indentParagraph $ "Make one or more local packages available in the"-      ++ " sandbox. PATHS may be relative or absolute."-      ++ " Typical usecase is when you need"-      ++ " to make a (temporary) modification to a dependency: You download"-      ++ " the package into a different directory, make the modification,"-      ++ " and add that directory to the sandbox with `add-source`."-    , indentParagraph $ "Unless given `--snapshot`, any add-source'd"-      ++ " dependency that was modified since the last build will be"-      ++ " re-installed automatically."-    , headLine "delete-source:"-    , indentParagraph $ "Remove an add-source dependency; however, this will"-      ++ " not delete the package(s) that have been installed in the sandbox"-      ++ " from this dependency. You can either unregister the package(s) via"-      ++ " `" ++ pname ++ " v1-sandbox hc-pkg unregister` or re-create the"-      ++ " sandbox (`v1-sandbox delete; v1-sandbox init`)."-    , headLine "list-sources:"-    , indentParagraph $ "List the directories of local packages made"-      ++ " available via `" ++ pname ++ " v1-sandbox add-source`."-    , headLine "hc-pkg:"-    , indentParagraph $ "Similar to `ghc-pkg`, but for the sandbox package"-      ++ " database. Can be used to list specific/all packages that are"-      ++ " installed in the sandbox. For subcommands, see the help for"-      ++ " ghc-pkg. Affected by the compiler version specified by `v1-configure`."-    ],-  commandNotes        = Just $ \pname ->-       relevantConfigValuesText ["require-sandbox"-                                ,"ignore-sandbox"]-    ++ "\n"-    ++ "Examples:\n"-    ++ "  Set up a sandbox with one local dependency, located at ../foo:\n"-    ++ "    " ++ pname ++ " v1-sandbox init\n"-    ++ "    " ++ pname ++ " v1-sandbox add-source ../foo\n"-    ++ "    " ++ pname ++ " v1-install --only-dependencies\n"-    ++ "  Reset the sandbox:\n"-    ++ "    " ++ pname ++ " v1-sandbox delete\n"-    ++ "    " ++ pname ++ " v1-sandbox init\n"-    ++ "    " ++ pname ++ " v1-install --only-dependencies\n"-    ++ "  List the packages in the sandbox:\n"-    ++ "    " ++ pname ++ " v1-sandbox hc-pkg list\n"-    ++ "  Unregister the `broken` package from the sandbox:\n"-    ++ "    " ++ pname ++ " v1-sandbox hc-pkg -- --force unregister broken\n",-  commandUsage        = usageAlternatives "v1-sandbox"-    [ "init          [FLAGS]"-    , "delete        [FLAGS]"-    , "add-source    [FLAGS] PATHS"-    , "delete-source [FLAGS] PATHS"-    , "list-sources  [FLAGS]"-    , "hc-pkg        [FLAGS] [--] COMMAND [--] [ARGS]"-    ],--  commandDefaultFlags = defaultSandboxFlags,-  commandOptions      = \_ ->-    [ optionVerbosity sandboxVerbosity-      (\v flags -> flags { sandboxVerbosity = v })--    , option [] ["snapshot"]-      "Take a snapshot instead of creating a link (only applies to 'add-source')"-      sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v })-      trueArg--    , option [] ["sandbox"]-      "Sandbox location (default: './.cabal-sandbox')."-      sandboxLocation (\v flags -> flags { sandboxLocation = v })-      (reqArgFlag "DIR")-    ]-  }--instance Monoid SandboxFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup SandboxFlags where-  (<>) = gmappend---- ------------------------------------------------------------ -- * Exec Flags -- ------------------------------------------------------------ @@ -2859,11 +2564,11 @@              -> OptionField flags optionSolver get set =   option [] ["solver"]-    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")+    ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")     get set-    (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)-                                 (toFlag `fmap` parse))-                     (flagToList . fmap display))+    (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers)+                                    (toFlag `fmap` parsec))+                     (flagToList . fmap prettyShow))  optionSolverFlags :: ShowOrParseArgs                   -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)@@ -2883,7 +2588,7 @@   [ option [] ["max-backjumps"]       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")       getmbj setmbj-      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse))+      (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral))                     (map show . flagToList))   , option [] ["reorder-goals"]       "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."@@ -2932,18 +2637,13 @@       getoc       setoc       (reqArg "none|all"-         (readP_to_E+         (parsecToReadE             (const "reject-unconstrained-dependencies must be 'none' or 'all'")-            (toFlag `fmap` parse))-         (flagToList . fmap display))+            (toFlag `fmap` parsec))+         (flagToList . fmap prettyShow))    ] -usageFlagsOrPackages :: String -> String -> String-usageFlagsOrPackages name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"-  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"- usagePackages :: String -> String -> String usagePackages name pname =      "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"@@ -2953,85 +2653,29 @@   "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"  --TODO: do we want to allow per-package flags?-parsePackageArgs :: [String] -> Either String [Dependency]-parsePackageArgs = parsePkgArgs []-  where-    parsePkgArgs ds [] = Right (reverse ds)-    parsePkgArgs ds (arg:args) =-      case readPToMaybe parseDependencyOrPackageId arg of-        Just dep -> parsePkgArgs (dep:ds) args-        Nothing  -> Left $-         show arg ++ " is not valid syntax for a package name or"-                  ++ " package dependency."--parseDependencyOrPackageId :: Parse.ReadP r Dependency-parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse-  where-    pkgidToDependency :: PackageIdentifier -> Dependency-    pkgidToDependency p = case packageVersion p of-      v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName)-        | otherwise        -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName)+parsePackageArgs :: [String] -> Either String [PackageVersionConstraint]+parsePackageArgs = traverse p where+    p arg = case eitherParsec arg of+        Right pvc -> Right pvc+        Left err  -> Left $+          show arg ++ " is not valid syntax for a package name or"+                   ++ " package dependency. " ++ err   showRemoteRepo :: RemoteRepo -> String-showRemoteRepo repo = remoteRepoName repo ++ ":"-             ++ uriToString id (remoteRepoURI repo) []+showRemoteRepo = prettyShow  readRemoteRepo :: String -> Maybe RemoteRepo-readRemoteRepo = readPToMaybe parseRemoteRepo--parseRemoteRepo :: Parse.ReadP r RemoteRepo-parseRemoteRepo = do-  name   <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")-  _      <- Parse.char ':'-  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")-  uri    <- maybe Parse.pfail return (parseAbsoluteURI uriStr)-  return RemoteRepo {-    remoteRepoName           = name,-    remoteRepoURI            = uri,-    remoteRepoSecure         = Nothing,-    remoteRepoRootKeys       = [],-    remoteRepoKeyThreshold   = 0,-    remoteRepoShouldTryHttps = False-  }+readRemoteRepo = simpleParsec  showLocalRepo :: LocalRepo -> String-showLocalRepo repo = localRepoName repo ++ ":" ++ localRepoPath repo+showLocalRepo = prettyShow  readLocalRepo :: String -> Maybe LocalRepo-readLocalRepo = readPToMaybe parseLocalRepo--parseLocalRepo :: Parse.ReadP r LocalRepo-parseLocalRepo = do-  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")-  _    <- Parse.char ':'-  path <- Parse.munch1 (const True)-  return $ (emptyLocalRepo name)-    { localRepoPath = path-    }+readLocalRepo = simpleParsec  -- ------------------------------------------------------------ -- * Helpers for Documentation -- --------------------------------------------------------------headLine :: String -> String-headLine = unlines-         . map unwords-         . wrapLine 79-         . words--paragraph :: String -> String-paragraph = (++"\n")-          . unlines-          . map unwords-          . wrapLine 79-          . words--indentParagraph :: String -> String-indentParagraph = unlines-                . (flip (++)) [""]-                . map (("  "++).unwords)-                . wrapLine 77-                . words  relevantConfigValuesText :: [String] -> String relevantConfigValuesText vs =
Distribution/Client/SetupWrapper.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.SetupWrapper@@ -25,6 +26,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version@@ -39,7 +41,8 @@ import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)          , PackageDescription(..), specVersion, buildType-         , BuildType(..), defaultRenaming )+         , BuildType(..) )+import Distribution.Types.ModuleRenaming (defaultRenaming) import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription ) import Distribution.Simple.Configure@@ -85,9 +88,9 @@          ( safeHead ) import Distribution.Simple.Utils          ( die', debug, info, infoNoWrap-         , cabalVersion, tryFindPackageDesc, comparing+         , cabalVersion, tryFindPackageDesc          , createDirectoryIfMissingVerbose, installExecutableFile-         , copyFileVerbose, rewriteFileEx )+         , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) import Distribution.Client.Utils          ( inDir, tryCanonicalizePath, withExtraPathEnv          , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides@@ -98,25 +101,23 @@  import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform )-import Distribution.Deprecated.Text-         ( display ) import Distribution.Utils.NubList          ( toNubListR ) import Distribution.Verbosity-import Distribution.Compat.Exception-         ( catchIO ) import Distribution.Compat.Stack  import System.Directory    ( doesFileExist ) import System.FilePath     ( (</>), (<.>) ) import System.IO           ( Handle, hPutStr )-import System.Exit         ( ExitCode(..), exitWith )-import System.Process      ( createProcess, StdStream(..), proc, waitForProcess+import Distribution.Compat.Process (createProcess)+import System.Process      ( StdStream(..), proc, waitForProcess                            , ProcessHandle ) import qualified System.Process as Process import Data.List           ( foldl1' ) import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath ) +import qualified Data.ByteString.Lazy as BS+ #ifdef mingw32_HOST_OS import Distribution.Simple.Utils          ( withTempDirectory )@@ -301,7 +302,7 @@   let options'    = options {                       useCabalVersion = intersectVersionRanges                                           (useCabalVersion options)-                                          (orLaterVersion (specVersion pkg))+                                          (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))                     }       buildType'  = buildType pkg   (version, method, options'') <-@@ -464,6 +465,7 @@     mbToStd :: Maybe Handle -> StdStream     mbToStd Nothing = Inherit     mbToStd (Just hdl) = UseHandle hdl+ -- ------------------------------------------------------------ -- * Self-Exec SetupMethod -- ------------------------------------------------------------@@ -471,7 +473,7 @@ selfExecSetupMethod :: SetupRunner selfExecSetupMethod verbosity options bt args0 = do   let args = ["act-as-setup",-              "--build-type=" ++ display bt,+              "--build-type=" ++ prettyShow bt,               "--"] ++ args0   info verbosity $ "Using self-exec internal setup method with build-type "                  ++ show bt ++ " and args:\n  " ++ show args@@ -564,7 +566,7 @@     ++ show (useDependenciesExclusive options)   createDirectoryIfMissingVerbose verbosity True setupDir   (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse-  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion+  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion   path <- if useCachedSetupExecutable           then getCachedSetupExecutable options'                cabalLibVersion mCabalLibInstalledPkgId@@ -700,17 +702,15 @@       customSetupLhs  = workingDir options </> "Setup.lhs"    updateSetupScript cabalLibVersion _ =-    rewriteFileEx verbosity setupHs (buildTypeScript cabalLibVersion)+    rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) -  buildTypeScript :: Version -> String+  buildTypeScript :: Version -> BS.ByteString   buildTypeScript cabalLibVersion = case bt of-    Simple    -> "import Distribution.Simple; main = defaultMain\n"-    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= mkVersion [1,3,10]-                   then "autoconfUserHooks\n"-                   else "defaultUserHooks\n"-    Make      -> "import Distribution.Make; main = defaultMain\n"-    Custom    -> error "buildTypeScript Custom"+    Simple                                            -> "import Distribution.Simple; main = defaultMain\n"+    Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"+              | otherwise                             -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"+    Make                                              -> "import Distribution.Make; main = defaultMain\n"+    Custom                                            -> error "buildTypeScript Custom"    installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb                         -> IO (Version, Maybe InstalledPackageId@@ -724,9 +724,9 @@         cabalDepVersion = useCabalVersion options'         options''       = options' { usePackageIndex = Just index }     case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of-      []   -> die' verbosity $ "The package '" ++ display (packageName pkg)+      []   -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg)                  ++ "' requires Cabal library version "-                 ++ display (useCabalVersion options)+                 ++ prettyShow (useCabalVersion options)                  ++ " but no suitable version is installed."       pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs                   err = error "Distribution.Client.installedCabalVersion: empty version list"@@ -795,11 +795,11 @@     return (setupCacheDir, cachedSetupProgFile)       where         buildTypeString       = show bt-        cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)-        compilerVersionString = display $+        cabalVersionString    = "Cabal-" ++ prettyShow cabalLibVersion+        compilerVersionString = prettyShow $                                 maybe buildCompilerId compilerId                                   $ useCompiler options'-        platformString        = display platform+        platformString        = prettyShow platform    -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.@@ -903,7 +903,7 @@       let ghcCmdLine = renderGhcOptions compiler platform ghcOptions       when (useVersionMacros options') $         rewriteFileEx verbosity cppMacrosFile-            (generatePackageVersionMacros (map snd selectedDeps))+          $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)       case useLoggingHandle options of         Nothing          -> runDbProgram verbosity program progdb ghcCmdLine
Distribution/Client/SolverInstallPlan.hs view
@@ -57,9 +57,8 @@ import Distribution.Package          ( PackageIdentifier(..), Package(..), PackageName          , HasUnitId(..), PackageId, packageVersion, packageName )+import Distribution.Types.Flag (nullFlagAssignment) import qualified Distribution.Solver.Types.ComponentDeps as CD-import Distribution.Deprecated.Text-         ( display )  import Distribution.Client.Types          ( UnresolvedPkgLoc )@@ -69,6 +68,7 @@ import           Distribution.Solver.Types.Settings import           Distribution.Solver.Types.ResolverPackage import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage  import Distribution.Compat.Graph (Graph, IsNode(..)) import qualified Data.Foldable as Foldable@@ -111,11 +111,24 @@ showInstallPlan = showPlanIndex . toList  showPlanPackage :: SolverPlanPackage -> String-showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg)-                                            ++ " (" ++ display (installedUnitId ipkg)+showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg)+                                            ++ " (" ++ prettyShow (installedUnitId ipkg)                                             ++ ")"-showPlanPackage (Configured  spkg)   = "Configured " ++ display (packageId spkg)+showPlanPackage (Configured  spkg) =+    "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps+  where+    flags+        | nullFlagAssignment fa = ""+        | otherwise             = " " ++ prettyShow (solverPkgFlags spkg)+      where+        fa = solverPkgFlags spkg +    comps | null deps = ""+          | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)+      where+        deps = CD.components (solverPkgLibDeps spkg)+             <> CD.components (solverPkgExeDeps spkg)+ -- | Build an installation plan from a valid set of resolved packages. -- new :: IndependentGoals@@ -173,26 +186,26 @@  showPlanProblem :: SolverPlanProblem -> String showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (packageId pkg)+     "Package " ++ prettyShow (packageId pkg)   ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map display missingDeps)+  ++ intercalate ", " (map prettyShow missingDeps)  showPlanProblem (PackageCycle cycleGroup) =      "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display.packageId) cycleGroup)+  ++ intercalate ", " (map (prettyShow.packageId) cycleGroup)  showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ display name+     "Package " ++ prettyShow name   ++ " is required by several packages,"   ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ display pkg ++ " requires "-                            ++ display (PackageIdentifier name ver)+  ++ unlines [ "  package " ++ prettyShow pkg ++ " requires "+                            ++ prettyShow (PackageIdentifier name ver)              | (pkg, ver) <- inconsistencies ]  showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (packageId pkg)+     "Package " ++ prettyShow (packageId pkg)   ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ display (packageId pkg')+  ++ " state but it depends on package " ++ prettyShow (packageId pkg')   ++ " which is in the " ++ showPlanState pkg'   ++ " state"   where@@ -321,7 +334,7 @@     ]   where     -- For each package name (of a dependency, somewhere)-    --   and each installed ID of that that package+    --   and each installed ID of that package     --     the associated package instance     --     and a list of reverse dependencies (as source IDs)     inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))
Distribution/Client/SourceFiles.hs view
@@ -37,7 +37,6 @@ import Distribution.Client.Compat.Prelude  import System.FilePath-import Control.Monad import qualified Data.Set as Set  needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild ()@@ -48,7 +47,7 @@  needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () needElaboratedPackage elab epkg =-    mapM_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)+    traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)   where     pkg_descr = elabPkgDescription elab     enabled_stanzas = pkgStanzasEnabled epkg@@ -89,7 +88,7 @@ needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs                                      , foreignLibBuildInfo = bi })-  = do mapM_ needIfExists fs+  = do traverse_ needIfExists fs        needBuildInfo pkg_descr bi []  needExecutable :: PackageDescription -> Executable -> Rebuild ()@@ -145,21 +144,21 @@     -- A.hs-boot; need to track both.     findNeededModules ["hs", "lhs", "hsig", "lhsig"]     findNeededModules ["hs-boot", "lhs-boot"]-    mapM_ needIfExists (cSources bi ++ jsSources bi)-    -- A MASSIVE HACK to (1) make sure we rebuild when header-    -- files change, but (2) not have to rebuild when anything-    -- in extra-src-files changes (most of these won't affect-    -- compilation).  It would be even better if we knew on a-    -- per-component basis which headers would be used but that-    -- seems to be too difficult.-    mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr))-    forM_ (installIncludes bi) $ \f ->+    traverse_ needIfExists $ concat+        [ cSources bi+        , cxxSources bi+        , jsSources bi+        , cmmSources bi+        , asmSources bi+        , extraSrcFiles pkg_descr+        ]+    for_ (installIncludes bi) $ \f ->         findFileMonitored ("." : includeDirs bi) f             >>= maybe (return ()) need   where-    findNeededModules exts =-        mapM_ (findNeededModule exts)-              (modules ++ otherModules bi)+    findNeededModules exts = traverse_+        (findNeededModule exts)+        (modules ++ otherModules bi)     findNeededModule exts m =         findFileWithExtensionMonitored             (ppSuffixes knownSuffixHandlers ++ exts)
− Distribution/Client/SourceRepo.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-module Distribution.Client.SourceRepo where--import Distribution.Client.Compat.Prelude-import Prelude ()-import Distribution.Compat.Lens (Lens, Lens')--import Distribution.Types.SourceRepo-         ( RepoType(..))-import Distribution.FieldGrammar (FieldGrammar, ParsecFieldGrammar', PrettyFieldGrammar', uniqueField, uniqueFieldAla, optionalFieldAla, monoidalFieldAla)-import Distribution.Parsec.Newtypes (Token (..), FilePathNT (..), alaList', NoCommaFSep (..))---- | @source-repository-package@ definition----data SourceRepositoryPackage f = SourceRepositoryPackage-    { srpType     :: !RepoType-    , srpLocation :: !String-    , srpTag      :: !(Maybe String)-    , srpBranch   :: !(Maybe String)-    , srpSubdir   :: !(f FilePath)-    }-  deriving (Generic)--deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)-deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)-deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)-deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)-deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)---- | Read from @cabal.project@-type SourceRepoList  = SourceRepositoryPackage []---- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'-type SourceRepoMaybe = SourceRepositoryPackage Maybe---- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.-type SourceRepoProxy = SourceRepositoryPackage Proxy--srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g-srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }--srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy-srpToProxy s = s { srpSubdir = Proxy }---- | Split single @source-repository-package@ declaration with multiple subdirs,--- into multiple ones with at most single subdir.-srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)-srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =-    s { srpSubdir = Nothing } :| []-srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where-    f subdir = s { srpSubdir = Just subdir }------------------------------------------------------------------------------------ Lens----------------------------------------------------------------------------------srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType-srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))-{-# INLINE srpTypeLens #-}--srpLocationLens :: Lens' (SourceRepositoryPackage f) String-srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))-{-# INLINE srpLocationLens #-}--srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)-srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))-{-# INLINE srpTagLens #-}--srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)-srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))-{-# INLINE srpBranchLens #-}--srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)-srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))-{-# INLINE srpSubdirLens #-}------------------------------------------------------------------------------------ Parser & PPrinter----------------------------------------------------------------------------------sourceRepositoryPackageGrammar-    :: (FieldGrammar g, Applicative (g SourceRepoList))-    => g SourceRepoList SourceRepoList-sourceRepositoryPackageGrammar = SourceRepositoryPackage-    <$> uniqueField      "type"                                       srpTypeLens-    <*> uniqueFieldAla   "location" Token                             srpLocationLens-    <*> optionalFieldAla "tag"      Token                             srpTagLens-    <*> optionalFieldAla "branch"   Token                             srpBranchLens-    <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...-{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}-{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
Distribution/Client/SrcDist.hs view
@@ -1,155 +1,93 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE FlexibleContexts #-}--- Implements the \"@.\/cabal sdist@\" command, which creates a source--- distribution for this package.  That is, packs up the source code--- into a tarball, making use of the corresponding Cabal module.+{-# LANGUAGE OverloadedStrings #-}+-- | Utilities to implemenet cabal @v2-sdist@. module Distribution.Client.SrcDist (-         sdist,-         allPackageSourceFiles-  )  where---import Distribution.Client.SetupWrapper-        ( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper )-import Distribution.Client.Tar (createTarGzFile)--import Distribution.Package-         ( Package(..), packageName )-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, defaultPackageDesc-         , warn, notice, withTempDirectory )-import Distribution.Client.Setup-         ( SDistFlags(..) )-import Distribution.Simple.Setup-         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault-         , defaultSDistFlags )-import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Deprecated.Text ( display )-import Distribution.Verbosity (Verbosity, normal, lessVerbose)-import Distribution.Version   (mkVersion, orLaterVersion, intersectVersionRanges)--import Distribution.Client.Utils-  (tryFindAddSourcePackageDesc)-import Distribution.Compat.Exception                 (catchIO)--import System.FilePath ((</>), (<.>))-import Control.Monad (when, unless, liftM)-import System.Directory (getTemporaryDirectory)-import Control.Exception                             (IOException, evaluate)---- |Create a source distribution.-sdist :: SDistFlags -> IO ()-sdist flags = do-  pkg <- liftM flattenPackageDescription-    (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity)-  let withDir :: (FilePath -> IO a) -> IO a-      withDir = if not needMakeArchive then \f -> f tmpTargetDir-                else withTempDirectory verbosity tmpTargetDir "sdist."-  -- 'withTempDir' fails if we don't create 'tmpTargetDir'...-  when needMakeArchive $-    createDirectoryIfMissingVerbose verbosity True tmpTargetDir-  withDir $ \tmpDir -> do-    let outDir = if isOutDirectory then tmpDir else tmpDir </> tarBallName pkg-        flags' = (if not needMakeArchive then flags-                  else flags { sDistDirectory = Flag outDir })-    unless isListSources $-      createDirectoryIfMissingVerbose verbosity True outDir--    -- Run 'setup sdist --output-directory=tmpDir' (or-    -- '--list-source'/'--output-directory=someOtherDir') in case we were passed-    -- those options.-    setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') (const [])--    -- Unless we were given --list-sources or --output-directory ourselves,-    -- create an archive.-    when needMakeArchive $-      createTarGzArchive verbosity pkg tmpDir distPref--    when isOutDirectory $-      notice verbosity $ "Source directory created: " ++ tmpTargetDir--    when isListSources $-      notice verbosity $ "List of package sources written to file '"-                         ++ (fromFlag . sDistListSources $ flags) ++ "'"+    allPackageSourceFiles,+    packageDirToSdist,+)  where -  where-    flagEnabled f  = not . null . flagToList . f $ flags+import Distribution.Client.Compat.Prelude+import Prelude () -    isListSources   = flagEnabled sDistListSources-    isOutDirectory  = flagEnabled sDistDirectory-    needMakeArchive = not (isListSources || isOutDirectory)-    verbosity       = fromFlag (sDistVerbosity flags)-    distPref        = fromFlag (sDistDistPref flags)-    tmpTargetDir    = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags)-    setupOpts       = defaultSetupScriptOptions {-      useDistPref     = distPref,-      -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and-      -- '--list-sources' in 1.17.-      useCabalVersion = if isListSources-                        then orLaterVersion $ mkVersion [1,17,0]-                        else orLaterVersion $ mkVersion [1,12,0]-      }+import Control.Monad.State.Lazy  (StateT, evalStateT, gets, modify)+import Control.Monad.Trans       (liftIO)+import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)+import System.FilePath           (normalise, takeDirectory, (</>)) -tarBallName :: PackageDescription -> String-tarBallName = display . packageId+import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc)+import Distribution.Package                          (Package (packageId))+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)+import Distribution.Simple.PreProcess                (knownSuffixHandlers)+import Distribution.Simple.SrcDist                   (listPackageSources)+import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)+import Distribution.Simple.Utils                     (die')+import Distribution.Types.GenericPackageDescription  (GenericPackageDescription) --- | Create a tar.gz archive from a tree of source files.-createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath-                    -> IO ()-createTarGzArchive verbosity pkg tmpDir targetPref = do-    createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)-    notice verbosity $ "Source tarball created: " ++ tarBallFilePath-  where-    tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip  as GZip+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Lazy    as BSL+import qualified Data.Set                as Set  -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory).-allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath-                         -> IO [FilePath]-allPackageSourceFiles verbosity setupOpts0 packageDir = do-  pkg <- do+--+-- Used in sandbox and projectbuilding.+-- TODO: when sandboxes are removed, move to ProjectBuilding.+--+allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]+allPackageSourceFiles verbosity packageDir = do+  pd <- do     let err = "Error reading source files of package."     desc <- tryFindAddSourcePackageDesc verbosity packageDir err     flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc-  globalTmp <- getTemporaryDirectory-  withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do-  let file      = tempDir </> "cabal-sdist-list-sources"-      flags     = defaultSDistFlags {-        sDistVerbosity   = Flag $ if verbosity == normal-                                  then lessVerbose verbosity else verbosity,-        sDistListSources = Flag file-        }-      setupOpts = setupOpts0 {-        -- 'sdist --list-sources' was introduced in Cabal 1.18.-        useCabalVersion = intersectVersionRanges-                            (orLaterVersion $ mkVersion [1,18,0])-                            (useCabalVersion setupOpts0),-        useWorkingDir = Just packageDir-        } -      doListSources :: IO [FilePath]-      doListSources = do-        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) (const [])-        fmap lines . readFile $ file+  listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers -      onFailedListSources :: IOException -> IO ()-      onFailedListSources e = do-        warn verbosity $-          "Could not list sources of the package '"-          ++ display (packageName pkg) ++ "'."-        warn verbosity $-          "Exception was: " ++ show e+-- | Create a tarball for a package in a directory+packageDirToSdist+    :: Verbosity+    -> GenericPackageDescription  -- ^ read in GPD+    -> FilePath                   -- ^ directory containing that GPD+    -> IO BSL.ByteString          -- ^ resulting sdist tarball+packageDirToSdist verbosity gpd dir = do+    files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers+    let files = nub $ sort $ map normalise files' -  -- Run setup sdist --list-sources=TMPFILE-  r <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])-  -- Ensure that we've closed the 'readFile' handle before we exit the-  -- temporary directory.-  _ <- evaluate (length r)-  return r+    let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()+        entriesM = do+            let prefix = prettyShow (packageId gpd)+            modify (Set.insert prefix)+            case Tar.toTarPath True prefix of+                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                Right path -> tell [Tar.directoryEntry path]++            for_ files $ \file -> do+                let fileDir = takeDirectory (prefix </> file)+                needsEntry <- gets (Set.notMember fileDir)++                when needsEntry $ do+                    modify (Set.insert fileDir)+                    case Tar.toTarPath True fileDir of+                        Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                        Right path -> tell [Tar.directoryEntry path]++                contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file+                case Tar.toTarPath False (prefix </> file) of+                    Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                    Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]++    entries <- execWriterT (evalStateT entriesM mempty)+    let -- Pretend our GZip file is made on Unix.+        normalize bs = BSL.concat [pfx, "\x03", rest']+            where+                (pfx, rest) = BSL.splitAt 9 bs+                rest' = BSL.tail rest+        -- The Unix epoch, which is the default value, is+        -- unsuitable because it causes unpacking problems on+        -- Windows; we need a post-1980 date. One gigasecond+        -- after the epoch is during 2001-09-09, so that does+        -- nicely. See #5596.+        setModTime entry = entry { Tar.entryTime = 1000000000 }+    return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
Distribution/Client/Store.hs view
@@ -33,11 +33,10 @@ import           Distribution.Simple.Utils                    ( withTempDirectory, debug, info ) import           Distribution.Verbosity-import           Distribution.Deprecated.Text+                   ( silent )  import qualified Data.Set as Set import           Control.Exception-import           Control.Monad (forM_) import           System.FilePath import           System.Directory @@ -203,7 +202,7 @@           then do             info verbosity $                 "Concurrent build race: abandoning build in favour of existing "-             ++ "store entry " ++ display compid </> display unitid+             ++ "store entry " ++ prettyShow compid </> prettyShow unitid             return UseExistingStoreEntry            -- If the entry does not exist then we won the race and can proceed.@@ -214,13 +213,13 @@              -- Atomically rename the temp dir to the final store entry location.             renameDirectory incomingEntryDir finalEntryDir-            forM_ otherFiles $ \file -> do+            for_ otherFiles $ \file -> do               let finalStoreFile = storeDirectory compid </> makeRelative (incomingTmpDir </> (dropDrive (storeDirectory compid))) file               createDirectoryIfMissing True (takeDirectory finalStoreFile)               renameFile file finalStoreFile              debug verbosity $-              "Installed store entry " ++ display compid </> display unitid+              "Installed store entry " ++ prettyShow compid </> prettyShow unitid             return UseNewStoreEntry   where     finalEntryDir = storePackageDirectory compid unitid@@ -249,7 +248,7 @@             gotLock <- fdTryLock fd ExclusiveLock             unless gotLock  $ do                 info verbosity $ "Waiting for file lock on store entry "-                              ++ display compid </> display unitid+                              ++ prettyShow compid </> prettyShow unitid                 fdLock fd ExclusiveLock             return fd @@ -269,7 +268,7 @@       gotlock <- hTryLock h ExclusiveLock       unless gotlock $ do         info verbosity $ "Waiting for file lock on store entry "-                      ++ display compid </> display unitid+                      ++ prettyShow compid </> prettyShow unitid         hLock h ExclusiveLock       return h
Distribution/Client/Tar.hs view
@@ -28,6 +28,9 @@   entriesToList,   ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import qualified Data.ByteString.Lazy    as BS import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar@@ -35,7 +38,8 @@ import qualified Codec.Compression.GZip  as GZip import qualified Distribution.Client.GZipUtils as GZipUtils -import Control.Exception (Exception(..), throw)+-- for foldEntries...+import Control.Exception (throw)  -- -- * High level operations
+ Distribution/Client/TargetProblem.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Client.TargetProblem (+    TargetProblem(..),+    TargetProblem',+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectPlanning    (AvailableTarget)+import Distribution.Client.TargetSelector     (SubComponentTarget, TargetSelector)+import Distribution.Package                   (PackageId, PackageName)+import Distribution.Simple.LocalBuildInfo     (ComponentName (..))+import Distribution.Types.UnqualComponentName (UnqualComponentName)++-- | Target problems that occur during project orchestration.+data TargetProblem a+    = TargetNotInProject                   PackageName+    | TargetAvailableInIndex               PackageName++    | TargetComponentNotProjectLocal+      PackageId ComponentName SubComponentTarget++    | TargetComponentNotBuildable+      PackageId ComponentName SubComponentTarget++    | TargetOptionalStanzaDisabledByUser+      PackageId ComponentName SubComponentTarget++    | TargetOptionalStanzaDisabledBySolver+      PackageId ComponentName SubComponentTarget++    | TargetProblemUnknownComponent+      PackageName (Either UnqualComponentName ComponentName)++    | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]+      -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable++    | TargetProblemNoTargets TargetSelector+      -- ^ There are no targets at all++    -- The target matching stuff only returns packages local to the project,+    -- so these lookups should never fail, but if 'resolveTargets' is called+    -- directly then of course it can.+    | TargetProblemNoSuchPackage           PackageId+    | TargetProblemNoSuchComponent         PackageId ComponentName++      -- | A custom target problem+    | CustomTargetProblem a+  deriving (Eq, Show, Functor)++-- | Type alias for a 'TargetProblem' with no user-defined problems/errors.+--+-- Can use the utilities below for reporting/rendering problems.+type TargetProblem' = TargetProblem Void
Distribution/Client/TargetSelector.hs view
@@ -49,7 +49,6 @@ import Distribution.Client.Types          ( PackageLocation(..), PackageSpecifier(..) ) -import Distribution.Verbosity import Distribution.PackageDescription          ( PackageDescription          , Executable(..)@@ -67,27 +66,19 @@          , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib -import Distribution.Deprecated.Text-         ( Text, display, simpleParse ) import Distribution.Simple.Utils          ( die', lowercase, ordNub ) import Distribution.Client.Utils          ( makeRelativeCanonical ) -import Data.Either-         ( partitionEithers )-import Data.Function-         ( on ) import Data.List-         ( stripPrefix, partition, groupBy )+         ( stripPrefix, groupBy ) import qualified Data.List.NonEmpty as NE-import Data.Ord-         ( comparing ) import qualified Data.Map.Lazy   as Map.Lazy import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Control.Arrow ((&&&))-import Control.Monad +import Control.Monad   hiding ( mfilter ) import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Deprecated.ReadP@@ -189,7 +180,8 @@      -- | A specific module within a component.    | ModuleTarget ModuleName -     -- | A specific file within a component.+     -- | A specific file within a component. Note that this does not carry the+     -- file extension.    | FileTarget   FilePath   deriving (Eq, Ord, Show, Generic) @@ -222,10 +214,10 @@                         -> Maybe ComponentKindFilter                         -> [String]                         -> m (Either [TargetSelectorProblem] [TargetSelector])-readTargetSelectorsWith dirActions@DirActions{..} pkgs mfilter targetStrs =+readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =     case parseTargetStrings targetStrs of       ([], usertargets) -> do-        usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets+        usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets         knowntargets <- getKnownTargets dirActions pkgs         case resolveTargetSelectors knowntargets usertargets' mfilter of           ([], btargets) -> return (Right btargets)@@ -437,7 +429,24 @@     TargetStringFileStatus7 s1   s2 s3 s4                                  s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 +getFileStatus :: TargetStringFileStatus -> Maybe FileStatus+getFileStatus (TargetStringFileStatus1 _ f)     = Just f+getFileStatus (TargetStringFileStatus2 _ f _)   = Just f+getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f+getFileStatus _                                 = Nothing +setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus+setFileStatus f (TargetStringFileStatus1 s1 _)       = TargetStringFileStatus1 s1 f+setFileStatus f (TargetStringFileStatus2 s1 _ s2)    = TargetStringFileStatus2 s1 f s2+setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3+setFileStatus _ t                                    = t++copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus+copyFileStatus src dst =+    case getFileStatus src of+      Just f -> setFileStatus f dst+      Nothing -> dst+ -- ------------------------------------------------------------ -- * Resolving target strings to target selectors -- ------------------------------------------------------------@@ -585,7 +594,12 @@    | TargetSelectorNoTargetsInProject   deriving (Show, Eq) -data QualLevel = QL1 | QL2 | QL3 | QLFull+-- | Qualification levels.+-- Given the filepath src/F, executable component A, and package foo:+data QualLevel = QL1    -- ^ @src/F@+               | QL2    -- ^ @foo:src/F | A:src/F@+               | QL3    -- ^ @foo:A:src/F | exe:A:src/F@+               | QLFull -- ^ @pkg:foo:exe:A:file:src/F@   deriving (Eq, Enum, Show)  disambiguateTargetSelectors@@ -602,12 +616,19 @@     -- So, here's the strategy. We take the original match results, and make a     -- table of all their renderings at all qualification levels.     -- Note there can be multiple renderings at each qualification level.++    -- Note that renderTargetSelector won't immediately work on any file syntax+    -- When rendering syntax, the FileStatus is always FileStatusNotExists,+    -- which will never match on syntaxForm1File!+    -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile.+    -- So we need to copy over the file status from the input+    -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus     matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]     matchResultsRenderings =       [ (matchResult, matchRenderings)       | matchResult <- matchResults       , let matchRenderings =-              [ rendering+              [ copyFileStatus matchInput rendering               | ql <- [QL1 .. QLFull]               , rendering <- renderTargetSelector ql matchResult ]       ]@@ -624,6 +645,8 @@            then Map.insert matchInput (Match Exact 0 matchResults)            else id)       $ Map.Lazy.fromList+        -- (matcher rendering) should *always* be a Match! Otherwise we will hit+        -- the internal error later on.           [ (rendering, matcher rendering)           | rendering <- concatMap snd matchResultsRenderings ] @@ -1037,7 +1060,7 @@     (pkgfile, ~KnownPackage{pinfoId, pinfoComponents})       -- always returns the KnownPackage case       <- matchPackageDirectoryPrefix ps fstatus1-    orNoThingIn "package" (display (packageName pinfoId)) $ do+    orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do       (filepath, c) <- matchComponentFile pinfoComponents pkgfile       return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))   where@@ -1135,7 +1158,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentName pinfoComponents str2           return (TargetComponent pinfoId (cinfoName c) WholeComponent)         --TODO: the error here ought to say there's no component by that name in@@ -1147,7 +1170,7 @@     render (TargetComponent p c WholeComponent) =       [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]     render (TargetComponentUnknown pn (Left cn) WholeComponent) =-      [TargetStringFileStatus2 (dispPN pn) noFileStatus (display cn)]+      [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)]     render _ = []  -- | Syntax: namespace : component@@ -1180,7 +1203,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ]           (m,c) <- matchModuleNameAnd ms str2           return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))@@ -1226,7 +1249,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           (filepath, c) <- matchComponentFile pinfoComponents str2           return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))       KnownPackageName pn ->@@ -1325,7 +1348,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentKindAndName pinfoComponents ckind str3           return (TargetComponent pinfoId (cinfoName c) WholeComponent)       KnownPackageName pn ->@@ -1353,7 +1376,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentName pinfoComponents str2           orNoThingIn "component" (cinfoStrName c) $ do             let ms = cinfoModules c@@ -1405,7 +1428,7 @@     p <- matchPackage ps str1 fstatus1     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentName pinfoComponents str2           orNoThingIn "component" (cinfoStrName c) $ do             (filepath, _) <- matchComponentFile [c] str3@@ -1496,7 +1519,7 @@     p <- matchPackage  ps str3 noFileStatus     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentKindAndName pinfoComponents ckind str5           return (TargetComponent pinfoId (cinfoName c) WholeComponent)       KnownPackageName pn ->@@ -1526,7 +1549,7 @@     p <- matchPackage  ps str3 noFileStatus     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentKindAndName pinfoComponents ckind str5           orNoThingIn "component" (cinfoStrName c) $ do             let ms = cinfoModules c@@ -1564,7 +1587,7 @@     p <- matchPackage  ps str3 noFileStatus     case p of       KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (display (packageName pinfoId)) $ do+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do           c <- matchComponentKindAndName pinfoComponents ckind str5           orNoThingIn "component" (cinfoStrName c) $ do             (filepath,_) <- matchComponentFile [c] str7@@ -1648,10 +1671,10 @@     match _ = mzero  dispP :: Package p => p -> String-dispP = display . packageName+dispP = prettyShow . packageName  dispPN :: PackageName -> String-dispPN = display+dispPN = prettyShow  dispC :: PackageId -> ComponentName -> String dispC = componentStringName . packageName@@ -1660,7 +1683,7 @@ dispC' = componentStringName  dispCN :: UnqualComponentName -> String-dispCN = display+dispCN = prettyShow  dispK :: ComponentKind -> String dispK = showComponentKindShort@@ -1672,7 +1695,7 @@ dispF = showComponentKindFilterShort  dispM :: ModuleName -> String-dispM = display+dispM = prettyShow   -------------------------------@@ -1727,7 +1750,7 @@                 -> [PackageSpecifier (SourcePackage (PackageLocation a))]                 -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do-    pinfo <- mapM (collectKnownPackageInfo dirActions) pkgs+    pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs     cwd   <- getCurrentDirectory     let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo     return KnownTargets {@@ -1758,8 +1781,8 @@     return (KnownPackageName pkgname) collectKnownPackageInfo dirActions@DirActions{..}                   (SpecificSourcePackage SourcePackage {-                    packageDescription = pkg,-                    packageSource      = loc+                    srcpkgDescription = pkg,+                    srcpkgSource      = loc                   }) = do     (pkgdir, pkgfile) <-       case loc of@@ -1768,8 +1791,8 @@           dirabs <- canonicalizePath dir           dirrel <- makeRelativeToCwd dirActions dirabs           --TODO: ought to get this earlier in project reading-          let fileabs = dirabs </> display (packageName pkg) <.> "cabal"-              filerel = dirrel </> display (packageName pkg) <.> "cabal"+          let fileabs = dirabs </> prettyShow (packageName pkg) <.> "cabal"+              filerel = dirrel </> prettyShow (packageName pkg) <.> "cabal"           exists <- doesFileExist fileabs           return ( Just (dirabs, dirrel)                  , if exists then Just (fileabs, filerel) else Nothing@@ -1803,7 +1826,7 @@   componentStringName :: PackageName -> ComponentName -> ComponentStringName-componentStringName pkgname (CLibName LMainLibName) = display pkgname+componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name componentStringName _ (CFLibName name)  = unUnqualComponentName name componentStringName _ (CExeName   name) = unUnqualComponentName name@@ -1975,9 +1998,9 @@ matchPackageName ps = \str -> do     guard (validPackageName str)     orNoSuchThing "package" str-                  (map (display . knownPackageName) ps) $+                  (map (prettyShow . knownPackageName) ps) $       increaseConfidenceFor $-        matchInexactly caseFold (display . knownPackageName) ps str+        matchInexactly caseFold (prettyShow . knownPackageName) ps str   matchPackageNameUnknown :: String -> Match KnownPackage@@ -2060,7 +2083,7 @@  guardModuleName :: String -> Match () guardModuleName s =-  case simpleParse s :: Maybe ModuleName of+  case simpleParsec s :: Maybe ModuleName of     Just _                   -> increaseConfidence     _ | all validModuleChar s         && not (null s)      -> return ()@@ -2071,16 +2094,16 @@  matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str =-    orNoSuchThing "module" str (map display ms)+    orNoSuchThing "module" str (map prettyShow ms)   $ increaseConfidenceFor-  $ matchInexactly caseFold display ms str+  $ matchInexactly caseFold prettyShow ms str   matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) matchModuleNameAnd ms str =-    orNoSuchThing "module" str (map (display . fst) ms)+    orNoSuchThing "module" str (map (prettyShow . fst) ms)   $ increaseConfidenceFor-  $ matchInexactly caseFold (display . fst) ms str+  $ matchInexactly caseFold (prettyShow . fst) ms str   matchModuleNameUnknown :: String -> Match ModuleName@@ -2117,12 +2140,14 @@                         -> Match (FilePath, KnownComponent) matchComponentOtherFile cs =     matchFile-      [ (file, c)-      | c    <- cs-      , file <- cinfoHsFiles c-             ++ cinfoCFiles  c-             ++ cinfoJsFiles c+      [ (normalise (srcdir </> file), c)+      | c      <- cs+      , srcdir <- cinfoSrcDirs c+      , file   <- cinfoHsFiles c+               ++ cinfoCFiles  c+               ++ cinfoJsFiles c       ]+      . normalise   matchComponentModuleFile :: [KnownComponent] -> String@@ -2134,7 +2159,8 @@       , d <- cinfoSrcDirs c       , m <- cinfoModules c       ]-      (dropExtension (normalise str))+      (dropExtension (normalise str)) -- Drop the extension because FileTarget+                                      -- is stored without the extension  -- utils @@ -2370,8 +2396,8 @@     -- the map of canonicalised keys to groups of inexact matches     m' = Map.mapKeysWith (++) cannonicalise m -matchParse :: Text a => String -> Match a-matchParse = maybe mzero return . simpleParse+matchParse :: Parsec a => String -> Match a+matchParse = maybe mzero return . simpleParsec   ------------------------------
Distribution/Client/Targets.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} @@ -50,13 +50,10 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Deprecated.ParseUtils (parseFlagAssignment)- import Distribution.Package          ( Package(..), PackageName, unPackageName, mkPackageName-         , PackageIdentifier(..), packageName, packageVersion )+         , packageName ) import Distribution.Types.Dependency-import Distribution.Types.LibraryName import Distribution.Client.Types          ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage          , PackageSpecifier(..) )@@ -76,33 +73,25 @@ import Distribution.Client.Utils ( tryFindPackageDesc ) import Distribution.Client.GlobalFlags          ( RepoContext(..) )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint (..) )  import Distribution.PackageDescription-         ( GenericPackageDescription, nullFlagAssignment)+         ( GenericPackageDescription )+import Distribution.Types.Flag+         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty ) import Distribution.Version-         ( nullVersion, thisVersion, anyVersion, isAnyVersion )-import Distribution.Deprecated.Text-         ( Text(..), display )-import Distribution.Verbosity (Verbosity)+         ( anyVersion, isAnyVersion ) import Distribution.Simple.Utils          ( die', warn, lowercase )  import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) --- import Data.List ( find, nub )-import Data.Either-         ( partitionEithers ) import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils-import Control.Monad (mapM)-import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Deprecated.ReadP-         ( (+++), (<++) )-import Distribution.Deprecated.ParseUtils-         ( readPToMaybe )+import qualified Distribution.Compat.CharParsing as P import System.FilePath          ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory@@ -125,7 +114,7 @@      -- > cabal install foo-1.0      -- > cabal install 'foo < 2'      ---     UserTargetNamed Dependency+     UserTargetNamed PackageVersionConstraint       -- | A special virtual package that refers to the collection of packages      -- recorded in the world file that the user specifically installed.@@ -174,7 +163,7 @@ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] readUserTargets verbosity targetStrs = do     (problems, targets) <- liftM partitionEithers-                                 (mapM readUserTarget targetStrs)+                                 (traverse readUserTarget targetStrs)     reportUserTargetProblems verbosity problems     return targets @@ -190,14 +179,14 @@  readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr =-    case testNamedTargets targetstr of-      Just (Dependency pkgn verrange _)+    case eitherParsec targetstr of+      Right (PackageVersionConstraint pkgn verrange)         | pkgn == mkPackageName "world"           -> return $ if verrange == anyVersion                       then Right UserTargetWorld                       else Left  UserTargetBadWorldPkg-      Just dep -> return (Right (UserTargetNamed dep))-      Nothing -> do+      Right dep -> return (Right (UserTargetNamed dep))+      Left _err -> do         fileTarget <- testFileTargets targetstr         case fileTarget of           Just target -> return target@@ -206,8 +195,6 @@               Just target -> return target               Nothing     -> return (Left (UserTargetUnrecognised targetstr))   where-    testNamedTargets = readPToMaybe parseDependencyOrPackageId-     testFileTargets filename = do       isDir  <- doesDirectoryExist filename       isFile <- doesFileExist filename@@ -253,16 +240,6 @@     extensionIsTarGz f = takeExtension f                 == ".gz"                       && takeExtension (dropExtension f) == ".tar" -    parseDependencyOrPackageId :: Parse.ReadP r Dependency-    parseDependencyOrPackageId = parse-                             +++ liftM pkgidToDependency parse-      where-        pkgidToDependency :: PackageIdentifier -> Dependency-        pkgidToDependency p = case packageVersion p of-          v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName)-            | otherwise        -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName)-- reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () reportUserTargetProblems verbosity problems = do     case [ target | UserTargetUnrecognised target <- problems ] of@@ -332,9 +309,9 @@      -- given the user targets, get a list of fully or partially resolved     -- package references-    packageTargets <- mapM (readPackageTarget verbosity)-                  =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat-                  =<< mapM (expandUserTarget verbosity worldFile) userTargets+    packageTargets <- traverse (readPackageTarget verbosity)+                  =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat+                  =<< traverse (expandUserTarget verbosity worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must     -- disambiguate named package references@@ -380,7 +357,7 @@                  -> IO [PackageTarget (PackageLocation ())] expandUserTarget verbosity worldFile userTarget = case userTarget of -    UserTargetNamed (Dependency name vrange _cs) ->+    UserTargetNamed (PackageVersionConstraint name vrange) ->       let props = [ PackagePropertyVersion vrange                   | not (isAnyVersion vrange) ]       in  return [PackageTargetNamedFuzzy name props userTarget]@@ -442,12 +419,12 @@       LocalUnpackedPackage dir -> do         pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=                  readGenericPackageDescription verbosity-        return $ SourcePackage {-                   packageInfoId        = packageId pkg,-                   packageDescription   = pkg,-                   packageSource        = fmap Just location,-                   packageDescrOverride = Nothing-                 }+        return SourcePackage+          { srcpkgPackageId     = packageId pkg+          , srcpkgDescription   = pkg+          , srcpkgSource        = fmap Just location+          , srcpkgDescrOverride = Nothing+          }        LocalTarballPackage tarballFile ->         readTarballPackageTarget location tarballFile tarballFile@@ -474,12 +451,12 @@         Nothing  -> die' verbosity $ "Could not parse the cabal file "                        ++ filename ++ " in " ++ tarballFile         Just pkg ->-          return $ SourcePackage {-                     packageInfoId        = packageId pkg,-                     packageDescription   = pkg,-                     packageSource        = fmap Just location,-                     packageDescrOverride = Nothing-                   }+          return SourcePackage+            { srcpkgPackageId     = packageId pkg+            , srcpkgDescription   = pkg+            , srcpkgSource        = fmap Just location+            , srcpkgDescrOverride = Nothing+            }      extractTarballPackageCabalFile :: FilePath -> String                                    -> IO (FilePath, BS.ByteString)@@ -515,7 +492,7 @@           _                 -> False      parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription-    parsePackageDescription' bs = +    parsePackageDescription' bs =         parseGenericPackageDescriptionMaybe (BS.toStrict bs)  -- ------------------------------------------------------------@@ -571,7 +548,7 @@                , not (isUserTagetWorld originalTarget) ] of       []    -> return ()       pkgs  -> die' verbosity $ unlines-                       [ "There is no package named '" ++ display name ++ "'. "+                       [ "There is no package named '" ++ prettyShow name ++ "'. "                        | name <- pkgs ]                   ++ "You may need to run 'cabal update' to get the latest "                   ++ "list of available packages."@@ -579,11 +556,11 @@     case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of       []          -> return ()       ambiguities -> die' verbosity $ unlines-                         [    "There is no package named '" ++ display name ++ "'. "+                         [    "There is no package named '" ++ prettyShow name ++ "'. "                            ++ (if length matches > 1                                then "However, the following package names exist: "                                else "However, the following package name exists: ")-                           ++ intercalate ", " [ "'" ++ display m ++ "'" | m <- matches]+                           ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches]                            ++ "."                          | (name, matches) <- ambiguities ] @@ -592,7 +569,7 @@       pkgs -> warn verbosity $                  "The following 'world' packages will be ignored because "               ++ "they refer to packages that cannot be found: "-              ++ intercalate ", " (map display pkgs) ++ "\n"+              ++ intercalate ", " (map prettyShow pkgs) ++ "\n"               ++ "You can suppress this warning by correcting the world file."   where     isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False@@ -703,7 +680,7 @@ data UserConstraint =     UserConstraint UserConstraintScope PackageProperty   deriving (Eq, Show, Generic)-           + instance Binary UserConstraint instance Structured UserConstraint @@ -720,69 +697,50 @@  readUserConstraint :: String -> Either String UserConstraint readUserConstraint str =-    case readPToMaybe parse str of-      Nothing -> Left msgCannotParse-      Just c  -> Right c+    case explicitEitherParsec parsec str of+      Left err -> Left $ msgCannotParse ++ err+      Right c  -> Right c   where     msgCannotParse =          "expected a (possibly qualified) package name followed by a " ++          "constraint, which is either a version range, 'installed', " ++-         "'source', 'test', 'bench', or flags"+         "'source', 'test', 'bench', or flags. " -instance Text UserConstraint where-  disp (UserConstraint scope prop) =+instance Pretty UserConstraint where+  pretty (UserConstraint scope prop) =     dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop-  -  parse =-    let parseConstraintScope :: Parse.ReadP a UserConstraintScope-        parseConstraintScope =-          do-             _ <- Parse.string "any."-             pn <- parse-             return (UserAnyQualifier pn)-          +++-          do-             _ <- Parse.string "setup."-             pn <- parse-             return (UserAnySetupQualifier pn)-          +++-          do-             -- Qualified name-             pn <- parse-             (return (UserQualified UserQualToplevel pn)-              +++-              do _ <- Parse.string ":setup."-                 pn2 <- parse-                 return (UserQualified (UserQualSetup pn) pn2)) -              -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax.-              ---              -- +++-              -- do _ <- Parse.string ":"-              --    pn2 <- parse-              --    _ <- Parse.string ":exe."-              --    pn3 <- parse-              --    return (UserQualExe pn pn2, pn3)-    in do-      scope <- parseConstraintScope-                       -      -- Package property-      let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x-      prop <- ((parse >>= return . PackagePropertyVersion)-               +++-               keyword "installed" PackagePropertyInstalled-               +++-               keyword "source" PackagePropertySource-               +++-               keyword "test" (PackagePropertyStanzas [TestStanzas])-               +++-               keyword "bench" (PackagePropertyStanzas [BenchStanzas]))-              -- Note: the parser is left-biased here so that we-              -- don't get an ambiguous parse from 'installed',-              -- 'source', etc. being regarded as flags.-              <++-                (Parse.skipSpaces1 >> parseFlagAssignment-               >>= return . PackagePropertyFlags)-    -      -- Result-      return (UserConstraint scope prop)+instance Parsec UserConstraint where+    parsec = do+        scope <- parseConstraintScope+        P.spaces+        prop <- P.choice+            [ PackagePropertyFlags                  <$> parsecFlagAssignmentNonEmpty -- headed by "+-"+            , PackagePropertyVersion                <$> parsec                       -- headed by "<=>" (will be)+            , PackagePropertyInstalled              <$ P.string "installed"+            , PackagePropertySource                 <$ P.string "source"+            , PackagePropertyStanzas [TestStanzas]  <$ P.string "test"+            , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"+            ]+        return (UserConstraint scope prop)++      where+        parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope+        parseConstraintScope = do+            pn <- parsec+            P.choice+                [ P.char '.' *> withDot pn+                , P.char ':' *> withColon pn+                , return (UserQualified UserQualToplevel pn)+                ]+          where+            withDot :: PackageName -> m UserConstraintScope+            withDot pn+                | pn == mkPackageName "any"   = UserAnyQualifier <$> parsec+                | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec+                | otherwise                   = P.unexpected $ "constraint scope: " ++ unPackageName pn++            withColon :: PackageName -> m UserConstraintScope+            withColon pn = UserQualified (UserQualSetup pn)+                <$  P.string "setup."+                <*> parsec
Distribution/Client/Types.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -17,634 +17,29 @@ -- -- Various common data types for the entire cabal-install system ------------------------------------------------------------------------------module Distribution.Client.Types where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Package-         ( Package(..), HasMungedPackageId(..), HasUnitId(..)-         , PackageIdentifier(..), packageVersion, packageName-         , PackageInstalled(..), newSimpleUnitId )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, installedComponentId, sourceComponentName )-import Distribution.PackageDescription-         ( FlagAssignment )-import Distribution.Version-         ( VersionRange, nullVersion, thisVersion )-import Distribution.Types.ComponentId-         ( ComponentId )-import Distribution.Types.MungedPackageId-         ( computeCompatPackageId )-import Distribution.Types.PackageId-         ( PackageId )-import Distribution.Types.AnnotatedId-import Distribution.Types.UnitId-         ( UnitId )-import Distribution.Types.PackageName-         ( PackageName, mkPackageName )-import Distribution.Types.ComponentName-         ( ComponentName(..) )-import Distribution.Types.LibraryName-         ( LibraryName(..) )-import Distribution.Client.SourceRepo-         ( SourceRepoMaybe )-import Distribution.Client.HashValue (showHashValue, hashValue, truncateHash)--import Distribution.Solver.Types.PackageIndex-         ( PackageIndex )-import qualified Distribution.Solver.Types.ComponentDeps as CD-import Distribution.Solver.Types.ComponentDeps-         ( ComponentDeps )-import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackageFixedDeps-import Distribution.Solver.Types.SourcePackage-import Distribution.Compat.Graph (IsNode(..))-import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Deprecated.ParseUtils (parseOptCommaList)-import Distribution.Simple.Utils (ordNub, toUTF8BS)-import Distribution.Deprecated.Text (Text(..))--import Network.URI (URI(..), nullURI)-import Control.Exception (Exception, SomeException)--import qualified Text.PrettyPrint as Disp-import qualified Data.ByteString.Lazy.Char8 as LBS---newtype Username = Username { unUsername :: String }-newtype Password = Password { unPassword :: String }---- | This is the information we get from a @00-index.tar.gz@ hackage index.----data SourcePackageDb = SourcePackageDb {-  packageIndex       :: PackageIndex UnresolvedSourcePackage,-  packagePreferences :: Map PackageName VersionRange-}-  deriving (Eq, Generic)--instance Binary SourcePackageDb---- --------------------------------------------------------------- * Various kinds of information about packages--- ---------------------------------------------------------------- | Within Cabal the library we no longer have a @InstalledPackageId@ type.--- That's because it deals with the compilers' notion of a registered library,--- and those really are libraries not packages. Those are now named units.------ The package management layer does however deal with installed packages, as--- whole packages not just as libraries. So we do still need a type for--- installed package ids. At the moment however we track instaled packages via--- their primary library, which is a unit id. In future this may change--- slightly and we may distinguish these two types and have an explicit--- conversion when we register units with the compiler.----type InstalledPackageId = ComponentId----- | A 'ConfiguredPackage' is a not-yet-installed package along with the--- total configuration information. The configuration information is total in--- the sense that it provides all the configuration information and so the--- final configure process will be independent of the environment.------ 'ConfiguredPackage' is assumed to not support Backpack.  Only the--- @v2-build@ codepath supports Backpack.----data ConfiguredPackage loc = ConfiguredPackage {-       confPkgId :: InstalledPackageId,-       confPkgSource :: SourcePackage loc, -- package info, including repo-       confPkgFlags :: FlagAssignment,     -- complete flag assignment for the package-       confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package-       confPkgDeps :: ComponentDeps [ConfiguredId]-                               -- set of exact dependencies (installed or source).-                               -- These must be consistent with the 'buildDepends'-                               -- in the 'PackageDescription' that you'd get by-                               -- applying the flag assignment and optional stanzas.-    }-  deriving (Eq, Show, Generic)---- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.--- This type class is mostly used to conveniently finesse between--- 'ElaboratedPackage' and 'ElaboratedComponent'.----instance HasConfiguredId (ConfiguredPackage loc) where-    configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)---- 'ConfiguredPackage' is the legacy codepath, we are guaranteed--- to never have a nontrivial 'UnitId'-instance PackageFixedDeps (ConfiguredPackage loc) where-    depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps--instance IsNode (ConfiguredPackage loc) where-    type Key (ConfiguredPackage loc) = UnitId-    nodeKey       = newSimpleUnitId . confPkgId-    -- TODO: if we update ConfiguredPackage to support order-only-    -- dependencies, need to include those here.-    -- NB: have to deduplicate, otherwise the planner gets confused-    nodeNeighbors = ordNub . CD.flatDeps . depends--instance (Binary loc) => Binary (ConfiguredPackage loc)----- | A ConfiguredId is a package ID for a configured package.------ Once we configure a source package we know its UnitId. It is still--- however useful in lots of places to also know the source ID for the package.--- We therefore bundle the two.------ An already installed package of course is also "configured" (all its--- configuration parameters and dependencies have been specified).-data ConfiguredId = ConfiguredId {-    confSrcId  :: PackageId-  , confCompName :: Maybe ComponentName-  , confInstId :: ComponentId-  }-  deriving (Eq, Ord, Generic)--annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId-annotatedIdToConfiguredId aid = ConfiguredId {-        confSrcId    = ann_pid aid,-        confCompName = Just (ann_cname aid),-        confInstId   = ann_id aid-    }--instance Binary ConfiguredId-instance Structured ConfiguredId--instance Show ConfiguredId where-  show cid = show (confInstId cid)--instance Package ConfiguredId where-  packageId = confSrcId--instance Package (ConfiguredPackage loc) where-  packageId cpkg = packageId (confPkgSource cpkg)--instance HasMungedPackageId (ConfiguredPackage loc) where-  mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName---- Never has nontrivial UnitId-instance HasUnitId (ConfiguredPackage loc) where-  installedUnitId = newSimpleUnitId . confPkgId--instance PackageInstalled (ConfiguredPackage loc) where-  installedDepends = CD.flatDeps . depends--class HasConfiguredId a where-    configuredId :: a -> ConfiguredId---- NB: This instance is slightly dangerous, in that you'll lose--- information about the specific UnitId you depended on.-instance HasConfiguredId InstalledPackageInfo where-    configuredId ipkg = ConfiguredId (packageId ipkg)-                            (Just (sourceComponentName ipkg))-                            (installedComponentId ipkg)---- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be--- installed already, hence itself ready to be installed.-newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.-  deriving (Eq, Show, Generic, Package, PackageFixedDeps,-            HasMungedPackageId, HasUnitId, PackageInstalled, Binary)---- Can't newtype derive this-instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where-    type Key (GenericReadyPackage srcpkg) = Key srcpkg-    nodeKey (ReadyPackage spkg) = nodeKey spkg-    nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg--type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)---- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.-type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc----- --------------------------------------------------------------- * Package specifier--- ---------------------------------------------------------------- | A fully or partially resolved reference to a package.----data PackageSpecifier pkg =--     -- | A partially specified reference to a package (either source or-     -- installed). It is specified by package name and optionally some-     -- required properties. Use a dependency resolver to pick a specific-     -- package satisfying these properties.-     ---     NamedPackage PackageName [PackageProperty]--     -- | A fully specified source package.-     ---   | SpecificSourcePackage pkg-  deriving (Eq, Show, Functor, Generic)--instance Binary pkg => Binary (PackageSpecifier pkg)-instance Structured pkg => Structured (PackageSpecifier pkg)--pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName-pkgSpecifierTarget (NamedPackage name _)       = name-pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg--pkgSpecifierConstraints :: Package pkg-                        => PackageSpecifier pkg -> [LabeledPackageConstraint]-pkgSpecifierConstraints (NamedPackage name props) = map toLpc props-  where-    toLpc prop = LabeledPackageConstraint-                 (PackageConstraint (scopeToplevel name) prop)-                 ConstraintSourceUserTarget-pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-    [LabeledPackageConstraint pc ConstraintSourceUserTarget]-  where-    pc = PackageConstraint-         (ScopeTarget $ packageName pkg)-         (PackagePropertyVersion $ thisVersion (packageVersion pkg))+module Distribution.Client.Types (+    module Distribution.Client.Types.AllowNewer,+    module Distribution.Client.Types.ConfiguredId,+    module Distribution.Client.Types.ConfiguredPackage,+    module Distribution.Client.Types.BuildResults,+    module Distribution.Client.Types.PackageLocation,+    module Distribution.Client.Types.PackageSpecifier,+    module Distribution.Client.Types.ReadyPackage,+    module Distribution.Client.Types.Repo,+    module Distribution.Client.Types.RepoName,+    module Distribution.Client.Types.SourcePackageDb,+    module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy,+) where  --- --------------------------------------------------------------- * Package locations and repositories--- --------------------------------------------------------------type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)--type ResolvedPkgLoc = PackageLocation FilePath--data PackageLocation local =--    -- | An unpacked package in the given dir, or current dir-    LocalUnpackedPackage FilePath--    -- | A package as a tarball that's available as a local tarball-  | LocalTarballPackage FilePath--    -- | A package as a tarball from a remote URI-  | RemoteTarballPackage URI local--    -- | A package available as a tarball from a repository.-    ---    -- It may be from a local repository or from a remote repository, with a-    -- locally cached copy. ie a package available from hackage-  | RepoTarballPackage Repo PackageId local--    -- | A package available from a version control system source repository-  | RemoteSourceRepoPackage SourceRepoMaybe local-  deriving (Show, Functor, Eq, Ord, Generic, Typeable)--instance Binary local => Binary (PackageLocation local)-instance Structured local => Structured (PackageLocation local)--data RemoteRepo =-    RemoteRepo {-      remoteRepoName     :: String,-      remoteRepoURI      :: URI,--      -- | Enable secure access?-      ---      -- 'Nothing' here represents "whatever the default is"; this is important-      -- to allow for a smooth transition from opt-in to opt-out security-      -- (once we switch to opt-out, all access to the central Hackage-      -- repository should be secure by default)-      remoteRepoSecure :: Maybe Bool,--      -- | Root key IDs (for bootstrapping)-      remoteRepoRootKeys :: [String],--      -- | Threshold for verification during bootstrapping-      remoteRepoKeyThreshold :: Int,--      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a-      -- special case we may know a repo supports both and want to try HTTPS-      -- if we can, but still allow falling back to HTTP.-      ---      -- This field is not currently stored in the config file, but is filled-      -- in automagically for known repos.-      remoteRepoShouldTryHttps :: Bool-    }--  deriving (Show, Eq, Ord, Generic)--instance Binary RemoteRepo-instance Structured RemoteRepo---- | Construct a partial 'RemoteRepo' value to fold the field parser list over.-emptyRemoteRepo :: String -> RemoteRepo-emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False---- | /no-index/ style local repositories.------ https://github.com/haskell/cabal/issues/6359-data LocalRepo = LocalRepo-    { localRepoName        :: String-    , localRepoPath        :: FilePath-    , localRepoSharedCache :: Bool-    }-  deriving (Show, Eq, Ord, Generic)--instance Binary LocalRepo-instance Structured LocalRepo---- | Construct a partial 'LocalRepo' value to fold the field parser list over.-emptyLocalRepo :: String -> LocalRepo-emptyLocalRepo name = LocalRepo name "" False---- | Calculate a cache key for local-repo.------ For remote repositories we just use name, but local repositories may--- all be named "local", so we add a bit of `localRepoPath` into the--- mix.-localRepoCacheKey :: LocalRepo -> String-localRepoCacheKey local = localRepoName local ++ "-" ++ hashPart where-    hashPart-        = showHashValue $ truncateHash 8 $ hashValue-        $ LBS.fromStrict $ toUTF8BS $ localRepoPath local---- | Different kinds of repositories------ NOTE: It is important that this type remains serializable.-data Repo =-    -- | Local repositories-    RepoLocal {-        repoLocalDir :: FilePath-      }-  -    -- | Local repository, without index.-    ---    -- https://github.com/haskell/cabal/issues/6359-  | RepoLocalNoIndex-      { repoLocal    :: LocalRepo-      , repoLocalDir :: FilePath-      }--    -- | Standard (unsecured) remote repositores-  | RepoRemote {-        repoRemote   :: RemoteRepo-      , repoLocalDir :: FilePath-      }--    -- | Secure repositories-    ---    -- Although this contains the same fields as 'RepoRemote', we use a separate-    -- constructor to avoid confusing the two.-    ---    -- Not all access to a secure repo goes through the hackage-security-    -- library currently; code paths that do not still make use of the-    -- 'repoRemote' and 'repoLocalDir' fields directly.-  | RepoSecure {-        repoRemote   :: RemoteRepo-      , repoLocalDir :: FilePath-      }-  deriving (Show, Eq, Ord, Generic)--instance Binary Repo-instance Structured Repo---- | Check if this is a remote repo-isRepoRemote :: Repo -> Bool-isRepoRemote RepoLocal{}        = False-isRepoRemote RepoLocalNoIndex{} = False-isRepoRemote _                  = True---- | Extract @RemoteRepo@ from @Repo@ if remote.-maybeRepoRemote :: Repo -> Maybe RemoteRepo-maybeRepoRemote (RepoLocal          _localDir) = Nothing-maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing-maybeRepoRemote (RepoRemote       r _localDir) = Just r-maybeRepoRemote (RepoSecure       r _localDir) = Just r---- --------------------------------------------------------------- * Build results--- ---------------------------------------------------------------- | A summary of the outcome for building a single package.----type BuildOutcome = Either BuildFailure BuildResult---- | A summary of the outcome for building a whole set of packages.----type BuildOutcomes = Map UnitId BuildOutcome--data BuildFailure = PlanningFailed-                  | DependentFailed PackageId-                  | DownloadFailed  SomeException-                  | UnpackFailed    SomeException-                  | ConfigureFailed SomeException-                  | BuildFailed     SomeException-                  | TestsFailed     SomeException-                  | InstallFailed   SomeException-  deriving (Show, Typeable, Generic)--instance Exception BuildFailure---- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only--- the public library's 'InstalledPackageInfo' is stored here, even if--- there were 'InstalledPackageInfo' from internal libraries.  This--- 'InstalledPackageInfo' is not used anyway, so it makes no difference.-data BuildResult = BuildResult DocsResult TestsResult-                               (Maybe InstalledPackageInfo)-  deriving (Show, Generic)--data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-  deriving (Show, Generic, Typeable)-data TestsResult = TestsNotTried | TestsOk-  deriving (Show, Generic, Typeable)--instance Binary BuildFailure-instance Binary BuildResult-instance Binary DocsResult-instance Binary TestsResult--instance Structured BuildFailure-instance Structured BuildResult-instance Structured DocsResult-instance Structured TestsResult---- --------------------------------------------------------------- * --allow-newer/--allow-older--- ---------------------------------------------------------------- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,--- it may make sense to move these definitions to the Solver.Types--- module---- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)-newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }-                   deriving (Eq, Read, Show, Generic)---- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)-newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }-                   deriving (Eq, Read, Show, Generic)---- | Generic data type for policy when relaxing bounds in dependencies.--- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending--- on whether or not you are relaxing an lower or upper bound--- (respectively).-data RelaxDeps =--  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.-  ---  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all-  -- dependencies, never choose versions newer (resp. older) than allowed.-    RelaxDepsSome [RelaxedDep]--  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.-  ---  -- __Note__: This is should be semantically equivalent to-  ---  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]-  ---  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')-  | RelaxDepsAll-  deriving (Eq, Read, Show, Generic)---- | Dependencies can be relaxed either for all packages in the install plan, or--- only for some packages.-data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject-                deriving (Eq, Read, Show, Generic)---- | Specify the scope of a relaxation, i.e. limit which depending--- packages are allowed to have their version constraints relaxed.-data RelaxDepScope = RelaxDepScopeAll-                     -- ^ Apply relaxation in any package-                   | RelaxDepScopePackage !PackageName-                     -- ^ Apply relaxation to in all versions of a package-                   | RelaxDepScopePackageId !PackageId-                     -- ^ Apply relaxation to a specific version of a package only-                   deriving (Eq, Read, Show, Generic)---- | Modifier for dependency relaxation-data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics-                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints-                 deriving (Eq, Read, Show, Generic)---- | Express whether to relax bounds /on/ @all@ packages, or a single package-data RelaxDepSubject = RelaxDepSubjectAll-                     | RelaxDepSubjectPkg !PackageName-                     deriving (Eq, Ord, Read, Show, Generic)--instance Text RelaxedDep where-  disp (RelaxedDep scope rdmod subj) = case scope of-      RelaxDepScopeAll          -> Disp.text "all:"           Disp.<> modDep-      RelaxDepScopePackage   p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep-      RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep-    where-      modDep = case rdmod of-               RelaxDepModNone  -> disp subj-               RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj--  parse = RelaxedDep <$> scopeP <*> modP <*> parse-    where-      -- "greedy" choices-      scopeP =           (pure RelaxDepScopeAll  <* Parse.char '*' <* Parse.char ':')-               Parse.<++ (pure RelaxDepScopeAll  <* Parse.string "all:")-               Parse.<++ (RelaxDepScopePackageId <$> pidP  <* Parse.char ':')-               Parse.<++ (RelaxDepScopePackage   <$> parse <* Parse.char ':')-               Parse.<++ (pure RelaxDepScopeAll)--      modP =           (pure RelaxDepModCaret <* Parse.char '^')-             Parse.<++ (pure RelaxDepModNone)--      -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser-      pidP = do-          p0 <- parse-          when (pkgVersion p0 == nullVersion) Parse.pfail-          pure p0--instance Text RelaxDepSubject where-  disp RelaxDepSubjectAll      = Disp.text "all"-  disp (RelaxDepSubjectPkg pn) = disp pn--  parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn-    where-      pkgn = do-          pn <- parse-          pure (if (pn == mkPackageName "all")-                then RelaxDepSubjectAll-                else RelaxDepSubjectPkg pn)--instance Text RelaxDeps where-  disp rd | not (isRelaxDeps rd) = Disp.text "none"-  disp (RelaxDepsSome pkgs)      = Disp.fsep .-                                   Disp.punctuate Disp.comma .-                                   map disp $ pkgs-  disp RelaxDepsAll              = Disp.text "all"--  parse =           (const mempty        <$> ((Parse.string "none" Parse.+++-                                               Parse.string "None") <* Parse.eof))-          Parse.<++ (const RelaxDepsAll  <$> ((Parse.string "all"  Parse.+++-                                               Parse.string "All"  Parse.+++-                                               Parse.string "*")  <* Parse.eof))-          Parse.<++ (      RelaxDepsSome <$> parseOptCommaList parse)--instance Binary RelaxDeps-instance Binary RelaxDepMod-instance Binary RelaxDepScope-instance Binary RelaxDepSubject-instance Binary RelaxedDep-instance Binary AllowNewer-instance Binary AllowOlder--instance Structured RelaxDeps-instance Structured RelaxDepMod-instance Structured RelaxDepScope-instance Structured RelaxDepSubject-instance Structured RelaxedDep-instance Structured AllowNewer-instance Structured AllowOlder---- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations------ Equivalent to @isRelaxDeps = (/= 'mempty')@-isRelaxDeps :: RelaxDeps -> Bool-isRelaxDeps (RelaxDepsSome [])    = False-isRelaxDeps (RelaxDepsSome (_:_)) = True-isRelaxDeps RelaxDepsAll          = True---- | 'RelaxDepsAll' is the /absorbing element/-instance Semigroup RelaxDeps where-  -- identity element-  RelaxDepsSome []    <> r                   = r-  l@(RelaxDepsSome _) <> RelaxDepsSome []    = l-  -- absorbing element-  l@RelaxDepsAll      <> _                   = l-  (RelaxDepsSome   _) <> r@RelaxDepsAll      = r-  -- combining non-{identity,absorbing} elements-  (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)---- | @'RelaxDepsSome' []@ is the /identity element/-instance Monoid RelaxDeps where-  mempty  = RelaxDepsSome []-  mappend = (<>)--instance Semigroup AllowNewer where-  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)--instance Semigroup AllowOlder where-  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)--instance Monoid AllowNewer where-  mempty  = AllowNewer mempty-  mappend = (<>)--instance Monoid AllowOlder where-  mempty  = AllowOlder mempty-  mappend = (<>)---- --------------------------------------------------------------- * --write-ghc-environment-file--- ---------------------------------------------------------------- | Whether 'v2-build' should write a .ghc.environment file after--- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+'--- (8.4.4 is the earliest version that supports--- '-package-env -').-data WriteGhcEnvironmentFilesPolicy-  = AlwaysWriteGhcEnvironmentFiles-  | NeverWriteGhcEnvironmentFiles-  | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer-  deriving (Eq, Enum, Bounded, Generic, Show)--instance Binary WriteGhcEnvironmentFilesPolicy-instance Structured WriteGhcEnvironmentFilesPolicy+import Distribution.Client.Types.AllowNewer+import Distribution.Client.Types.BuildResults+import Distribution.Client.Types.ConfiguredId+import Distribution.Client.Types.ConfiguredPackage+import Distribution.Client.Types.PackageLocation+import Distribution.Client.Types.PackageSpecifier+import Distribution.Client.Types.Repo+import Distribution.Client.Types.RepoName+import Distribution.Client.Types.ReadyPackage+import Distribution.Client.Types.SourcePackageDb+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
+ Distribution/Client/Types/AllowNewer.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.AllowNewer (+    AllowNewer (..),+    AllowOlder (..),+    RelaxDeps (..),+    mkRelaxDepSome,+    RelaxDepMod (..),+    RelaxDepScope (..),+    RelaxDepSubject (..),+    RelaxedDep (..),+    isRelaxDeps,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Parsec            (parsecLeadingCommaNonEmpty)+import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))+import Distribution.Types.PackageName (PackageName, mkPackageName)+import Distribution.Types.Version     (nullVersion)++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,+-- it may make sense to move these definitions to the Solver.Types+-- module++-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)+newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)+newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | Generic data type for policy when relaxing bounds in dependencies.+-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending+-- on whether or not you are relaxing an lower or upper bound+-- (respectively).+data RelaxDeps =++  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.+  --+  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all+  -- dependencies, never choose versions newer (resp. older) than allowed.+    RelaxDepsSome [RelaxedDep]++  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.+  --+  -- __Note__: This is should be semantically equivalent to+  --+  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]+  --+  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')+  | RelaxDepsAll+  deriving (Eq, Read, Show, Generic)++-- | Dependencies can be relaxed either for all packages in the install plan, or+-- only for some packages.+data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject+                deriving (Eq, Read, Show, Generic)++-- | Specify the scope of a relaxation, i.e. limit which depending+-- packages are allowed to have their version constraints relaxed.+data RelaxDepScope = RelaxDepScopeAll+                     -- ^ Apply relaxation in any package+                   | RelaxDepScopePackage !PackageName+                     -- ^ Apply relaxation to in all versions of a package+                   | RelaxDepScopePackageId !PackageId+                     -- ^ Apply relaxation to a specific version of a package only+                   deriving (Eq, Read, Show, Generic)++-- | Modifier for dependency relaxation+data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics+                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints+                 deriving (Eq, Read, Show, Generic)++-- | Express whether to relax bounds /on/ @all@ packages, or a single package+data RelaxDepSubject = RelaxDepSubjectAll+                     | RelaxDepSubjectPkg !PackageName+                     deriving (Eq, Ord, Read, Show, Generic)++instance Pretty RelaxedDep where+  pretty (RelaxedDep scope rdmod subj) = case scope of+      RelaxDepScopeAll          -> Disp.text "*:"               Disp.<> modDep+      RelaxDepScopePackage   p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep+      RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep+    where+      modDep = case rdmod of+               RelaxDepModNone  -> pretty subj+               RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj++instance Parsec RelaxedDep where+    parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)++-- continuation after *+relaxedDepStarP :: CabalParsing m => m RelaxedDep+relaxedDepStarP =+    RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)++-- continuation after package identifier+relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep+relaxedDepPkgidP pid@(PackageIdentifier pn v)+    | pn == mkPackageName "all"+    , v == nullVersion+    =  RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)++    | v == nullVersion+    = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))++    | otherwise+    = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec++modP :: P.CharParsing m => m RelaxDepMod+modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone++instance Pretty RelaxDepSubject where+  pretty RelaxDepSubjectAll      = Disp.text "*"+  pretty (RelaxDepSubjectPkg pn) = pretty pn++instance Parsec RelaxDepSubject where+  parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn+    where+      pkgn = do+          pn <- parsec+          pure $ if pn == mkPackageName "all"+              then RelaxDepSubjectAll+              else RelaxDepSubjectPkg pn++instance Pretty RelaxDeps where+  pretty rd | not (isRelaxDeps rd) = Disp.text "none"+  pretty (RelaxDepsSome pkgs)      = Disp.fsep .+                                   Disp.punctuate Disp.comma .+                                   map pretty $ pkgs+  pretty RelaxDepsAll              = Disp.text "all"++-- |+--+-- >>> simpleParsec "all" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "none" :: Maybe RelaxDeps+-- Just (RelaxDepsSome [])+--+-- >>> simpleParsec "*, *" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "*:*" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps+-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])+--+-- This is not a glitch, even it looks like:+--+-- >>> simpleParsec ", all" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "" :: Maybe RelaxDeps+-- Nothing+--+instance Parsec RelaxDeps where+    parsec = do+        xs <- parsecLeadingCommaNonEmpty parsec+        pure $ case toList xs of+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]+                -> RelaxDepsAll+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]+                | pn == mkPackageName "none"+                -> mempty+            xs' -> mkRelaxDepSome xs'++instance Binary RelaxDeps+instance Binary RelaxDepMod+instance Binary RelaxDepScope+instance Binary RelaxDepSubject+instance Binary RelaxedDep+instance Binary AllowNewer+instance Binary AllowOlder++instance Structured RelaxDeps+instance Structured RelaxDepMod+instance Structured RelaxDepScope+instance Structured RelaxDepSubject+instance Structured RelaxedDep+instance Structured AllowNewer+instance Structured AllowOlder++-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations+--+-- Equivalent to @isRelaxDeps = (/= 'mempty')@+isRelaxDeps :: RelaxDeps -> Bool+isRelaxDeps (RelaxDepsSome [])    = False+isRelaxDeps (RelaxDepsSome (_:_)) = True+isRelaxDeps RelaxDepsAll          = True++-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.+mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps+mkRelaxDepSome xs+    | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs+    = RelaxDepsAll++    | otherwise+    = RelaxDepsSome xs++-- | 'RelaxDepsAll' is the /absorbing element/+instance Semigroup RelaxDeps where+    -- identity element+    RelaxDepsSome []    <> r                   = r+    l@(RelaxDepsSome _) <> RelaxDepsSome []    = l+    -- absorbing element+    l@RelaxDepsAll      <> _                   = l+    (RelaxDepsSome   _) <> r@RelaxDepsAll      = r+    -- combining non-{identity,absorbing} elements+    (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)++-- | @'RelaxDepsSome' []@ is the /identity element/+instance Monoid RelaxDeps where+  mempty  = RelaxDepsSome []+  mappend = (<>)++instance Semigroup AllowNewer where+  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)++instance Semigroup AllowOlder where+  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)++instance Monoid AllowNewer where+  mempty  = AllowNewer mempty+  mappend = (<>)++instance Monoid AllowOlder where+  mempty  = AllowOlder mempty+  mappend = (<>)
+ Distribution/Client/Types/BuildResults.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.BuildResults (+    BuildOutcome,+    BuildOutcomes,+    BuildFailure (..),+    BuildResult (..),+    TestsResult (..),+    DocsResult (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Types.PackageId            (PackageId)+import Distribution.Types.UnitId               (UnitId)++-- | A summary of the outcome for building a single package.+--+type BuildOutcome = Either BuildFailure BuildResult++-- | A summary of the outcome for building a whole set of packages.+--+type BuildOutcomes = Map UnitId BuildOutcome++data BuildFailure = PlanningFailed+                  | DependentFailed PackageId+                  | DownloadFailed  SomeException+                  | UnpackFailed    SomeException+                  | ConfigureFailed SomeException+                  | BuildFailed     SomeException+                  | TestsFailed     SomeException+                  | InstallFailed   SomeException+  deriving (Show, Typeable, Generic)++instance Exception BuildFailure++-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only+-- the public library's 'InstalledPackageInfo' is stored here, even if+-- there were 'InstalledPackageInfo' from internal libraries.  This+-- 'InstalledPackageInfo' is not used anyway, so it makes no difference.+data BuildResult = BuildResult DocsResult TestsResult+                               (Maybe InstalledPackageInfo)+  deriving (Show, Generic)++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+  deriving (Show, Generic, Typeable)+data TestsResult = TestsNotTried | TestsOk+  deriving (Show, Generic, Typeable)++instance Binary BuildFailure+instance Binary BuildResult+instance Binary DocsResult+instance Binary TestsResult++instance Structured BuildFailure+instance Structured BuildResult+instance Structured DocsResult+instance Structured TestsResult
+ Distribution/Client/Types/ConfiguredId.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.ConfiguredId (+    InstalledPackageId,+    ConfiguredId (..),+    annotatedIdToConfiguredId,+    HasConfiguredId (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId)+import Distribution.Package              (Package (..))+import Distribution.Types.AnnotatedId    (AnnotatedId (..))+import Distribution.Types.ComponentId    (ComponentId)+import Distribution.Types.ComponentName  (ComponentName)+import Distribution.Types.PackageId      (PackageId)++-------------------------------------------------------------------------------+-- InstalledPackageId+-------------------------------------------------------------------------------++-- | Within Cabal the library we no longer have a @InstalledPackageId@ type.+-- That's because it deals with the compilers' notion of a registered library,+-- and those really are libraries not packages. Those are now named units.+--+-- The package management layer does however deal with installed packages, as+-- whole packages not just as libraries. So we do still need a type for+-- installed package ids. At the moment however we track instaled packages via+-- their primary library, which is a unit id. In future this may change+-- slightly and we may distinguish these two types and have an explicit+-- conversion when we register units with the compiler.+--+type InstalledPackageId = ComponentId++-------------------------------------------------------------------------------+-- ConfiguredId+-------------------------------------------------------------------------------++-- | A ConfiguredId is a package ID for a configured package.+--+-- Once we configure a source package we know its UnitId. It is still+-- however useful in lots of places to also know the source ID for the package.+-- We therefore bundle the two.+--+-- An already installed package of course is also "configured" (all its+-- configuration parameters and dependencies have been specified).+data ConfiguredId = ConfiguredId {+    confSrcId  :: PackageId+  , confCompName :: Maybe ComponentName+  , confInstId :: ComponentId+  }+  deriving (Eq, Ord, Generic)++annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId+annotatedIdToConfiguredId aid = ConfiguredId {+        confSrcId    = ann_pid aid,+        confCompName = Just (ann_cname aid),+        confInstId   = ann_id aid+    }++instance Binary ConfiguredId+instance Structured ConfiguredId++instance Show ConfiguredId where+  show cid = show (confInstId cid)++instance Package ConfiguredId where+  packageId = confSrcId++-------------------------------------------------------------------------------+-- HasConfiguredId class+-------------------------------------------------------------------------------++class HasConfiguredId a where+    configuredId :: a -> ConfiguredId++-- NB: This instance is slightly dangerous, in that you'll lose+-- information about the specific UnitId you depended on.+instance HasConfiguredId InstalledPackageInfo where+    configuredId ipkg = ConfiguredId (packageId ipkg)+                            (Just (sourceComponentName ipkg))+                            (installedComponentId ipkg)
+ Distribution/Client/Types/ConfiguredPackage.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}+module Distribution.Client.Types.ConfiguredPackage (+    ConfiguredPackage (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Compat.Graph (IsNode (..))+import Distribution.Package      (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId)+import Distribution.Types.Flag   (FlagAssignment)+import Distribution.Types.ComponentName+import Distribution.Types.LibraryName (LibraryName (..))+import Distribution.Types.MungedPackageId (computeCompatPackageId)+import Distribution.Simple.Utils (ordNub)++import Distribution.Client.Types.ConfiguredId+import Distribution.Solver.Types.OptionalStanza   (OptionalStanza)+import Distribution.Solver.Types.PackageFixedDeps+import Distribution.Solver.Types.SourcePackage    (SourcePackage)++import qualified Distribution.Solver.Types.ComponentDeps as CD++-- | A 'ConfiguredPackage' is a not-yet-installed package along with the+-- total configuration information. The configuration information is total in+-- the sense that it provides all the configuration information and so the+-- final configure process will be independent of the environment.+--+-- 'ConfiguredPackage' is assumed to not support Backpack.  Only the+-- @v2-build@ codepath supports Backpack.+--+data ConfiguredPackage loc = ConfiguredPackage+    { confPkgId      :: InstalledPackageId+    , confPkgSource  :: SourcePackage loc  -- ^ package info, including repo+    , confPkgFlags   :: FlagAssignment     -- ^ complete flag assignment for the package+    , confPkgStanzas :: [OptionalStanza]   -- ^ list of enabled optional stanzas for the package+    , confPkgDeps    :: CD.ComponentDeps [ConfiguredId]+      -- ^ set of exact dependencies (installed or source).+      --+      -- These must be consistent with the 'buildDepends'+      -- in the 'PackageDescription' that you'd get by+      -- applying the flag assignment and optional stanzas.+    }+  deriving (Eq, Show, Generic)++-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.+-- This type class is mostly used to conveniently finesse between+-- 'ElaboratedPackage' and 'ElaboratedComponent'.+--+instance HasConfiguredId (ConfiguredPackage loc) where+    configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)++-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed+-- to never have a nontrivial 'UnitId'+instance PackageFixedDeps (ConfiguredPackage loc) where+    depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps++instance IsNode (ConfiguredPackage loc) where+    type Key (ConfiguredPackage loc) = UnitId+    nodeKey       = newSimpleUnitId . confPkgId+    -- TODO: if we update ConfiguredPackage to support order-only+    -- dependencies, need to include those here.+    -- NB: have to deduplicate, otherwise the planner gets confused+    nodeNeighbors = ordNub . CD.flatDeps . depends++instance (Binary loc) => Binary (ConfiguredPackage loc)+++++instance Package (ConfiguredPackage loc) where+  packageId cpkg = packageId (confPkgSource cpkg)++instance HasMungedPackageId (ConfiguredPackage loc) where+  mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName++-- Never has nontrivial UnitId+instance HasUnitId (ConfiguredPackage loc) where+  installedUnitId = newSimpleUnitId . confPkgId++instance PackageInstalled (ConfiguredPackage loc) where+  installedDepends = CD.flatDeps . depends+++
+ Distribution/Client/Types/Credentials.hs view
@@ -0,0 +1,9 @@+module Distribution.Client.Types.Credentials (+    Username (..),+    Password (..),+) where++import Prelude (String)++newtype Username = Username { unUsername :: String }+newtype Password = Password { unPassword :: String }
+ Distribution/Client/Types/InstallMethod.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.InstallMethod where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as PP++data InstallMethod+    = InstallMethodCopy+    | InstallMethodSymlink+  deriving (Eq, Show, Generic, Bounded, Enum)++instance Binary InstallMethod+instance Structured InstallMethod++-- | Last+instance Semigroup InstallMethod where+    _ <> x = x++instance Parsec InstallMethod where+    parsec = do+        name <- P.munch1 isAlpha+        case name of+            "copy"    -> pure InstallMethodCopy+            "symlink" -> pure InstallMethodSymlink+            _         -> P.unexpected $ "InstallMethod: " ++ name++instance Pretty InstallMethod where+    pretty InstallMethodCopy    = PP.text "copy"+    pretty InstallMethodSymlink = PP.text "symlink"
+ Distribution/Client/Types/OverwritePolicy.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.OverwritePolicy where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as PP++data OverwritePolicy+    = NeverOverwrite+    | AlwaysOverwrite+  deriving (Show, Eq, Generic, Bounded, Enum)++instance Binary OverwritePolicy+instance Structured OverwritePolicy++instance Parsec OverwritePolicy where+    parsec = do+        name <- P.munch1 isAlpha+        case name of+            "always" -> pure AlwaysOverwrite+            "never"  -> pure NeverOverwrite+            _        -> P.unexpected $ "OverwritePolicy: " ++ name++instance Pretty OverwritePolicy where+    pretty NeverOverwrite  = PP.text "never"+    pretty AlwaysOverwrite = PP.text "always"
+ Distribution/Client/Types/PackageLocation.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.PackageLocation (+    PackageLocation (..),+    UnresolvedPkgLoc,+    ResolvedPkgLoc,+    UnresolvedSourcePackage,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI)++import Distribution.Types.PackageId (PackageId)++import Distribution.Client.Types.Repo+import Distribution.Client.Types.SourceRepo    (SourceRepoMaybe)+import Distribution.Solver.Types.SourcePackage (SourcePackage)++type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)++type ResolvedPkgLoc = PackageLocation FilePath++data PackageLocation local =++    -- | An unpacked package in the given dir, or current dir+    LocalUnpackedPackage FilePath++    -- | A package as a tarball that's available as a local tarball+  | LocalTarballPackage FilePath++    -- | A package as a tarball from a remote URI+  | RemoteTarballPackage URI local++    -- | A package available as a tarball from a repository.+    --+    -- It may be from a local repository or from a remote repository, with a+    -- locally cached copy. ie a package available from hackage+  | RepoTarballPackage Repo PackageId local++    -- | A package available from a version control system source repository+  | RemoteSourceRepoPackage SourceRepoMaybe local+  deriving (Show, Functor, Eq, Ord, Generic, Typeable)++instance Binary local => Binary (PackageLocation local)+instance Structured local => Structured (PackageLocation local)++-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.+type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc
+ Distribution/Client/Types/PackageSpecifier.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.PackageSpecifier (+    PackageSpecifier (..),+    pkgSpecifierTarget,+    pkgSpecifierConstraints,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Package           (Package (..), packageName, packageVersion)+import Distribution.Types.PackageName (PackageName)+import Distribution.Version           (thisVersion)++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PackageConstraint++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++     -- | A partially specified reference to a package (either source or+     -- installed). It is specified by package name and optionally some+     -- required properties. Use a dependency resolver to pick a specific+     -- package satisfying these properties.+     --+     NamedPackage PackageName [PackageProperty]++     -- | A fully specified source package.+     --+   | SpecificSourcePackage pkg+  deriving (Eq, Show, Functor, Generic)++instance Binary pkg => Binary (PackageSpecifier pkg)+instance Structured pkg => Structured (PackageSpecifier pkg)++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _)       = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+                        => PackageSpecifier pkg -> [LabeledPackageConstraint]+pkgSpecifierConstraints (NamedPackage name props) = map toLpc props+  where+    toLpc prop = LabeledPackageConstraint+                 (PackageConstraint (scopeToplevel name) prop)+                 ConstraintSourceUserTarget+pkgSpecifierConstraints (SpecificSourcePackage pkg)  =+    [LabeledPackageConstraint pc ConstraintSourceUserTarget]+  where+    pc = PackageConstraint+         (ScopeTarget $ packageName pkg)+         (PackagePropertyVersion $ thisVersion (packageVersion pkg))
+ Distribution/Client/Types/ReadyPackage.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Client.Types.ReadyPackage (+    GenericReadyPackage (..),+    ReadyPackage,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Compat.Graph (IsNode (..))+import Distribution.Package      (HasMungedPackageId, HasUnitId, Package, PackageInstalled)++import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage)+import Distribution.Client.Types.PackageLocation   (UnresolvedPkgLoc)+import Distribution.Solver.Types.PackageFixedDeps++-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be+-- installed already, hence itself ready to be installed.+newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.+  deriving (Eq, Show, Generic, Package, PackageFixedDeps,+            HasMungedPackageId, HasUnitId, PackageInstalled, Binary)++-- Can't newtype derive this+instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where+    type Key (GenericReadyPackage srcpkg) = Key srcpkg+    nodeKey (ReadyPackage spkg) = nodeKey spkg+    nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg++type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
+ Distribution/Client/Types/Repo.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.Repo (+    -- * Remote repository+    RemoteRepo (..),+    emptyRemoteRepo,+    -- * Local repository (no-index)+    LocalRepo (..),+    emptyLocalRepo,+    localRepoCacheKey,+    -- * Repository+    Repo (..),+    repoName,+    isRepoRemote,+    maybeRepoRemote,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString)++import Distribution.Simple.Utils (toUTF8BS)++import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)++import qualified Data.ByteString.Lazy.Char8      as LBS+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++import Distribution.Client.Types.RepoName++-------------------------------------------------------------------------------+-- Remote repository+-------------------------------------------------------------------------------++data RemoteRepo =+    RemoteRepo {+      remoteRepoName     :: RepoName,+      remoteRepoURI      :: URI,++      -- | Enable secure access?+      --+      -- 'Nothing' here represents "whatever the default is"; this is important+      -- to allow for a smooth transition from opt-in to opt-out security+      -- (once we switch to opt-out, all access to the central Hackage+      -- repository should be secure by default)+      remoteRepoSecure :: Maybe Bool,++      -- | Root key IDs (for bootstrapping)+      remoteRepoRootKeys :: [String],++      -- | Threshold for verification during bootstrapping+      remoteRepoKeyThreshold :: Int,++      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a+      -- special case we may know a repo supports both and want to try HTTPS+      -- if we can, but still allow falling back to HTTP.+      --+      -- This field is not currently stored in the config file, but is filled+      -- in automagically for known repos.+      remoteRepoShouldTryHttps :: Bool+    }++  deriving (Show, Eq, Ord, Generic)++instance Binary RemoteRepo+instance Structured RemoteRepo++instance Pretty RemoteRepo where+    pretty r =+        pretty (remoteRepoName r) <<>> Disp.colon <<>>+        Disp.text (uriToString id (remoteRepoURI r) [])++-- | Note: serialised format represends 'RemoteRepo' only partially.+instance Parsec RemoteRepo where+    parsec = do+        name <- parsec+        _ <- P.char ':'+        uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))+        uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)+        return RemoteRepo+            { remoteRepoName           = name+            , remoteRepoURI            = uri+            , remoteRepoSecure         = Nothing+            , remoteRepoRootKeys       = []+            , remoteRepoKeyThreshold   = 0+            , remoteRepoShouldTryHttps = False+            }++-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.+emptyRemoteRepo :: RepoName -> RemoteRepo+emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False++-------------------------------------------------------------------------------+-- Local repository+-------------------------------------------------------------------------------++-- | /no-index/ style local repositories.+--+-- https://github.com/haskell/cabal/issues/6359+data LocalRepo = LocalRepo+    { localRepoName        :: RepoName+    , localRepoPath        :: FilePath+    , localRepoSharedCache :: Bool+    }+  deriving (Show, Eq, Ord, Generic)++instance Binary LocalRepo+instance Structured LocalRepo++-- | Note: doesn't parse 'localRepoSharedCache' field.+instance Parsec LocalRepo where+    parsec = do+        n <- parsec+        _ <- P.char ':'+        p <- P.munch1 (const True) -- restrict what can be a path?+        return (LocalRepo n p False)++instance Pretty LocalRepo where+    pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p++-- | Construct a partial 'LocalRepo' value to fold the field parser list over.+emptyLocalRepo :: RepoName -> LocalRepo+emptyLocalRepo name = LocalRepo name "" False++-- | Calculate a cache key for local-repo.+--+-- For remote repositories we just use name, but local repositories may+-- all be named "local", so we add a bit of `localRepoPath` into the+-- mix.+localRepoCacheKey :: LocalRepo -> String+localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where+    hashPart+        = showHashValue $ truncateHash 8 $ hashValue+        $ LBS.fromStrict $ toUTF8BS $ localRepoPath local++-------------------------------------------------------------------------------+-- Any repository+-------------------------------------------------------------------------------++-- | Different kinds of repositories+--+-- NOTE: It is important that this type remains serializable.+data Repo+    -- | Local repository, without index.+    --+    -- https://github.com/haskell/cabal/issues/6359+  = RepoLocalNoIndex+      { repoLocal    :: LocalRepo+      , repoLocalDir :: FilePath+      }++    -- | Standard (unsecured) remote repositores+  | RepoRemote {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }++    -- | Secure repositories+    --+    -- Although this contains the same fields as 'RepoRemote', we use a separate+    -- constructor to avoid confusing the two.+    --+    -- Not all access to a secure repo goes through the hackage-security+    -- library currently; code paths that do not still make use of the+    -- 'repoRemote' and 'repoLocalDir' fields directly.+  | RepoSecure {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }+  deriving (Show, Eq, Ord, Generic)++instance Binary Repo+instance Structured Repo++-- | Check if this is a remote repo+isRepoRemote :: Repo -> Bool+isRepoRemote RepoLocalNoIndex{} = False+isRepoRemote _                  = True++-- | Extract @RemoteRepo@ from @Repo@ if remote.+maybeRepoRemote :: Repo -> Maybe RemoteRepo+maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing+maybeRepoRemote (RepoRemote       r _localDir) = Just r+maybeRepoRemote (RepoSecure       r _localDir) = Just r++repoName :: Repo -> RepoName+repoName (RepoLocalNoIndex r _) = localRepoName r+repoName (RepoRemote r _)       = remoteRepoName r+repoName (RepoSecure r _)       = remoteRepoName r
+ Distribution/Client/Types/RepoName.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.RepoName (+    RepoName (..),+    unRepoName,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-- | Repository name.+--+-- May be used as path segment.+--+newtype RepoName = RepoName String+  deriving (Show, Eq, Ord, Generic)++unRepoName :: RepoName -> String+unRepoName (RepoName n) = n++instance Binary RepoName+instance Structured RepoName+instance NFData RepoName++instance Pretty RepoName where+    pretty = Disp.text . unRepoName++-- |+--+-- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName+-- Just (RepoName "hackage.haskell.org")+--+-- >>> simpleParsec "0123" :: Maybe RepoName+-- Nothing+--+instance Parsec RepoName where+    parsec = RepoName <$> parser where+        parser = (:) <$> lead <*> rest+        lead = P.satisfy (\c -> isAlpha    c || c == '_' || c == '-' || c == '.')+        rest = P.munch   (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
+ Distribution/Client/Types/SourcePackageDb.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.SourcePackageDb (+    SourcePackageDb (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Types.PackageName  (PackageName)+import Distribution.Types.VersionRange (VersionRange)++import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage)+import Distribution.Solver.Types.PackageIndex    (PackageIndex)++-- | This is the information we get from a @00-index.tar.gz@ hackage index.+--+data SourcePackageDb = SourcePackageDb+    { packageIndex       :: PackageIndex UnresolvedSourcePackage+    , packagePreferences :: Map PackageName VersionRange+    }+  deriving (Eq, Generic)++instance Binary SourcePackageDb
+ Distribution/Client/Types/SourceRepo.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE UndecidableInstances #-}+module Distribution.Client.Types.SourceRepo (+    SourceRepositoryPackage (..),+    SourceRepoList,+    SourceRepoMaybe,+    SourceRepoProxy,+    srpHoist,+    srpToProxy,+    srpFanOut,+    sourceRepositoryPackageGrammar,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens           (Lens, Lens')+import Prelude ()++import Distribution.FieldGrammar+import Distribution.Types.SourceRepo (RepoType (..))++-- | @source-repository-package@ definition+--+data SourceRepositoryPackage f = SourceRepositoryPackage+    { srpType     :: !RepoType+    , srpLocation :: !String+    , srpTag      :: !(Maybe String)+    , srpBranch   :: !(Maybe String)+    , srpSubdir   :: !(f FilePath)+    }+  deriving (Generic)++deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)+deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)+deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)+deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)+deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)++-- | Read from @cabal.project@+type SourceRepoList  = SourceRepositoryPackage []++-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'+type SourceRepoMaybe = SourceRepositoryPackage Maybe++-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.+type SourceRepoProxy = SourceRepositoryPackage Proxy++srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g+srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }++srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy+srpToProxy s = s { srpSubdir = Proxy }++-- | Split single @source-repository-package@ declaration with multiple subdirs,+-- into multiple ones with at most single subdir.+srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)+srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =+    s { srpSubdir = Nothing } :| []+srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where+    f subdir = s { srpSubdir = Just subdir }++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType+srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))+{-# INLINE srpTypeLens #-}++srpLocationLens :: Lens' (SourceRepositoryPackage f) String+srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))+{-# INLINE srpLocationLens #-}++srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))+{-# INLINE srpTagLens #-}++srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))+{-# INLINE srpBranchLens #-}++srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)+srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))+{-# INLINE srpSubdirLens #-}++-------------------------------------------------------------------------------+-- Parser & PPrinter+-------------------------------------------------------------------------------++sourceRepositoryPackageGrammar+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType)+       , c (List NoCommaFSep FilePathNT String)+       )+    => g SourceRepoList SourceRepoList+sourceRepositoryPackageGrammar = SourceRepositoryPackage+    <$> uniqueField      "type"                                       srpTypeLens+    <*> uniqueFieldAla   "location" Token                             srpLocationLens+    <*> optionalFieldAla "tag"      Token                             srpTagLens+    <*> optionalFieldAla "branch"   Token                             srpBranchLens+    <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...+{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}+{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
+ Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (+    WriteGhcEnvironmentFilesPolicy (..),+) where++import Prelude ()+import Distribution.Client.Compat.Prelude++-- | Whether 'v2-build' should write a .ghc.environment file after+-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+'+-- (8.4.4 is the earliest version that supports+-- '-package-env -').+data WriteGhcEnvironmentFilesPolicy+  = AlwaysWriteGhcEnvironmentFiles+  | NeverWriteGhcEnvironmentFiles+  | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer+  deriving (Eq, Enum, Bounded, Generic, Show)++instance Binary WriteGhcEnvironmentFilesPolicy+instance Structured WriteGhcEnvironmentFilesPolicy
Distribution/Client/Update.hs view
@@ -15,17 +15,21 @@     ( update     ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Simple.Setup          ( fromFlag ) import Distribution.Client.Compat.Directory          ( setModificationTime ) import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), maybeRepoRemote )+         ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName ) import Distribution.Client.HttpUtils          ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils          ( updateRepoIndexCache, Index(..), writeIndexTimestamp          , currentIndexTimestamp, indexBaseName )@@ -33,9 +37,7 @@          ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup          ( RepoContext(..), UpdateFlags(..) )-import Distribution.Deprecated.Text-         ( display )-import Distribution.Verbosity+import Distribution.Verbosity (lessVerbose)  import Distribution.Simple.Utils          ( writeFileAtomic, warn, notice, noticeNoWrap )@@ -43,9 +45,7 @@ import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((<.>), dropExtension)-import Data.Maybe (mapMaybe) import Data.Time (getCurrentTime)-import Control.Monad  import qualified Hackage.Security.Client as Sec @@ -61,20 +61,19 @@     [] -> return ()     [remoteRepo] ->         notice verbosity $ "Downloading the latest package list from "-                        ++ remoteRepoName remoteRepo+                        ++ unRepoName (remoteRepoName remoteRepo)     _ -> notice verbosity . unlines             $ "Downloading the latest package lists from: "-            : map (("- " ++) . remoteRepoName) remoteRepos+            : map (("- " ++) . unRepoName . remoteRepoName) remoteRepos   jobCtrl <- newParallelJobControl (length repos)-  mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos-  mapM_ (\_ -> collectJob jobCtrl) repos+  traverse_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos+  traverse_ (\_ -> collectJob jobCtrl) repos  updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () updateRepo verbosity updateFlags repoCtxt repo = do   transport <- repoContextGetTransport repoCtxt   case repo of-    RepoLocal{..} -> return ()-    RepoLocalNoIndex{..} -> return ()+    RepoLocalNoIndex{} -> return ()     RepoRemote{..} -> do       downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir       case downloadResult of@@ -84,13 +83,20 @@           writeFileAtomic (dropExtension indexPath) . maybeDecompress                                                   =<< BS.readFile indexPath           updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+    RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do       let index = RepoIndex repoCtxt repo       -- NB: This may be a nullTimestamp if we've never updated before       current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+       -- NB: always update the timestamp, even if we didn't actually       -- download anything-      writeIndexTimestamp index (fromFlag (updateIndexState updateFlags))+      let rname :: RepoName+          rname = remoteRepoName remote++      let repoIndexState :: RepoIndexState+          repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags))+      writeIndexTimestamp index repoIndexState+       ce <- if repoContextIgnoreExpiry repoCtxt               then Just `fmap` getCurrentTime               else return Nothing@@ -108,4 +114,4 @@       when (current_ts /= nullTimestamp) $         noticeNoWrap verbosity $           "To revert to previous state run:\n" ++-          "    cabal update --index-state='" ++ display current_ts ++ "'\n"+          "    cabal update --index-state='" ++ prettyShow current_ts ++ "'\n"
Distribution/Client/Upload.hs view
@@ -1,18 +1,21 @@ module Distribution.Client.Upload (upload, uploadDoc, report) where -import Distribution.Client.Types ( Username(..), Password(..)-                                 , RemoteRepo(..), maybeRepoRemote )+import Distribution.Client.Compat.Prelude+import qualified Prelude as Unsafe (tail, head, read)++import Distribution.Client.Types.Credentials ( Username(..), Password(..) )+import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote)+import Distribution.Client.Types.RepoName (unRepoName) import Distribution.Client.HttpUtils          ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup          ( IsCandidate(..), RepoContext(..) ) -import Distribution.Simple.Utils (notice, warn, info, die')-import Distribution.Verbosity (Verbosity)-import Distribution.Deprecated.Text (display)+import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) import Distribution.Client.Config  import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (parseBuildReport) import qualified Distribution.Client.BuildReports.Upload as BuildReport  import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName))@@ -20,13 +23,9 @@  import System.IO        (hFlush, stdout) import System.IO.Echo   (withoutInputEcho)-import System.Exit      (exitFailure) import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory-import Control.Monad (forM_, when, foldM)-import Data.Maybe (mapMaybe)-import Data.Char (isSpace)  type Auth = Maybe (String, String) @@ -50,7 +49,7 @@     targetRepo <-       case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of         [] -> die' verbosity "Cannot upload. No remote repositories are configured."-        rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs)+        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))     let targetRepoURI = remoteRepoURI targetRepo         domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI         rootIfEmpty x = if null x then "/" else x@@ -72,7 +71,7 @@     Username username <- maybe (promptUsername domain) return mUsername     Password password <- maybe (promptPassword domain) return mPassword     let auth = Just (username,password)-    forM_ paths $ \path -> do+    for_ paths $ \path -> do       notice verbosity $ "Uploading " ++ path ++ "... "       case fmap takeFileName (stripExtensions ["tar", "gz"] path) of         Just pkgid -> handlePackage transport verbosity uploadURI@@ -90,7 +89,7 @@     targetRepo <-       case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of         [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."-        rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs)+        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))     let targetRepoURI = remoteRepoURI targetRepo         domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI         rootIfEmpty x = if null x then "/" else x@@ -115,9 +114,9 @@         }         (reverseSuffix, reversePkgid) = break (== '-')                                         (reverse (takeFileName path))-        pkgid = reverse $ tail reversePkgid+        pkgid = reverse $ Unsafe.tail reversePkgid     when (reverse reverseSuffix /= "docs.tar.gz"-          || null reversePkgid || head reversePkgid /= '-') $+          || null reversePkgid || Unsafe.head reversePkgid /= '-') $       die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"     Username username <- maybe (promptUsername domain) return mUsername     Password password <- maybe (promptPassword domain) return mPassword@@ -170,27 +169,27 @@ report verbosity repoCtxt mUsername mPassword = do   let repos       = repoContextRepos repoCtxt       remoteRepos = mapMaybe maybeRepoRemote repos-  forM_ remoteRepos $ \remoteRepo -> do+  for_ remoteRepos $ \remoteRepo -> do       let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)       Username username <- maybe (promptUsername domain) return mUsername       Password password <- maybe (promptPassword domain) return mPassword       let auth        = (username, password)        dotCabal <- getCabalDir-      let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+      let srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)       -- We don't want to bomb out just because we haven't built any packages       -- from this repo yet.       srcExists <- doesDirectoryExist srcDir       when srcExists $ do         contents <- getDirectoryContents srcDir-        forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->+        for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->           do inp <- readFile (srcDir </> logFile)-             let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse-             case BuildReport.parse reportStr of+             let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse+             case parseBuildReport (toUTF8BS reportStr) of                Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME                Right report' ->                  do info verbosity $ "Uploading report for "-                      ++ display (BuildReport.package report')+                      ++ prettyShow (BuildReport.package report')                     BuildReport.uploadReports verbosity repoCtxt auth                       (remoteRepoURI remoteRepo) [(report', Just buildLog)]                     return ()
Distribution/Client/Utils.hs view
@@ -19,24 +19,24 @@                                  , tryFindPackageDesc                                  , relaxEncodingErrors                                  , ProgressPhase (..)-                                 , progressMessage)+                                 , progressMessage+                                 , cabalInstallVersion)        where  import Prelude () import Distribution.Client.Compat.Prelude  import Distribution.Compat.Environment-import Distribution.Compat.Exception   ( catchIO )-import Distribution.Compat.Time ( getModTime )+import Distribution.Compat.Time        ( getModTime ) import Distribution.Simple.Setup       ( Flag(..) )-import Distribution.Verbosity+import Distribution.Version import Distribution.Simple.Utils       ( die', findPackageDesc, noticeNoWrap ) import qualified Data.ByteString.Lazy as BS import Data.Bits          ( (.|.), shiftL, shiftR ) import System.FilePath import Control.Monad-         ( mapM, mapM_, zipWithM_ )+         ( zipWithM_ ) import Data.List          ( groupBy ) import Foreign.C.Types ( CInt(..) )@@ -61,6 +61,10 @@ import qualified System.IO.Error as IOError #endif +#ifndef __DOCTEST__+import qualified Paths_cabal_install (version)+#endif+ -- | Generic merging utility. For sorted input lists this is a full outer join. -- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]@@ -143,8 +147,8 @@ -- environment is a process-global concept. withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a withEnvOverrides overrides m = do-  mb_olds <- mapM lookupEnv envVars-  mapM_ (uncurry update) overrides+  mb_olds <- traverse lookupEnv envVars+  traverse_ (uncurry update) overrides   m `Exception.finally` zipWithM_ update envVars mb_olds    where     envVars :: [String]@@ -356,3 +360,10 @@         ProgressHaddock     -> "Haddock      "         ProgressInstalling  -> "Installing   "         ProgressCompleted   -> "Completed    "++cabalInstallVersion :: Version+#ifdef __DOCTEST__+cabalInstallVersion = mkVersion [3,3]+#else+cabalInstallVersion = mkVersion' Paths_cabal_install.version+#endif
Distribution/Client/Utils/Assertion.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE CPP #-} module Distribution.Client.Utils.Assertion (expensiveAssert) where + #ifdef DEBUG_EXPENSIVE_ASSERTIONS+import Prelude (Bool) import Control.Exception (assert) import Distribution.Compat.Stack+#else+import Prelude (Bool, id) #endif  -- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This
Distribution/Client/Utils/Json.hs view
@@ -15,13 +15,10 @@     )     where -import Data.Char-import Data.Int-import Data.String-import Data.Word-import Data.List-import Data.Monoid+import Distribution.Client.Compat.Prelude +import Data.Char (intToDigit)+ import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB @@ -135,13 +132,13 @@ encodeArrayBB [] = "[]" encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'   where-    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB+    go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB  encodeObjectBB :: Object -> Builder encodeObjectBB [] = "{}" encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'   where-    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair+    go = mconcat . intersperse (BB.char8 ',') . map encPair     encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x  encodeStringBB :: String -> Builder
Distribution/Client/VCS.hs view
@@ -28,18 +28,19 @@     vcsGit,     vcsHg,     vcsSvn,+    vcsPijul,   ) where  import Prelude () import Distribution.Client.Compat.Prelude  import Distribution.Types.SourceRepo-         ( RepoType(..) )-import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)+         ( RepoType(..), KnownRepoType (..) )+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) import Distribution.Client.RebuildMonad          ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Simple.Program          ( Program(programFindVersion)          , ConfiguredProgram(programVersion)@@ -50,14 +51,10 @@          ( mkVersion ) import qualified Distribution.PackageDescription as PD -import Control.Monad-         ( mapM_ ) import Control.Monad.Trans          ( liftIO ) import qualified Data.Char as Char import qualified Data.Map  as Map-import Data.Either-         ( partitionEithers ) import System.FilePath          ( takeDirectory ) import System.Directory@@ -186,7 +183,7 @@     -> IO () cloneSourceRepo verbosity vcs                 repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =-    mapM_ (runProgramInvocation verbosity) invocations+    traverse_ (runProgramInvocation verbosity) invocations   where     invocations = vcsCloneRepo vcs verbosity                                (vcsProgram vcs) repo@@ -234,7 +231,7 @@ vcsBzr :: VCS Program vcsBzr =     VCS {-      vcsRepoType = Bazaar,+      vcsRepoType = KnownRepoType Bazaar,       vcsProgram  = bzrProgram,       vcsCloneRepo,       vcsSyncRepos@@ -280,7 +277,7 @@ vcsDarcs :: VCS Program vcsDarcs =     VCS {-      vcsRepoType = Darcs,+      vcsRepoType = KnownRepoType Darcs,       vcsProgram  = darcsProgram,       vcsCloneRepo,       vcsSyncRepos@@ -325,7 +322,7 @@ vcsGit :: VCS Program vcsGit =     VCS {-      vcsRepoType = Git,+      vcsRepoType = KnownRepoType Git,       vcsProgram  = gitProgram,       vcsCloneRepo,       vcsSyncRepos@@ -418,7 +415,7 @@ vcsHg :: VCS Program vcsHg =     VCS {-      vcsRepoType = Mercurial,+      vcsRepoType = KnownRepoType Mercurial,       vcsProgram  = hgProgram,       vcsCloneRepo,       vcsSyncRepos@@ -464,7 +461,7 @@ vcsSvn :: VCS Program vcsSvn =     VCS {-      vcsRepoType = SVN,+      vcsRepoType = KnownRepoType SVN,       vcsProgram  = svnProgram,       vcsCloneRepo,       vcsSyncRepos@@ -498,3 +495,147 @@         _ -> ""   } ++-- | VCS driver for Pijul.+-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>+--+-- 2020-04-09 Oleg:+--+--    As far as I understand pijul, there are branches and "tags" in pijul,+--    but there aren't a "commit hash" identifying an arbitrary state.+--+--    One can create `a pijul tag`, which will make a patch hash,+--    which depends on everything currently in the repository.+--    I guess if you try to apply that patch, you'll be forced to apply+--    all the dependencies too. In other words, there are no named tags.+--+--    It's not clear to me whether there is an option to+--    "apply this patch *and* all of its dependencies".+--    And relatedly, whether how to make sure that there are no other+--    patches applied.+--+--    With branches it's easier, as you can `pull` and `checkout` them,+--    and they seem to be similar enough. Yet, pijul documentations says+--+--    > Note that the purpose of branches in Pijul is quite different from Git,+--      since Git's "feature branches" can usually be implemented by just+--      patches.+--+--    I guess it means that indeed instead of creating a branch and making PR+--    in "GitHub" workflow, you'd just create a patch and offer it.+--    You can do that with `git` too. Push (a branch with) commit to remote+--    and ask other to cherry-pick that commit. Yet, in git identity of commit+--    changes when it applied to other trees, where patches in pijul have+--    will continue to have the same hash.+--+--    Unfortunately pijul doesn't talk about conflict resolution.+--    It seems that you get something like:+--+--        % pijul status+--        On branch merge+--+--        Unresolved conflicts:+--          (fix conflicts and record the resolution with "pijul record ...")+--+--                foo+--+--        % cat foo+--        first line+--        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>+--        branch BBB+--        ================================+--        branch AAA+--        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+--        last line+--+--    And then the `pijul dependencies` would draw you a graph like+--+--+--                    ----->  foo on branch B ----->+--    resolve confict                                  Initial patch+--                    ----->  foo on branch A ----->+--+--    Which is seems reasonable.+--+--    So currently, pijul support is very experimental, and most likely+--    won't work, even the basics are in place. Tests are also written+--    but disabled, as the branching model differs from `git` one,+--    for which tests are written.+--+vcsPijul :: VCS Program+vcsPijul =+    VCS {+      vcsRepoType = KnownRepoType Pijul,+      vcsProgram  = pijulProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo _verbosity prog repo srcuri destdir =+        [ programInvocation prog cloneArgs ]+        -- And if there's a tag, we have to do that in a second step:+     ++ [ (programInvocation prog (checkoutArgs tag)) {+            progInvokeCwd = Just destdir+          }+        | tag <- maybeToList (srpTag repo) ]+      where+        cloneArgs  = ["clone", srcuri, destdir]+                     ++ branchArgs+        branchArgs = case srpBranch repo of+          Just b  -> ["--from-branch", b]+          Nothing -> []+        checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either++    vcsSyncRepos :: Verbosity+                 -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)]+                 -> IO [MonitorFilePath]+    vcsSyncRepos _ _ [] = return []+    vcsSyncRepos verbosity pijulProg+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do++      vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing+      sequence_+        [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)+        | (repo, localDir) <- secondaryRepos ]+      return [ monitorDirectoryExistence dir+             | dir <- (primaryLocalDir : map snd secondaryRepos) ]++    vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do+        exists <- doesDirectoryExist localDir+        if exists+        then pijul localDir                 ["pull"] -- TODO: this probably doesn't work.+        else pijul (takeDirectory localDir) cloneArgs+        pijul localDir checkoutArgs+      where+        pijul :: FilePath -> [String] -> IO ()+        pijul cwd args = runProgramInvocation verbosity $+                         (programInvocation pijulProg args) {+                           progInvokeCwd = Just cwd+                         }++        cloneArgs      = ["clone", loc, localDir]+                      ++ case peer of+                           Nothing           -> []+                           Just peerLocalDir -> [peerLocalDir]+                         where loc = srpLocation+        checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]+        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.++pijulProgram :: Program+pijulProgram = (simpleProgram "pijul") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- "pijul 0.12.2+        (_:ver:_) | all isTypical ver -> ver+        _ -> ""+  }+  where+    isNum     c = c >= '0' && c <= '9'+    isTypical c = isNum c || c == '.'
Distribution/Client/Win32SelfUpgrade.hs view
@@ -42,6 +42,9 @@     deleteOldExeFile,   ) where +import Distribution.Client.Compat.Prelude hiding (log)+import Prelude ()+ #ifdef mingw32_HOST_OS  import qualified System.Win32 as Win32@@ -51,10 +54,9 @@ import System.Directory (canonicalizePath) import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) -import Distribution.Verbosity as Verbosity (Verbosity, showForCabal)+import Distribution.Verbosity as Verbosity (showForCabal) import Distribution.Simple.Utils (debug, info) -import Prelude hiding (log)  -- | If one of the given files is our own exe file then we arrange things such -- that the nested action can replace our own exe file.@@ -68,7 +70,7 @@ possibleSelfUpgrade verbosity newPaths action = do   dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE -  newPaths' <- mapM canonicalizePath newPaths+  newPaths' <- traverse canonicalizePath newPaths   let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'    if not doingSelfUpgrade@@ -211,7 +213,6 @@  #else -import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils (die')  possibleSelfUpgrade :: Verbosity
Distribution/Client/World.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.World@@ -33,22 +34,14 @@ import Distribution.Client.Compat.Prelude hiding (getContents)  import Distribution.Types.Dependency-import Distribution.PackageDescription-         ( FlagAssignment, mkFlagAssignment, unFlagAssignment-         , mkFlagName, unFlagName )-import Distribution.Verbosity-         ( Verbosity )+import Distribution.Types.Flag+         ( FlagAssignment, unFlagAssignment+         , unFlagName, parsecFlagAssignmentNonEmpty ) import Distribution.Simple.Utils          ( die', info, chattyTry, writeFileAtomic )-import Distribution.Deprecated.Text-         ( Text(..), display, simpleParse )-import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Compat.Exception ( catchIO )+import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp --import Data.Char as Char- import Data.List          ( unionBy, deleteFirstsBy ) import System.IO.Error@@ -57,7 +50,7 @@   data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment-  deriving (Show,Eq)+  deriving (Show,Eq, Generic)  -- | Adds packages to the world file; creates the file if it doesn't -- exist yet. Version constraints and flag assignments for a package are@@ -102,7 +95,7 @@       then do         info verbosity "Updating world file..."         writeFileAtomic world . B.pack $ unlines-            [ (display pkg) | pkg <- pkgsNewWorld]+            [ (prettyShow pkg) | pkg <- pkgsNewWorld]       else         info verbosity "World file is already up to date." @@ -111,7 +104,7 @@ getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] getContents verbosity world = do   content <- safelyReadFile world-  let result = map simpleParse (lines $ B.unpack content)+  let result = map simpleParsec (lines $ B.unpack content)   case sequence result of     Nothing -> die' verbosity "Could not parse world file."     Just xs -> return xs@@ -123,51 +116,29 @@                 | otherwise             = ioError e  -instance Text WorldPkgInfo where-  disp (WorldPkgInfo dep flags) = disp dep Disp.<+> dispFlags (unFlagAssignment flags)+instance Pretty WorldPkgInfo where+  pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)     where       dispFlags [] = Disp.empty       dispFlags fs = Disp.text "--flags="                   <<>> Disp.doubleQuotes (flagAssToDoc fs)       flagAssToDoc = foldr (\(fname,val) flagAssDoc ->                              (if not val then Disp.char '-'-                                         else Disp.empty)+                                         else Disp.char '+')                              <<>> Disp.text (unFlagName fname)                              Disp.<+> flagAssDoc)                            Disp.empty-  parse = do-      dep <- parse-      Parse.skipSpaces-      flagAss <- Parse.option mempty parseFlagAssignment++instance Parsec WorldPkgInfo where+  parsec = do+      dep <- parsec+      P.spaces+      flagAss <- P.option mempty parseFlagAssignment       return $ WorldPkgInfo dep flagAss     where-      parseFlagAssignment :: Parse.ReadP r FlagAssignment+      parseFlagAssignment :: CabalParsing m => m FlagAssignment       parseFlagAssignment = do-          _ <- Parse.string "--flags"-          Parse.skipSpaces-          _ <- Parse.char '='-          Parse.skipSpaces-          mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag)+          _ <- P.string "--flags="+          inDoubleQuotes parsecFlagAssignmentNonEmpty         where-          inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a-          inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')--          flag = do-            Parse.skipSpaces-            val <- negative Parse.+++ positive-            name <- ident-            Parse.skipSpaces-            return (mkFlagName name,val)-          negative = do-            _ <- Parse.char '-'-            return False-          positive = return True--          ident :: Parse.ReadP r String-          ident = do-            -- First character must be a letter/digit to avoid flags-            -- like "+-debug":-            c  <- Parse.satisfy Char.isAlphaNum-            cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'-                                                         || ch == '-')-            return (c:cs)+          inDoubleQuotes = P.between (P.char '"') (P.char '"')
Distribution/Deprecated/ParseUtils.hs view
@@ -23,50 +23,41 @@ {-# LANGUAGE Rank2Types #-} module Distribution.Deprecated.ParseUtils (         LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,-        runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,-        Field(..), fName, lineNo,-        FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,-        showFields, showSingleNamedField, showSimpleSingleNamedField,-        parseFields, parseFieldsFlat,-        parseHaskellString, parseFilePathQ, parseTokenQ, parseTokenQ',-        parseModuleNameQ,-        parseFlagAssignment,-        parseOptVersion, parsePackageName,-        parseSepList, parseCommaList, parseOptCommaList,-        showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,+        runP, runE, ParseResult(..), parseFail, showPWarning,+        Field(..), lineNo,+        FieldDescr(..), readFields, readFieldsFlat,+        parseHaskellString, parseFilePathQ, parseTokenQ,+        parseOptCommaList,+        showFilePath, showToken, showFreeText,         field, simpleField, listField, listFieldWithSep, spaceListField,-        commaListField, commaListFieldWithSep, commaNewLineListField, newLineListField,-        optsField, liftField, boolField, parseQuoted, parseMaybeQuoted,+        newLineListField,+        liftField,         readPToMaybe, -        UnrecFieldParser, warnUnrec, ignoreUnrec,+        fieldParsec, simpleFieldParsec,+        listFieldParsec,+        commaListFieldParsec,+        commaNewLineListFieldParsec,++        UnrecFieldParser,   ) where  import Distribution.Client.Compat.Prelude hiding (get) import Prelude ()  import Distribution.Deprecated.ReadP as ReadP hiding (get)-import Distribution.Deprecated.Text -import Distribution.Compat.Newtype-import Distribution.Compiler-import Distribution.ModuleName-import Distribution.Parsec.Newtypes (TestedWith (..)) import Distribution.Pretty import Distribution.ReadE import Distribution.Utils.Generic-import Distribution.Version-import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment)  import Data.Tree as Tree (Tree (..), flatten) import System.FilePath  (normalise)-import Text.PrettyPrint-       (Doc, Mode (..), colon, comma, fsep, hsep, isEmpty, mode, nest, punctuate, render,-       renderStyle, sep, style, text, vcat, ($+$), (<+>))+import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) import qualified Text.Read as Read-import qualified Data.Map  as Map  import qualified Control.Monad.Fail as Fail+import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList)  -- ----------------------------------------------------------------------------- @@ -120,12 +111,6 @@ parseResultFail :: String -> ParseResult a parseResultFail s = parseFail (FromString s Nothing) --catchParseError :: ParseResult a -> (PError -> ParseResult a)-                -> ParseResult a-p@(ParseOk _ _) `catchParseError` _ = p-ParseFailed e `catchParseError` k   = k e- parseFail :: PError -> ParseResult a parseFail = ParseFailed @@ -188,6 +173,12 @@ field name showF readF =   FieldDescr name showF (\line val _st -> runP line name readF val) +fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a+fieldParsec name showF readF =+  FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of+    Left err -> ParseFailed (FromString err (Just line))+    Right x  -> ParseOk [] x+ -- Lift a field descriptor storing into an 'a' to a field descriptor storing -- into a 'b'. liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b@@ -205,22 +196,28 @@ simpleField name showF readF get set   = liftField get set $ field name showF readF -commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a+simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a+            -> (b -> a) -> (a -> b -> b) -> FieldDescr b+simpleFieldParsec name showF readF get set+  = liftField get set $ fieldParsec name showF readF++commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a                       -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListFieldWithSep separator name showF readF get set =+commaListFieldWithSepParsec separator name showF readF get set =    liftField get set' $-     field name showF' (parseCommaList readF)+     fieldParsec name showF' (parsecLeadingCommaList readF)    where      set' xs b = set (get b ++ xs) b      showF'    = separator . punctuate comma . map showF -commaListField :: String -> (a -> Doc) -> ReadP [a] a+commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListField = commaListFieldWithSep fsep+commaListFieldParsec = commaListFieldWithSepParsec fsep -commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaNewLineListField = commaListFieldWithSep sep+commaNewLineListFieldParsec+    :: String -> (a -> Doc) ->  ParsecParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaNewLineListFieldParsec = commaListFieldWithSepParsec sep  spaceListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b@@ -246,83 +243,23 @@     set' xs b = set (get b ++ xs) b     showF'    = separator . map showF +listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldWithSepParsec separator name showF readF get set =+  liftField get set' $+    fieldParsec name showF' (parsecLeadingOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF+ listField :: String -> (a -> Doc) -> ReadP [a] a           -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listField = listFieldWithSep fsep -optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])])-             -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b-optsField name flavor get set =-   liftField (fromMaybe [] . lookup flavor . get)-             (\opts b -> set (reorder (update flavor opts (get b))) b) $-        field name showF (sepBy parseTokenQ' (munch1 isSpace))-  where-        update _ opts l | all null opts = l  --empty opts as if no opts-        update f opts [] = [(f,opts)]-        update f opts ((f',opts'):rest)-           | f == f'   = (f, opts' ++ opts) : rest-           | otherwise = (f',opts') : update f opts rest-        reorder = sortBy (comparing fst)-        showF   = hsep . map text---- TODO: this is a bit smelly hack. It's because we want to parse bool fields---       liberally but not accept new parses. We cannot do that with ReadP---       because it does not support warnings. We need a new parser framework!-boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b-boolField name get set = liftField get set (FieldDescr name showF readF)-  where-    showF = text . show-    readF line str _-      |  str == "True"  = ParseOk [] True-      |  str == "False" = ParseOk [] False-      | lstr == "true"  = ParseOk [caseWarning] True-      | lstr == "false" = ParseOk [caseWarning] False-      | otherwise       = ParseFailed (NoParse name line)-      where-        lstr = lowercase str-        caseWarning = PWarning $-          "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."--ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x =-   vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]-showFields :: [FieldDescr a] -> a -> String-showFields fields = render . ($+$ text "") . ppFields fields--showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)-showSingleNamedField fields f =-  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of-    []      -> Nothing-    (get:_) -> Just (render . ppField f . get)--showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)-showSimpleSingleNamedField fields f =-  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of-    []      -> Nothing-    (get:_) -> Just (renderStyle myStyle . get)- where myStyle = style { mode = LeftMode }--parseFields :: [FieldDescr a] -> a -> String -> ParseResult a-parseFields fields initial str =-  readFields str >>= accumFields fields initial--parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a-parseFieldsFlat fields initial str =-  readFieldsFlat str >>= accumFields fields initial--accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a-accumFields fields = foldM setField-  where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (F line name value) = case Map.lookup name fieldMap of-      Just (FieldDescr _ _ set) -> set line value accum-      Nothing -> do-        warning ("Unrecognized field " ++ name ++ " on line " ++ show line)-        return accum-    setField accum f = do-      warning ("Unrecognized stanza on line " ++ show (lineNo f))-      return accum+listFieldParsec+    :: String -> (a -> Doc) -> ParsecParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldParsec = listFieldWithSepParsec fsep  -- | The type of a function which, given a name-value pair of an --   unrecognized field, and the current structure being built,@@ -331,17 +268,6 @@ --   of the structure being built), or not (by returning Nothing). type UnrecFieldParser a = (String,String) -> a -> Maybe a --- | A default unrecognized field parser which simply returns Nothing,---   i.e. ignores all unrecognized fields, so warnings will be generated.-warnUnrec :: UnrecFieldParser a-warnUnrec _ _ = Nothing---- | A default unrecognized field parser which silently (i.e. no---   warnings will be generated) ignores unrecognized fields, by---   returning the structure being built unmodified.-ignoreUnrec :: UnrecFieldParser a-ignoreUnrec _ = Just- ------------------------------------------------------------------------------  -- The data type for our three syntactic categories@@ -375,11 +301,6 @@ lineNo (Section n _ _ _) = n lineNo (IfBlock n _ _ _) = n -fName :: Field -> String-fName (F _ n _) = n-fName (Section _ n _ _) = n-fName _ = error "fname: not a field or section"- readFields :: String -> ParseResult [Field] readFields input = ifelse                =<< traverse (mkField 0)@@ -603,26 +524,11 @@  ------------------------------------------------------------------------------ --- |parse a module name-parseModuleNameQ :: ReadP r ModuleName-parseModuleNameQ = parseMaybeQuoted parse- parseFilePathQ :: ReadP r FilePath parseFilePathQ = parseTokenQ   -- removed until normalise is no longer broken, was:   --   liftM normalise parseTokenQ -betweenSpaces :: ReadP r a -> ReadP r a-betweenSpaces act = do skipSpaces-                       res <- act-                       skipSpaces-                       return res--parseOptVersion :: ReadP r Version-parseOptVersion = parseMaybeQuoted ver-  where ver :: ReadP r Version-        ver = parse <++ return nullVersion- -- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a -- because the "compat" version of ReadP isn't quite powerful enough.  In -- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a@@ -639,23 +545,10 @@ parseTokenQ :: ReadP r String parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') -parseTokenQ' :: ReadP r String-parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace)--parseSepList :: ReadP r b-             -> ReadP r a -- ^The parser for the stuff between commas-             -> ReadP r [a]-parseSepList sepr p = sepBy p separator-    where separator = betweenSpaces sepr- parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas                -> ReadP r [a] parseSpaceList p = sepBy p skipSpaces -parseCommaList :: ReadP r a -- ^The parser for the stuff between commas-               -> ReadP r [a]-parseCommaList = parseSepList (ReadP.char ',')- -- This version avoid parse ambiguity for list element parsers -- that have multiple valid parses of prefixes. parseOptCommaList :: ReadP r a -> ReadP r [a]@@ -665,60 +558,6 @@     localSep = (skipSpaces >> char ',' >> skipSpaces)       +++ (satisfy isSpace >> skipSpaces) -parseQuoted :: ReadP r a -> ReadP r a-parseQuoted = between (ReadP.char '"') (ReadP.char '"')--parseMaybeQuoted :: (forall r. ReadP r a) -> ReadP r' a-parseMaybeQuoted p = parseQuoted p <++ p--parseFreeText :: ReadP.ReadP s String-parseFreeText = ReadP.munch (const True)- readPToMaybe :: ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str                                      , all isSpace s ]--ppField :: String -> Doc -> Doc-ppField name fielddoc-   | isEmpty fielddoc         = mempty-   | name `elem` nestedFields = text name <<>> colon $+$ nest indentWith fielddoc-   | otherwise                = text name <<>> colon <+> fielddoc-   where-      indentWith = 4-      nestedFields =-         [ "description"-         , "build-depends"-         , "data-files"-         , "extra-source-files"-         , "extra-tmp-files"-         , "exposed-modules"-         , "asm-sources"-         , "cmm-sources"-         , "c-sources"-         , "js-sources"-         , "extra-libraries"-         , "includes"-         , "install-includes"-         , "other-modules"-         , "autogen-modules"-         , "depends"-         ]--parseFlagAssignment :: ReadP r FlagAssignment-parseFlagAssignment = mkFlagAssignment <$>-                      sepBy parseFlagValue skipSpaces1-  where-    parseFlagValue =-          (do optional (char '+')-              f <- parse-              return (f, True))-      +++ (do _ <- char '-'-              f <- parse-              return (f, False))------------------------------------------------------------------------------------ Internal----------------------------------------------------------------------------------showTestedWith :: (CompilerFlavor, VersionRange) -> Doc-showTestedWith = pretty . pack' TestedWith
− Distribution/Deprecated/Text.hs 
@@ -1,409 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Deprecated.Text--- Copyright   :  Duncan Coutts 2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ classes. The difference is that it uses a modern pretty printer and parser--- system and the format is not expected to be Haskell concrete syntax but--- rather the external human readable representation used by Cabal.----module Distribution.Deprecated.Text (-  Text(..),-  defaultStyle,-  display,-  flatStyle,-  simpleParse,-  stdParse,-  -- parse utils-  parsePackageName,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude (read)--import           Distribution.Deprecated.ReadP ((<++))-import qualified Distribution.Deprecated.ReadP as Parse--import           Distribution.Parsec-import           Distribution.Pretty-import qualified Text.PrettyPrint          as Disp--import qualified Data.Set as Set--import Data.Version (Version (Version))--import qualified Distribution.Compiler                       as D-import qualified Distribution.License                        as D-import qualified Distribution.ModuleName                     as D-import qualified Distribution.Package                        as D-import qualified Distribution.PackageDescription             as D-import qualified Distribution.Simple.Setup                   as D-import qualified Distribution.System                         as D-import qualified Distribution.Types.PackageVersionConstraint as D-import qualified Distribution.Types.SourceRepo               as D-import qualified Distribution.Types.UnqualComponentName      as D-import qualified Distribution.Version                        as D-import qualified Distribution.Types.VersionRange.Internal    as D-import qualified Language.Haskell.Extension                  as E---- | /Note:/ this class will soon be deprecated.--- It's not yet, so that we are @-Wall@ clean.-class Text a where-  disp  :: a -> Disp.Doc-  default disp :: Pretty a => a -> Disp.Doc-  disp = pretty--  parse :: Parse.ReadP r a-  default parse :: Parsec a => Parse.ReadP r a-  parse = parsec---- | Pretty-prints with the default style.-display :: Text a => a -> String-display = Disp.renderStyle defaultStyle . disp--simpleParse :: Text a => String -> Maybe a-simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str-                       , all isSpace s ] of-  []    -> Nothing-  (p:_) -> Just p--stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res-stdParse f = do-  cs   <- Parse.sepBy1 component (Parse.char '-')-  _    <- Parse.char '-'-  ver  <- parse-  let name = intercalate "-" cs-  return $! f ver (lowercase name)-  where-    component = do-      cs <- Parse.munch1 isAlphaNum-      if all isDigit cs then Parse.pfail else return cs-      -- each component must contain an alphabetic character, to avoid-      -- ambiguity in identifiers like foo-1 (the 1 is the version number).--lowercase :: String -> String-lowercase = map toLower---- -------------------------------------------------------------------------------- Instances for types from the base package--instance Text Bool where-  parse = Parse.choice [ (Parse.string "True" Parse.+++-                          Parse.string "true") >> return True-                       , (Parse.string "False" Parse.+++-                          Parse.string "false") >> return False ]--instance Text Int where-  parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat--instance Text a => Text (Identity a) where-    disp = disp . runIdentity-    parse = fmap Identity parse---- | Parser for non-negative integers.-parseNat :: Parse.ReadP r Int-parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse---instance Text Version where-  disp (Version branch _tags)     -- Death to version tags!!-    = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))--  parse = do-      branch <- Parse.sepBy1 parseNat (Parse.char '.')-                -- allow but ignore tags:-      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)-      return (Version branch [])------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------instance Text D.Arch where-  parse = fmap (D.classifyArch D.Strict) ident--instance Text D.BuildType where-  parse = do-    name <- Parse.munch1 isAlphaNum-    case name of-      "Simple"    -> return D.Simple-      "Configure" -> return D.Configure-      "Custom"    -> return D.Custom-      "Make"      -> return D.Make-      "Default"   -> return D.Custom-      _           -> fail ("unknown build-type: '" ++ name ++ "'")--instance Text D.CompilerFlavor where-  parse = do-    comp <- Parse.munch1 isAlphaNum-    when (all isDigit comp) Parse.pfail-    return (D.classifyCompilerFlavor comp)--instance Text D.CompilerId where-  parse = do-    flavour <- parse-    version <- (Parse.char '-' >> parse) Parse.<++ return D.nullVersion-    return (D.CompilerId flavour version)--instance Text D.ComponentId where-  parse = D.mkComponentId `fmap` Parse.munch1 abi_char-   where abi_char c = isAlphaNum c || c `elem` "-_."--instance Text D.DefUnitId where-  parse = D.unsafeMkDefUnitId `fmap` parse--instance Text D.UnitId where-    parse = D.mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")--instance Text D.Dependency where-  parse = do name <- parse-             Parse.skipSpaces-             libs <- Parse.option [D.LMainLibName]-                   $ (Parse.char ':' *>)-                   $ pure <$> parseLib name <|> parseMultipleLibs name-             Parse.skipSpaces-             ver <- parse Parse.<++ return D.anyVersion-             Parse.skipSpaces-             return $ D.Dependency name ver $ Set.fromList libs-    where makeLib pn ln | D.unPackageName pn == ln = D.LMainLibName-                        | otherwise = D.LSubLibName $ D.mkUnqualComponentName ln-          parseLib pn = makeLib pn <$> parsecUnqualComponentName-          parseMultipleLibs pn = Parse.between (Parse.char '{' *> Parse.skipSpaces)-                                         (Parse.skipSpaces <* Parse.char '}')-                                         $ parsecCommaList $ parseLib pn---instance Text E.Extension where-  parse = do-    extension <- Parse.munch1 isAlphaNum-    return (E.classifyExtension extension)--instance Text D.FlagName where-    -- Note:  we don't check that FlagName doesn't have leading dash,-    -- cabal check will do that.-    parse = D.mkFlagName . lowercase <$> parse'-      where-        parse' = (:) <$> lead <*> rest-        lead = Parse.satisfy (\c ->  isAlphaNum c || c == '_')-        rest = Parse.munch (\c -> isAlphaNum c ||  c == '_' || c == '-')--instance Text D.HaddockTarget where-    parse = Parse.choice [ Parse.string "for-hackage"     >> return D.ForHackage-                         , Parse.string "for-development" >> return D.ForDevelopment]--instance Text E.Language where-  parse = do-    lang <- Parse.munch1 isAlphaNum-    return (E.classifyLanguage lang)--instance Text D.License where-  parse = do-    name    <- Parse.munch1 (\c -> isAlphaNum c && c /= '-')-    version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)-    return $! case (name, version :: Maybe D.Version) of-      ("GPL",               _      ) -> D.GPL  version-      ("LGPL",              _      ) -> D.LGPL version-      ("AGPL",              _      ) -> D.AGPL version-      ("BSD2",              Nothing) -> D.BSD2-      ("BSD3",              Nothing) -> D.BSD3-      ("BSD4",              Nothing) -> D.BSD4-      ("ISC",               Nothing) -> D.ISC-      ("MIT",               Nothing) -> D.MIT-      ("MPL",         Just version') -> D.MPL version'-      ("Apache",            _      ) -> D.Apache version-      ("PublicDomain",      Nothing) -> D.PublicDomain-      ("AllRightsReserved", Nothing) -> D.AllRightsReserved-      ("OtherLicense",      Nothing) -> D.OtherLicense-      _                              -> D.UnknownLicense $ name ++-                                        maybe "" (('-':) . display) version--instance Text D.Module where-    parse = do-        uid <- parse-        _ <- Parse.char ':'-        mod_name <- parse-        return (D.Module uid mod_name)--instance Text D.ModuleName where-  parse = do-    ms <- Parse.sepBy1 component (Parse.char '.')-    return (D.fromComponents ms)--    where-      component = do-        c  <- Parse.satisfy isUpper-        cs <- Parse.munch validModuleChar-        return (c:cs)--instance Text D.OS where-  parse = fmap (D.classifyOS D.Compat) ident--instance Text D.PackageVersionConstraint where-  parse = do name <- parse-             Parse.skipSpaces-             ver <- parse Parse.<++ return D.anyVersion-             Parse.skipSpaces-             return (D.PackageVersionConstraint name ver)--instance Text D.PkgconfigName where-  parse = D.mkPkgconfigName-          <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._")--instance Text D.Platform where-  -- TODO: there are ambigious platforms like: `arch-word-os`-  -- which could be parsed as-  --   * Platform "arch-word" "os"-  --   * Platform "arch" "word-os"-  -- We could support that preferring variants 'OtherOS' or 'OtherArch'-  ---  -- For now we split into arch and os parts on the first dash.-  parse = do-    arch <- parseDashlessArch-    _ <- Parse.char '-'-    os   <- parse-    return (D.Platform arch os)-      where-        parseDashlessArch :: Parse.ReadP r D.Arch-        parseDashlessArch = fmap (D.classifyArch D.Strict) dashlessIdent--        dashlessIdent :: Parse.ReadP r String-        dashlessIdent = liftM2 (:) firstChar rest-          where firstChar = Parse.satisfy isAlpha-                rest = Parse.munch (\c -> isAlphaNum c || c == '_')--instance Text D.RepoKind where-  parse = fmap D.classifyRepoKind ident--instance Text D.RepoType where-  parse = fmap D.classifyRepoType ident--instance Text D.UnqualComponentName where-  parse = D.mkUnqualComponentName <$> parsePackageName--instance Text D.PackageIdentifier where-  parse = do-    n <- parse-    v <- (Parse.char '-' >> parse) <++ return D.nullVersion-    return (D.PackageIdentifier n v)--instance Text D.PackageName where-  parse = D.mkPackageName <$> parsePackageName--instance Text D.Version where-  parse = do-      branch <- Parse.sepBy1 parseNat (Parse.char '.')-                -- allow but ignore tags:-      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)-      return (D.mkVersion branch)--instance Text D.VersionRange where-  parse = expr-   where-        expr   = do Parse.skipSpaces-                    t <- term-                    Parse.skipSpaces-                    (do _  <- Parse.string "||"-                        Parse.skipSpaces-                        e <- expr-                        return (D.unionVersionRanges t e)-                     Parse.+++-                     return t)-        term   = do f <- factor-                    Parse.skipSpaces-                    (do _  <- Parse.string "&&"-                        Parse.skipSpaces-                        t <- term-                        return (D.intersectVersionRanges f t)-                     Parse.+++-                     return f)-        factor = Parse.choice $ parens expr-                              : parseAnyVersion-                              : parseNoVersion-                              : parseWildcardRange-                              : map parseRangeOp rangeOps-        parseAnyVersion    = Parse.string "-any" >> return D.anyVersion-        parseNoVersion     = Parse.string "-none" >> return D.noVersion--        parseWildcardRange = do-          _ <- Parse.string "=="-          Parse.skipSpaces-          branch <- Parse.sepBy1 digits (Parse.char '.')-          _ <- Parse.char '.'-          _ <- Parse.char '*'-          return (D.withinVersion (D.mkVersion branch))--        parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)-                                 (Parse.char ')' >> Parse.skipSpaces)-                                 (do a <- p-                                     Parse.skipSpaces-                                     return (D.VersionRangeParens a))-        digits = do-          firstDigit <- Parse.satisfy isDigit-          if firstDigit == '0'-            then return 0-            else do rest <- Parse.munch isDigit-                    return (read (firstDigit : rest)) -- TODO: eradicateNoParse--        parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse-        rangeOps = [ ("<",  D.earlierVersion),-                     ("<=", D.orEarlierVersion),-                     (">",  D.laterVersion),-                     (">=", D.orLaterVersion),-                     ("^>=", D.majorBoundVersion),-                     ("==", D.thisVersion) ]------------------------------------------------------------------------------------ ParseUtils----------------------------------------------------------------------------------parsePackageName :: Parse.ReadP r String-parsePackageName = do-  ns <- Parse.sepBy1 component (Parse.char '-')-  return $ intercalate "-" ns-  where-    component = do-      cs <- Parse.munch1 isAlphaNum-      if all isDigit cs then Parse.pfail else return cs-      -- each component must contain an alphabetic character, to avoid-      -- ambiguity in identifiers like foo-1 (the 1 is the version number).---ident :: Parse.ReadP r String-ident = liftM2 (:) firstChar rest-  where firstChar = Parse.satisfy isAlpha-        rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')--validModuleChar :: Char -> Bool-validModuleChar c = isAlphaNum c || c == '_' || c == '\''------------------------------------------------------------------------------------ Rest of instances, we don't seem to need------------------------------------------------------------------------------------ instance Text D.AbiDependency--- instance Text D.AbiHash--- instance Text D.AbiTa--- instance Text D.BenchmarkType--- instance Text D.ExecutableScope--- instance Text D.ExeDependency--- instance Text D.ExposedModule--- instance Text D.ForeignLibOption--- instance Text D.ForeignLibType--- instance Text D.IncludeRenaming--- instance Text D.KnownExtension--- instance Text D.LegacyExeDependency--- instance Text D.LibVersionInfo--- instance Text D.License--- instance Text D.Mixin--- instance Text D.ModuleReexport--- instance Text D.ModuleRenaming--- instance Text D.MungedPackageName--- instance Text D.OpenModule--- instance Text D.OpenUnitId--- instance Text D.PackageVersionConstraint--- instance Text D.PkgconfigDependency--- instance Text D.TestType
Distribution/Deprecated/ViewAsFieldDescr.hs view
@@ -6,8 +6,6 @@ import Prelude ()  import qualified Data.List.NonEmpty as NE-import Distribution.Parsec   (parsec)-import Distribution.Pretty import Distribution.ReadE          (parsecToReadE) import Distribution.Simple.Command import Text.PrettyPrint            (cat, comma, punctuate, text)
Distribution/Solver/Modular.hs view
@@ -17,7 +17,6 @@  import qualified Data.Map as M import Data.Set (isSubsetOf)-import Data.Ord import Distribution.Compat.Graph          ( IsNode(..) ) import Distribution.Compiler
Distribution/Solver/Modular/Assignment.hs view
@@ -9,11 +9,12 @@ import Prelude () import Distribution.Solver.Compat.Prelude hiding (pi) -import Data.Array as A-import Data.List as L-import Data.Map as M-import Data.Maybe+import qualified Data.Array as A+import qualified Data.List as L+import qualified Data.Map as M +import Data.Maybe (fromJust)+ import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal  import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)@@ -79,7 +80,7 @@     -- Dependencies per package.     depp :: QPN -> [(Component, PI QPN)]     depp qpn = let v :: Vertex-                   v   = fromJust (cvm qpn)+                   v   = fromJust (cvm qpn) -- TODO: why this is safe?                    dvs :: [(Component, Vertex)]                    dvs = tg A.! v                in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs
Distribution/Solver/Modular/Builder.hs view
@@ -19,10 +19,10 @@ -- flag-guarded dependencies, we cannot introduce them immediately. Instead, we -- store the entire dependency. -import Data.List as L-import Data.Map as M-import Data.Set as S-import Prelude hiding (sequence, mapM)+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S+import Prelude  import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency@@ -55,7 +55,7 @@ }  -- | Map of available linking targets.-type LinkingState = Map (PN, I) [PackagePath]+type LinkingState = M.Map (PN, I) [PackagePath]  -- | Extend the set of open goals with the new goals listed. --
Distribution/Solver/Modular/Dependency.hs view
@@ -55,6 +55,7 @@  import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath+import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName @@ -131,7 +132,9 @@  -- | A component that can be depended upon by another package, i.e., a library -- or an executable.-data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName+data ExposedComponent =+    ExposedLib LibraryName+  | ExposedExe UnqualComponentName   deriving (Eq, Ord, Show)  -- | The reason that a dependency is active. It identifies the package and any@@ -185,7 +188,7 @@     -- Suppose package B has a setup dependency on package A.     -- This will be recorded as something like     ---    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" ExposedLib) (Constrained AnyVersion))+    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion))     --     -- Observe that when we qualify this dependency, we need to turn that     -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier@@ -199,7 +202,7 @@     goD (Pkg pkn vr)  _    = Pkg pkn vr     goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =         Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci-    goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp+    goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp       | qBase qpn   = Dep (Q (PackagePath ns (QualBase  pn)) <$> dep) ci       | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci       | otherwise   = Dep (Q (PackagePath ns inheritedQ    ) <$> dep) ci
Distribution/Solver/Modular/Explore.hs view
@@ -3,13 +3,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Explore (backjumpAndExplore) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import qualified Distribution.Solver.Types.Progress as P -import Data.Foldable as F-import Data.List as L (foldl')-import Data.Maybe (fromMaybe)-import Data.Map.Strict as M-import Data.Set as S+import qualified Data.List as L (foldl')+import qualified Data.Map.Strict as M+import qualified Data.Set as S  import Distribution.Simple.Setup (asBool) @@ -81,7 +82,7 @@          -> ExploreState -> ConflictSetLog a backjump mbj enableBj fineGrainedConflicts couldResolveConflicts          logSkippedChoice var lastCS xs =-    F.foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing+    foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing   where     combine :: (k, ExploreState -> ConflictSetLog a)             -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a)@@ -269,7 +270,7 @@     -- to be merged with the previous one.     couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet     couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =-      let (PInfo deps _ _ _) = idx ! pn ! i+      let (PInfo deps _ _ _) = idx M.! pn M.! i           qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps            couldBeResolved :: CS.Conflict -> Maybe ConflictSet@@ -277,7 +278,7 @@           couldBeResolved (CS.GoalConflict conflictingDep) =               -- Check whether this package instance also has 'conflictingDep'               -- as a dependency (ignoring flag and stanza choices).-              if F.null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]+              if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]               then Nothing               else Just CS.empty           couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) =
Distribution/Solver/Modular/Index.hs view
@@ -1,15 +1,19 @@ module Distribution.Solver.Modular.Index     ( Index     , PInfo(..)+    , ComponentInfo(..)+    , IsVisible(..)     , IsBuildable(..)     , defaultQualifyOptions     , mkIndex     ) where -import Data.List as L-import Data.Map as M import Prelude hiding (pi) +import Data.Map (Map)+import qualified Data.List as L+import qualified Data.Map as M+ import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package@@ -28,10 +32,25 @@ -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason)+data PInfo = PInfo (FlaggedDeps PN)+                   (Map ExposedComponent ComponentInfo)+                   FlagInfo+                   (Maybe FailReason) +-- | Info associated with each library and executable in a package instance.+data ComponentInfo = ComponentInfo {+    compIsVisible   :: IsVisible+  , compIsBuildable :: IsBuildable+  }+  deriving Show++-- | Whether a component is visible in the current environment.+newtype IsVisible = IsVisible Bool+  deriving (Eq, Show)+ -- | Whether a component is made unbuildable by a "buildable: False" field. newtype IsBuildable = IsBuildable Bool+  deriving (Eq, Show)  mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
Distribution/Solver/Modular/IndexConversion.hs view
@@ -2,30 +2,28 @@     ( convPIs     ) where -import Data.List as L-import Data.Map.Strict (Map)+import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Data.List as L import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid as Mon-import Data.Set as S+import qualified Distribution.Compat.NonEmptySet as NonEmptySet+import qualified Data.Set as S +import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Compiler-import Distribution.InstalledPackageInfo as IPI import Distribution.Package                          -- from Cabal import Distribution.Simple.BuildToolDepends          -- from Cabal-import Distribution.Simple.Utils (cabalVersion)      -- from Cabal import Distribution.Types.ExeDependency              -- from Cabal import Distribution.Types.PkgconfigDependency        -- from Cabal import Distribution.Types.ComponentName              -- from Cabal-import Distribution.Types.UnqualComponentName        -- from Cabal import Distribution.Types.CondTree                   -- from Cabal import Distribution.Types.MungedPackageId            -- from Cabal import Distribution.Types.MungedPackageName          -- from Cabal-import Distribution.PackageDescription as PD         -- from Cabal-import Distribution.PackageDescription.Configuration as PDC+import Distribution.PackageDescription               -- from Cabal+import Distribution.PackageDescription.Configuration import qualified Distribution.Simple.PackageIndex as SI import Distribution.System-import Distribution.Types.ForeignLib  import           Distribution.Solver.Types.ComponentDeps                    ( Component(..), componentNameToComponent )@@ -81,26 +79,33 @@       | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))     shadow x                                     = x --- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I.-convId :: InstalledPackageInfo -> (PN, I)+-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.+convId :: IPI.InstalledPackageInfo -> (PN, I) convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)   where MungedPackageId mpn ver = mungedId ipi         -- HACK. See Note [Index conversion with internal libraries]         pn = encodeCompatPackageName mpn  -- | Convert a single installed package into the solver-specific format.-convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi =-  case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of-        Nothing  -> (pn, i, PInfo [] M.empty M.empty (Just Broken))-        Just fds -> ( pn-                    , i-                    , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing)+  case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of+        Left u    -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))+        Right fds -> (pn, i, PInfo fds components M.empty Nothing)  where+  -- TODO: Handle sub-libraries and visibility.+  components =+      M.singleton (ExposedLib LMainLibName)+                  ComponentInfo {+                      compIsVisible = IsVisible True+                    , compIsBuildable = IsBuildable True+                    }+   (pn, i) = convId ipi+   -- 'sourceLibName' is unreliable, but for now we only really use this for   -- primary libs anyways-  comp = componentNameToComponent $ CLibName $ sourceLibName ipi+  comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi -- TODO: Installed packages should also store their encapsulations!  -- Note [Index conversion with internal libraries]@@ -136,12 +141,13 @@ -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored.-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep PN)+convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) convIPId dr comp idx ipid =   case SI.lookupUnitId idx ipid of-    Nothing  -> Nothing+    Nothing  -> Left ipid     Just ipi -> let (pn, i) = convId ipi-                in  Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (Fixed i))) comp)+                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.+                in  Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)                 -- NB: something we pick up from the                 -- InstalledPackageIndex is NEVER an executable @@ -170,24 +176,16 @@         -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription         -> PInfo convGPD os arch cinfo constraints strfl solveExes pn-        (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =+        (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =   let     fds  = flagInfo strfl flags -    -- | We have to be careful to filter out dependencies on-    -- internal libraries, since they don't refer to real packages-    -- and thus cannot actually be solved over.  We'll do this-    -- by creating a set of package names which are "internal"-    -- and dropping them as we convert. -    ipns = S.fromList $ [ unqualComponentNameToPackageName nm-                        | (nm, _) <- sub_libs ]--    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->+    conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->             CondTree ConfVar [Dependency] a -> FlaggedDeps PN     conv comp getInfo dr =-        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo ipns solveExes .-        PDC.addBuildableCondition getInfo+        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .+        addBuildableCondition getInfo      initDR = DependencyReason pn M.empty S.empty @@ -207,63 +205,59 @@     addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn     addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) -    -- | We infer the maximally supported spec-version from @lib:Cabal@'s version-    ---    -- As we cannot predict the future, we can only properly support-    -- spec-versions predating (and including) the @lib:Cabal@ version-    -- used by @cabal-install@.-    ---    -- This relies on 'cabalVersion' having always at least 3 components to avoid-    -- comparisons like @2.0.0 > 2.0@ which would result in confusing results.-    ---    -- NOTE: Before we can switch to a /normalised/ spec-version-    -- comparison (e.g. by truncating to 3 components, and removing-    -- trailing zeroes) we'd have to make sure all other places where-    -- the spec-version is compared against a bound do it-    -- consistently.-    maxSpecVer = cabalVersion--    -- | Required/declared spec-version of the package-    ---    -- We don't truncate patch-levels, as specifying a patch-level-    -- spec-version is discouraged and not supported anymore starting-    -- with spec-version 2.2.-    reqSpecVer = specVersion pkg-     -- | A too-new specVersion is turned into a global 'FailReason'     -- which prevents the solver from selecting this release (and if     -- forced to, emit a meaningful solver error message).-    fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)-       | otherwise               = Nothing+    fr = case scannedVersion of+        Just ver -> Just (UnsupportedSpecVer ver)+        Nothing  -> Nothing -    components :: Map ExposedComponent IsBuildable-    components = M.fromList $ libComps ++ exeComps+    components :: Map ExposedComponent ComponentInfo+    components = M.fromList $ libComps ++ subLibComps ++ exeComps       where-        libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib)+        libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib)                    | lib <- maybeToList mlib ]-        exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe)+        subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib)+                      | (name, lib) <- sub_libs ]+        exeComps = [ ( ExposedExe name+                     , ComponentInfo {+                           compIsVisible = IsVisible True+                         , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False+                         }+                     )                    | (name, exe) <- exes ]-        isBuildable = isBuildableComponent os arch cinfo constraints +        libToComponentInfo lib =+            ComponentInfo {+                compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True+              , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False+              }++        testCondition = testConditionForComponent os arch cinfo constraints++        isPrivate LibraryVisibilityPrivate = True+        isPrivate LibraryVisibilityPublic  = False+   in PInfo flagged_deps components fds fr --- | Returns true if the component is buildable in the given environment.--- This function can give false-positives. For example, it only considers flags--- that are set by unqualified flag constraints, and it doesn't check whether--- the intra-package dependencies of a component are buildable. It is also--- possible for the solver to later assign a value to an automatic flag that--- makes the component unbuildable.-isBuildableComponent :: OS-                     -> Arch-                     -> CompilerInfo-                     -> [LabeledPackageConstraint]-                     -> (a -> BuildInfo)-                     -> CondTree ConfVar [Dependency] a-                     -> Bool-isBuildableComponent os arch cinfo constraints getInfo tree =-    case simplifyCondition $ extractCondition (buildable . getInfo) tree of-      Lit False -> False-      _         -> True+-- | Applies the given predicate (for example, testing buildability or+-- visibility) to the given component and environment. Values are combined with+-- AND. This function returns 'Nothing' when the result cannot be determined+-- before dependency solving. Additionally, this function only considers flags+-- that are set by unqualified flag constraints, and it doesn't check the+-- intra-package dependencies of a component.+testConditionForComponent :: OS+                          -> Arch+                          -> CompilerInfo+                          -> [LabeledPackageConstraint]+                          -> (a -> Bool)+                          -> CondTree ConfVar [Dependency] a+                          -> Maybe Bool+testConditionForComponent os arch cinfo constraints p tree =+    case go $ extractCondition p tree of+      Lit True  -> Just True+      Lit False -> Just False+      _         -> Nothing   where     flagAssignment :: [(FlagName, Bool)]     flagAssignment =@@ -274,10 +268,10 @@     -- Simplify the condition, using the current environment. Most of this     -- function was copied from convBranch and     -- Distribution.Types.Condition.simplifyCondition.-    simplifyCondition :: Condition ConfVar -> Condition ConfVar-    simplifyCondition (Var (OS os')) = Lit (os == os')-    simplifyCondition (Var (Arch arch')) = Lit (arch == arch')-    simplifyCondition (Var (Impl cf cvr))+    go :: Condition ConfVar -> Condition ConfVar+    go (Var (OS os')) = Lit (os == os')+    go (Var (Arch arch')) = Lit (arch == arch')+    go (Var (Impl cf cvr))         | matchImpl (compilerInfoId cinfo) ||               -- fixme: Nothing should be treated as unknown, rather than empty               --        list. This code should eventually be changed to either@@ -287,24 +281,24 @@         | otherwise = Lit False       where         matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv-    simplifyCondition (Var (Flag f))+    go (Var (PackageFlag f))         | Just b <- L.lookup f flagAssignment = Lit b-    simplifyCondition (Var v) = Var v-    simplifyCondition (Lit b) = Lit b-    simplifyCondition (CNot c) =-        case simplifyCondition c of+    go (Var v) = Var v+    go (Lit b) = Lit b+    go (CNot c) =+        case go c of           Lit True -> Lit False           Lit False -> Lit True           c' -> CNot c'-    simplifyCondition (COr c d) =-        case (simplifyCondition c, simplifyCondition d) of+    go (COr c d) =+        case (go c, go d) of           (Lit False, d') -> d'           (Lit True, _)   -> Lit True           (c', Lit False) -> c'           (_, Lit True)   -> Lit True           (c', d')        -> COr c' d'-    simplifyCondition (CAnd c d) =-        case (simplifyCondition c, simplifyCondition d) of+    go (CAnd c d) =+        case (go c, go d) of           (Lit False, _) -> Lit False           (Lit True, d') -> d'           (_, Lit False) -> Lit False@@ -321,46 +315,36 @@  -- | Convert flag information. Automatic flags are now considered weak -- unless strong flags have been selected explicitly.-flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo+flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo flagInfo (StrongFlags strfl) =-    M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))+    M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))   where     weak m = WeakOrTrivial $ not (strfl || m)     flagType m = if m then Manual else Automatic --- | Internal package names, which should not be interpreted as true--- dependencies.-type IPNs = Set PN---- | Convenience function to delete a 'Dependency' if it's--- for a 'PN' that isn't actually real.-filterIPNs :: IPNs -> Dependency -> Maybe Dependency-filterIPNs ipns d@(Dependency pn _ _)-    | S.notMember pn ipns = Just d-    | otherwise           = Nothing- -- | Convert condition trees to flagged dependencies.  Mutually -- recursive with 'convBranch'.  See 'convBranch' for an explanation -- of all arguments preceding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->                 Component ->                 (a -> BuildInfo) ->-                IPNs ->                 SolveExecutables ->                 CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =+convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =              -- Merge all library and build-tool dependencies at every level in              -- the tree of flagged dependencies. Otherwise 'extractCommon'              -- could create duplicate dependencies, and the number of              -- duplicates could grow exponentially from the leaves to the root              -- of the tree.              mergeSimpleDeps $-                 L.map (\d -> D.Simple (convLibDep dr d) comp)-                       (mapMaybe (filterIPNs ipns) ds)                                -- unconditional package dependencies-              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches+                 [ D.Simple singleDep comp+                 | dep <- ds+                 , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies++              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches               -- build-tools dependencies               -- NB: Only include these dependencies if SolveExecutables               -- is True.  It might be false in the legacy solver@@ -476,14 +460,13 @@            -> FlagInfo            -> Component            -> (a -> BuildInfo)-           -> IPNs            -> SolveExecutables            -> CondBranch ConfVar [Dependency] a            -> FlaggedDeps PN-convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') =+convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =     go c'-       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes  t')-       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf')+       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes  t')+       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf')        flags dr   where     go :: Condition ConfVar@@ -495,7 +478,7 @@     go (CNot c)    t f = go c f t     go (CAnd c d)  t f = go c (go d t f) f     go (COr  c d)  t f = go c t (go d t f)-    go (Var (Flag fn)) t f = \flags' ->+    go (Var (PackageFlag fn)) t f = \flags' ->         case M.lookup fn flags' of           Just True  -> t flags'           Just False -> f flags'@@ -560,9 +543,12 @@ unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =     DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) --- | Convert a Cabal dependency on a library to a solver-specific dependency.-convLibDep :: DependencyReason PN -> Dependency -> LDep PN-convLibDep dr (Dependency pn vr _) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr)+-- | Convert a Cabal dependency on a set of library components (from a single+-- package) to solver-specific dependencies.+convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN]+convLibDeps dr (Dependency pn vr libs) =+    [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr)+    | lib <- NonEmptySet.toList libs ]  -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN@@ -571,5 +557,6 @@ -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN convSetupBuildInfo pn nfo =-    L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup)-          (PD.setupDepends nfo)+    [ D.Simple singleDep ComponentSetup+    | dep <- setupDepends nfo+    , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ]
Distribution/Solver/Modular/LabeledGraph.hs view
@@ -17,10 +17,11 @@   , topSort   ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Data.Array import Data.Graph (Vertex, Bounds)-import Data.List (sortBy)-import Data.Maybe (mapMaybe) import qualified Data.Graph as G  {-------------------------------------------------------------------------------
Distribution/Solver/Modular/Linking.hs view
@@ -13,7 +13,6 @@ import Control.Exception (assert) import Control.Monad.Reader import Control.Monad.State-import Data.Function (on) import Data.Map ((!)) import qualified Data.Map         as M import qualified Data.Set         as S@@ -267,7 +266,7 @@           Just False -> return () -- stanza not enabled; no new deps     -- For extensions and language dependencies, there is nothing to do.     -- No choice is involved, just checking, so there is nothing to link.-    -- The same goes for for pkg-config constraints.+    -- The same goes for pkg-config constraints.       (Simple (LDep _ (Ext  _))   _, _) -> return ()       (Simple (LDep _ (Lang _))   _, _) -> return ()       (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()
Distribution/Solver/Modular/Message.hs view
@@ -25,6 +25,7 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress+import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName  data Message =@@ -220,14 +221,16 @@ showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"+showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"+showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" showFR _ CannotInstall                    = " (only already installed instances can be used)" showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" showFR _ Shadowed                         = " (shadowed by another installed package with same version)"-showFR _ Broken                           = " (package is broken)"+showFR _ (Broken u)                       = " (package is broken, missing depenedency " ++ prettyShow u ++ ")" showFR _ UnknownPackage                   = " (unknown package)" showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"@@ -247,8 +250,9 @@ showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"  showExposedComponent :: ExposedComponent -> String-showExposedComponent ExposedLib = "library"-showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"+showExposedComponent (ExposedLib LMainLibName)       = "library"+showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"+showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"  constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src@@ -257,8 +261,9 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =   let DependencyReason qpn' _ _ = dr       componentStr = case comp of-                       ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")"-                       ExposedLib     -> ""+                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"+                       ExposedLib LMainLibName      -> ""+                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"   in case ci of        Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++                          showQPN qpn ++ componentStr ++ "==" ++ showI i
Distribution/Solver/Modular/Package.hs view
@@ -22,7 +22,7 @@ import Distribution.Solver.Compat.Prelude  import Distribution.Package -- from Cabal-import Distribution.Deprecated.Text (display)+import Distribution.Pretty (prettyShow)  import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath@@ -61,7 +61,7 @@ showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid   where     extractPackageAbiHash xs =-      case first reverse $ break (=='-') $ reverse (display xs) of+      case first reverse $ break (=='-') $ reverse (prettyShow xs) of         (ys, []) -> ys         (ys, _)  -> '-' : ys
Distribution/Solver/Modular/Preference.hs view
@@ -21,11 +21,9 @@ import Prelude () import Distribution.Solver.Compat.Prelude -import Data.Function (on) import qualified Data.List as L import qualified Data.Map as M-import Control.Monad.Reader hiding (sequence)-import Data.Traversable (sequence)+import Control.Monad.Trans.Reader (Reader, runReader, ask, local)  import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal @@ -462,7 +460,7 @@      -- We just verify package choices.     go (PChoiceF qpn rdm gr cs) =-      PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) cs)+      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs)     go _otherwise =       innM _otherwise
Distribution/Solver/Modular/RetryLog.hs view
@@ -11,6 +11,9 @@     , tryWith     ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Solver.Modular.Message import Distribution.Solver.Types.Progress
Distribution/Solver/Modular/Solver.hs view
@@ -9,9 +9,12 @@     , PruneAfterFirstSuccess(..)     ) where -import Data.Map as M-import Data.List as L-import Data.Set as S+import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Data.Map as M+import qualified Data.List as L+import qualified Data.Set as S import Distribution.Verbosity  import Distribution.Compiler (CompilerInfo)@@ -91,8 +94,8 @@       -> Index                                -- ^ all available packages as an index       -> PkgConfigDb                          -- ^ available pkg-config pkgs       -> (PN -> PackagePreferences)           -- ^ preferences-      -> Map PN [LabeledPackageConstraint]    -- ^ global constraints-      -> Set PN                               -- ^ global goals+      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints+      -> S.Set PN                             -- ^ global goals       -> RetryLog Message SolverFailure (Assignment, RevDepMap) solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =   explorePhase     $
Distribution/Solver/Modular/Tree.hs view
@@ -32,6 +32,7 @@ import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath import Distribution.Types.PkgconfigVersionRange+import Distribution.Types.UnitId (UnitId) import Language.Haskell.Extension (Extension, Language)  type Weight = Double@@ -102,14 +103,16 @@                 | NewPackageDoesNotMatchExistingConstraint ConflictingDep                 | ConflictingConstraints ConflictingDep ConflictingDep                 | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)+                | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN)                 | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)                 | PackageRequiresMissingComponent QPN ExposedComponent+                | PackageRequiresPrivateComponent QPN ExposedComponent                 | PackageRequiresUnbuildableComponent QPN ExposedComponent                 | CannotInstall                 | CannotReinstall                 | NotExplicit                 | Shadowed-                | Broken+                | Broken UnitId                 | UnknownPackage                 | GlobalConstraintVersion VR ConstraintSource                 | GlobalConstraintInstalled ConstraintSource
Distribution/Solver/Modular/Validate.hs view
@@ -14,12 +14,14 @@  import Control.Applicative import Control.Monad.Reader hiding (sequence)+import Data.Either (lefts) import Data.Function (on)-import Data.List as L-import Data.Set as S import Data.Traversable import Prelude hiding (sequence) +import qualified Data.List as L+import qualified Data.Set as S+ import Language.Haskell.Extension (Extension, Language)  import Data.Map.Strict as M@@ -37,6 +39,7 @@  import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)+import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange  #ifdef DEBUG_CONFLICT_SETS@@ -59,7 +62,7 @@ --       active constraints, we must check that they are consistent with --       the current state. ----- We can actually merge (1) and (2) by saying the the current choice is+-- We can actually merge (1) and (2) by saying the current choice is -- a new active constraint, fixing the choice. -- -- If a test fails, we have detected an inconsistent state. We can@@ -109,8 +112,9 @@   pa                  :: PreAssignment,    -- Map from package name to the components that are provided by the chosen-  -- instance of that package, and whether those components are buildable.-  availableComponents :: Map QPN (Map ExposedComponent IsBuildable),+  -- instance of that package, and whether those components are visible and+  -- buildable.+  availableComponents :: Map QPN (Map ExposedComponent ComponentInfo),    -- Map from package name to the components that are required from that   -- package.@@ -226,7 +230,7 @@           let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)               newDeps = do                 nppa <- mnppa-                rComps' <- extendRequiredComponents aComps rComps newactives+                rComps' <- extendRequiredComponents qpn aComps rComps newactives                 checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps                 return (nppa, rComps')           in case newDeps of@@ -261,7 +265,7 @@       -- We now try to get the new active dependencies we might learn about because       -- we have chosen a new flag.       let newactives = extractNewDeps (F qfn) b npfa psa qdeps-          mNewRequiredComps = extendRequiredComponents aComps rComps newactives+          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives       -- As in the package case, we try to extend the partial assignment.       let mnppa = extend extSupported langSupported pkgPresent newactives ppa       case liftM2 (,) mnppa mNewRequiredComps of@@ -291,7 +295,7 @@       -- We now try to get the new active dependencies we might learn about because       -- we have chosen a new flag.       let newactives = extractNewDeps (S qsn) b pfa npsa qdeps-          mNewRequiredComps = extendRequiredComponents aComps rComps newactives+          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives       -- As in the package case, we try to extend the partial assignment.       let mnppa = extend extSupported langSupported pkgPresent newactives ppa       case liftM2 (,) mnppa mNewRequiredComps of@@ -300,20 +304,29 @@             local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r  -- | Check that a newly chosen package instance contains all components that--- are required from that package so far. The components must also be buildable.+-- are required from that package so far. The components must also be visible+-- and buildable. checkComponentsInNewPackage :: ComponentDependencyReasons                             -> QPN-                            -> Map ExposedComponent IsBuildable+                            -> Map ExposedComponent ComponentInfo                             -> Either Conflict () checkComponentsInNewPackage required qpn providedComps =     case M.toList $ deleteKeys (M.keys providedComps) required of       (missingComp, dr) : _ ->           Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent       []                    ->-          case M.toList $ deleteKeys buildableProvidedComps required of-            (unbuildableComp, dr) : _ ->-                Left $ mkConflict unbuildableComp dr NewPackageHasUnbuildableRequiredComponent-            []                        -> Right ()+          let failures = lefts+                  [ case () of+                      _ | compIsVisible compInfo == IsVisible False ->+                          Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent+                        | compIsBuildable compInfo == IsBuildable False ->+                          Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent+                        | otherwise -> Right ()+                  | let merged = M.intersectionWith (,) required providedComps+                  , (comp, (dr, compInfo)) <- M.toList merged ]+          in case failures of+               failure : _ -> Left failure+               []          -> Right ()   where     mkConflict :: ExposedComponent                -> DependencyReason QPN@@ -322,9 +335,6 @@     mkConflict comp dr mkFailure =         (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) -    buildableProvidedComps :: [ExposedComponent]-    buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps]-     deleteKeys :: Ord k => [k] -> Map k v -> Map k v     deleteKeys ks m = L.foldr M.delete m ks @@ -410,13 +420,15 @@ -- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. -- -- TODO: The new constraint is implemented as a dependency from foo to foo's--- library. That isn't correct, because foo might only be needed as a build+-- main library. That isn't correct, because foo might only be needed as a build -- tool dependency. The implemention may need to change when we support -- component-based dependency solving. extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment extendWithPackageChoice (PI qpn i) ppa =   let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa-      newChoice = PkgDep (DependencyReason qpn M.empty S.empty) (PkgComponent qpn ExposedLib) (Fixed i)+      newChoice = PkgDep (DependencyReason qpn M.empty S.empty)+                         (PkgComponent qpn (ExposedLib LMainLibName))+                         (Fixed i)   in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of         Left (c, (d, _d')) -> -- Don't include the package choice in the                               -- FailReason, because it is redundant.@@ -520,29 +532,37 @@  -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency--- requires a component that is missing or unbuildable in a previously chosen--- packages.-extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable)+-- requires a component that is missing, private, or unbuildable in a previously+-- chosen package.+extendRequiredComponents :: QPN -- ^ package we extend+                         -> Map QPN (Map ExposedComponent ComponentInfo)                          -> Map QPN ComponentDependencyReasons                          -> [LDep QPN]                          -> Either Conflict (Map QPN ComponentDependencyReasons)-extendRequiredComponents available = foldM extendSingle+extendRequiredComponents eqpn available = foldM extendSingle   where     extendSingle :: Map QPN ComponentDependencyReasons                  -> LDep QPN                  -> Either Conflict (Map QPN ComponentDependencyReasons)     extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) =       let compDeps = M.findWithDefault M.empty qpn required+          success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required       in -- Only check for the existence of the component if its package has          -- already been chosen.          case M.lookup qpn available of-           Just comps-             | M.notMember comp comps                ->-                 Left $ mkConflict qpn comp dr PackageRequiresMissingComponent-             | L.notElem comp (buildableComps comps) ->-                 Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent-           _                                         ->-                 Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required+           Just comps ->+               case M.lookup comp comps of+                 Nothing ->+                     Left $ mkConflict qpn comp dr PackageRequiresMissingComponent+                 Just compInfo+                   | compIsVisible compInfo == IsVisible False+                   , eqpn /= qpn -- package components can depend on other components+                   ->+                     Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent+                   | compIsBuildable compInfo == IsBuildable False ->+                     Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent+                   | otherwise -> success+           Nothing    -> success     extendSingle required _                                         = Right required      mkConflict :: QPN@@ -552,9 +572,6 @@                -> Conflict     mkConflict qpn comp dr mkFailure =       (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp)--    buildableComps :: Map comp IsBuildable -> [comp]-    buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps]   -- | Interface.
Distribution/Solver/Modular/Version.hs view
@@ -11,22 +11,25 @@     , (.||.)     ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import qualified Distribution.Version as CV -- from Cabal-import Distribution.Deprecated.Text -- from Cabal+import Distribution.Pretty (prettyShow)  -- | Preliminary type for versions. type Ver = CV.Version  -- | String representation of a version. showVer :: Ver -> String-showVer = display+showVer = prettyShow  -- | Version range. Consists of a lower and upper bound. type VR = CV.VersionRange  -- | String representation of a version range. showVR :: VR -> String-showVR = display+showVR = prettyShow  -- | Unconstrained version range. anyVR :: VR
Distribution/Solver/Types/ComponentDeps.hs view
@@ -34,6 +34,7 @@   , libraryDeps   , setupDeps   , select+  , components   ) where  import Prelude ()@@ -43,9 +44,12 @@ import qualified Data.Map as Map import Data.Foldable (fold) +import Distribution.Pretty (Pretty (..)) import qualified Distribution.Types.ComponentName as CN import qualified Distribution.Types.LibraryName as LN+import qualified Text.PrettyPrint as PP + {-------------------------------------------------------------------------------   Types -------------------------------------------------------------------------------}@@ -64,6 +68,15 @@ instance Binary Component instance Structured Component +instance Pretty Component where+    pretty ComponentLib        = PP.text "lib"+    pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n+    pretty (ComponentFLib n)   = PP.text "flib:" <<>> pretty n+    pretty (ComponentExe n)    = PP.text "exe:" <<>> pretty n+    pretty (ComponentTest n)   = PP.text "test:" <<>> pretty n+    pretty (ComponentBench n)  = PP.text "bench:" <<>> pretty n+    pretty ComponentSetup      = PP.text "setup"+ -- | Dependency for a single component. type ComponentDep a = (Component, a) @@ -178,6 +191,10 @@ libraryDeps = select (\c -> case c of ComponentSubLib _ -> True                                       ComponentLib -> True                                       _ -> False)++-- | List components+components :: ComponentDeps a -> Set Component+components = Map.keysSet . unComponentDeps  -- | Setup dependencies. setupDeps :: Monoid a => ComponentDeps a -> a
Distribution/Solver/Types/ConstraintSource.hs view
@@ -4,9 +4,8 @@     , showConstraintSource     ) where -import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured)+import Distribution.Solver.Compat.Prelude+import Prelude ()  -- | Source of a 'PackageConstraint'. data ConstraintSource =
Distribution/Solver/Types/DependencyResolver.hs view
@@ -2,7 +2,8 @@     ( DependencyResolver     ) where -import Data.Set (Set)+import Distribution.Solver.Compat.Prelude+import Prelude ()  import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )
Distribution/Solver/Types/Flag.hs view
@@ -2,5 +2,7 @@     ( FlagType(..)     ) where +import Prelude (Eq, Show)+ data FlagType = Manual | Automatic   deriving (Eq, Show)
Distribution/Solver/Types/InstSolverPackage.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.InstSolverPackage +module Distribution.Solver.Types.InstSolverPackage     ( InstSolverPackage(..)     ) where -import Distribution.Compat.Binary (Binary(..))-import Distribution.Utils.Structured (Structured)+import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId@@ -12,7 +13,6 @@ import Distribution.Types.PackageId import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import GHC.Generics (Generic)  -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver.
Distribution/Solver/Types/InstalledPreference.hs view
@@ -2,6 +2,8 @@     ( InstalledPreference(..),     ) where +import Prelude (Show)+ -- | Whether we prefer an installed version of a package or simply the latest -- version. --
Distribution/Solver/Types/OptionalStanza.hs view
@@ -6,13 +6,10 @@     , enableStanzas     ) where -import GHC.Generics (Generic)-import Data.Typeable-import Distribution.Compat.Binary (Binary)+import Distribution.Solver.Compat.Prelude+import Prelude () import Distribution.Types.ComponentRequestedSpec             (ComponentRequestedSpec(..), defaultComponentRequestedSpec)-import Data.List (foldl')-import Distribution.Utils.Structured (Structured)  data OptionalStanza     = TestStanzas
Distribution/Solver/Types/PackageConstraint.hs view
@@ -18,23 +18,19 @@     packageConstraintToDependency   ) where -import Distribution.Compat.Binary      (Binary)-import Distribution.Package            (PackageName)-import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)-import Distribution.Types.Dependency   (Dependency(..))-import Distribution.Types.LibraryName  (LibraryName(..))-import Distribution.Version            (VersionRange, simplifyVersionRange)-import Distribution.Utils.Structured (Structured)+import Distribution.Solver.Compat.Prelude+import Prelude () -import Distribution.Solver.Compat.Prelude ((<<>>))+import Distribution.Package                        (PackageName)+import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)+import Distribution.Pretty                         (flatStyle, pretty)+import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))+import Distribution.Version                        (VersionRange, simplifyVersionRange)+ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Deprecated.Text                  (disp, flatStyle)-import GHC.Generics                       (Generic)-import Text.PrettyPrint                   ((<+>)) import qualified Text.PrettyPrint as Disp-import qualified Data.Set as Set   -- | Determines to what packages and in what contexts a@@ -88,10 +84,10 @@  -- | Pretty-prints a constraint scope. dispConstraintScope :: ConstraintScope -> Disp.Doc-dispConstraintScope (ScopeTarget pn) = disp pn <<>> Disp.text "." <<>> disp pn-dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn-dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn-dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn+dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn+dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn+dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn+dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn  -- | A package property is a logical predicate on packages. data PackageProperty@@ -107,7 +103,7 @@  -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc-dispPackageProperty (PackagePropertyVersion verrange) = disp verrange+dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange dispPackageProperty PackagePropertyInstalled          = Disp.text "installed" dispPackageProperty PackagePropertySource             = Disp.text "source" dispPackageProperty (PackagePropertyFlags flags)      = dispFlagAssignment flags@@ -142,11 +138,10 @@       _ -> id  -- | Lossily convert a 'PackageConstraint' to a 'Dependency'.-packageConstraintToDependency :: PackageConstraint -> Maybe Dependency+packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint packageConstraintToDependency (PackageConstraint scope prop) = toDep prop   where-    toDep (PackagePropertyVersion vr) = -        Just $ Dependency (scopeToPackageName scope) vr (Set.singleton LMainLibName)+    toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr     toDep (PackagePropertyInstalled)  = Nothing     toDep (PackagePropertySource)     = Nothing     toDep (PackagePropertyFlags _)    = Nothing
Distribution/Solver/Types/PackageIndex.hs view
@@ -21,6 +21,7 @@    -- * Updates   merge,+  override,   insert,   deletePackageName,   deletePackageId,@@ -39,6 +40,7 @@   searchByName,   SearchResult(..),   searchByNameSubstring,+  searchWithPredicate,    -- ** Bulk queries   allPackages,@@ -59,7 +61,7 @@ import Distribution.Version          ( VersionRange, withinRange ) import Distribution.Simple.Utils-         ( lowercase, comparing )+         ( lowercase )  import qualified Prelude (foldr1) @@ -158,6 +160,7 @@   assert (invariant i1 && invariant i2) $     mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + -- | Elements in the second list mask those in the first. mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] mergeBuckets []     ys     = ys@@ -168,6 +171,16 @@         EQ -> y : mergeBuckets xs' ys'         LT -> x : mergeBuckets xs' ys +-- | Override-merge oftwo indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+override i1@(PackageIndex m1) i2@(PackageIndex m2) =+  assert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2)+ -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or@@ -312,9 +325,14 @@ -- searchByNameSubstring :: PackageIndex pkg                       -> String -> [(PackageName, [pkg])]-searchByNameSubstring (PackageIndex m) searchterm =+searchByNameSubstring index searchterm =+    searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)+  where lsearchterm = lowercase searchterm++searchWithPredicate :: PackageIndex pkg+                    -> (String -> Bool) -> [(PackageName, [pkg])]+searchWithPredicate (PackageIndex m) predicate =     [ pkgs     | pkgs@(pname, _) <- Map.toList m-    , lsearchterm `isInfixOf` lowercase (unPackageName pname) ]-  where-    lsearchterm = lowercase searchterm+    , predicate (unPackageName pname)+    ]
Distribution/Solver/Types/PackagePath.hs view
@@ -9,10 +9,11 @@     , showQPN     ) where -import Distribution.Package-import Distribution.Deprecated.Text+import Distribution.Solver.Compat.Prelude+import Prelude ()+import Distribution.Package (PackageName)+import Distribution.Pretty (pretty, flatStyle) import qualified Text.PrettyPrint as Disp-import Distribution.Solver.Compat.Prelude ((<<>>))  -- | A package path consists of a namespace and a package path inside that -- namespace.@@ -35,7 +36,7 @@ -- ends in a period, so it can be prepended onto a qualifier. dispNamespace :: Namespace -> Disp.Doc dispNamespace DefaultNamespace = Disp.empty-dispNamespace (Independent i) = disp i <<>> Disp.text "."+dispNamespace (Independent i) = pretty i <<>> Disp.text "."  -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier =@@ -79,10 +80,10 @@ -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty-dispQualifier (QualSetup pn)  = disp pn <<>> Disp.text ":setup."-dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>>-                                 disp pn2 <<>> Disp.text ":exe."-dispQualifier (QualBase pn)  = disp pn <<>> Disp.text "."+dispQualifier (QualSetup pn)  = pretty pn <<>> Disp.text ":setup."+dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>+                                 pretty pn2 <<>> Disp.text ":exe."+dispQualifier (QualBase pn)  = pretty pn <<>> Disp.text "."  -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a@@ -94,7 +95,7 @@ -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc dispQPN (Q (PackagePath ns qual) pn) =-  dispNamespace ns <<>> dispQualifier qual <<>> disp pn+  dispNamespace ns <<>> dispQualifier qual <<>> pretty pn  -- | String representation of a qualified package name. showQPN :: QPN -> String
Distribution/Solver/Types/PkgConfigDb.hs view
@@ -23,7 +23,7 @@ import Distribution.Solver.Compat.Prelude import Prelude () -import           Control.Exception (IOException, handle)+import           Control.Exception (handle) import qualified Data.Map          as M import           System.FilePath   (splitSearchPath)
Distribution/Solver/Types/Progress.hs view
@@ -15,7 +15,7 @@                              | Done done  -- This Functor instance works around a bug in GHC 7.6.3.--- See https://ghc.haskell.org/trac/ghc/ticket/7436#comment:6.+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. -- The derived functor instance caused a space leak in the solver. instance Functor (Progress step fail) where   fmap f (Step s p) = Step s (fmap f p)
Distribution/Solver/Types/ResolverPackage.hs view
@@ -6,17 +6,17 @@     , resolverPackageExeDeps     ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured) import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub)-import GHC.Generics (Generic)  -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration.
Distribution/Solver/Types/Settings.hs view
@@ -15,14 +15,14 @@     , SolveExecutables(..)     ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Simple.Setup ( BooleanFlag(..) )-import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured) import Distribution.Pretty ( Pretty(pretty) )-import Distribution.Deprecated.Text ( Text(parse) )-import GHC.Generics (Generic)+import Distribution.Parsec ( Parsec(parsec) ) -import qualified Distribution.Deprecated.ReadP as Parse+import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP  newtype ReorderGoals = ReorderGoals Bool@@ -90,12 +90,12 @@ instance Structured SolveExecutables  instance Pretty OnlyConstrained where-  pretty OnlyConstrainedAll = PP.text "all"+  pretty OnlyConstrainedAll  = PP.text "all"   pretty OnlyConstrainedNone = PP.text "none" -instance Text OnlyConstrained where-  parse = Parse.choice-    [ Parse.string "all" >> return OnlyConstrainedAll-    , Parse.string "none" >> return OnlyConstrainedNone+instance Parsec OnlyConstrained where+  parsec = P.choice+    [ P.string "all"  >> return OnlyConstrainedAll+    , P.string "none" >> return OnlyConstrainedNone     ]
Distribution/Solver/Types/SolverId.hs view
@@ -5,10 +5,10 @@  where -import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured)+import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Package (PackageId, Package(..), UnitId)-import GHC.Generics (Generic)  -- | The solver can produce references to existing packages or -- packages we plan to install.  Unlike 'ConfiguredId' we don't
Distribution/Solver/Types/SolverPackage.hs view
@@ -3,15 +3,15 @@     ( SolverPackage(..)     ) where -import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured)+import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Package ( Package(..) ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage-import GHC.Generics (Generic)  -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an
Distribution/Solver/Types/SourcePackage.hs view
@@ -5,31 +5,32 @@     , SourcePackage(..)     ) where +import Distribution.Solver.Compat.Prelude+import Prelude ()+ import Distribution.Package          ( PackageId, Package(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(..) )  import Data.ByteString.Lazy (ByteString)-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Data.Typeable-import Distribution.Utils.Structured (Structured)  -- | A package description along with the location of the package sources. ---data SourcePackage loc = SourcePackage {-    packageInfoId        :: PackageId,-    packageDescription   :: GenericPackageDescription,-    packageSource        :: loc,-    packageDescrOverride :: PackageDescriptionOverride+data SourcePackage loc = SourcePackage+  { srcpkgPackageId     :: PackageId+  , srcpkgDescription   :: GenericPackageDescription+    -- ^ Note, this field is lazy, e.g. when reading in hackage index+    --   we parse only what we need, not whole index.+  , srcpkgSource        :: loc+  , srcpkgDescrOverride :: PackageDescriptionOverride   }   deriving (Eq, Show, Generic, Typeable)  instance Binary loc => Binary (SourcePackage loc) instance Structured loc => Structured (SourcePackage loc) -instance Package (SourcePackage a) where packageId = packageInfoId+instance Package (SourcePackage a) where packageId = srcpkgPackageId  -- | We sometimes need to override the .cabal file in the tarball with -- the newer one from the package index.
Distribution/Solver/Types/Variable.hs view
@@ -1,5 +1,7 @@ module Distribution.Solver.Types.Variable where +import Prelude (Eq, Show)+ import Distribution.Solver.Types.OptionalStanza  import Distribution.PackageDescription (FlagName)
LICENSE view
@@ -1,5 +1,8 @@-Copyright (c) 2003-2017, Cabal Development Team.+Copyright (c) 2003-2020, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.++See */LICENSE for the copyright holders of the subcomponents.+ All rights reserved.  Redistribution and use in source and binary forms, with or without
Setup.hs view
@@ -1,63 +1,3 @@-import Distribution.PackageDescription ( PackageDescription )-import Distribution.Simple ( defaultMainWithHooks-                           , simpleUserHooks-                           , postBuild-                           , postCopy-                           , postInst-                           )-import Distribution.Simple.InstallDirs ( mandir-                                       , CopyDest (NoCopyDest)-                                       )-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)-                                          , absoluteInstallDirs-                                          )-import Distribution.Simple.Utils ( installOrdinaryFiles-                                 , notice )-import Distribution.Simple.Setup ( buildVerbosity-                                 , copyDest-                                 , copyVerbosity-                                 , fromFlag-                                 , installVerbosity-                                 )-import Distribution.Verbosity ( Verbosity )--import System.IO ( openFile-                 , IOMode (WriteMode)-                 )-import System.Process ( runProcess )-import System.FilePath ( (</>) )---- WARNING to editors of this file:--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- At this moment (Cabal 1.23), whatever you write here must be--- compatible with ALL Cabal libraries which we support bootstrapping--- with.  This is because pre-setup-depends versions of cabal-install will--- build Setup.hs against the version of Cabal which MATCHES the library--- that cabal-install was built against.  There is no way of overriding--- this behavior without bumping the required 'cabal-version' in our--- Cabal file.  Travis will let you know if we fail to install from--- tarball!-+import Distribution.Simple main :: IO ()-main = defaultMainWithHooks $ simpleUserHooks-  { postBuild = \ _ flags _ lbi ->-      buildManpage lbi (fromFlag $ buildVerbosity flags)-  , postCopy = \ _ flags pkg lbi ->-      installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags)-  , postInst = \ _ flags pkg lbi ->-      installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest-  }--buildManpage :: LocalBuildInfo -> Verbosity -> IO ()-buildManpage lbi verbosity = do-  let cabal = buildDir lbi </> "cabal/cabal"-      manpage = buildDir lbi </> "cabal/cabal.1"-  manpageHandle <- openFile manpage WriteMode-  notice verbosity ("Generating manual page " ++ manpage ++ " ...")-  _ <- runProcess cabal ["manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing-  return ()--installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()-installManpage pkg lbi verbosity copy = do-  let destDir = mandir (absoluteInstallDirs pkg lbi copy) </> "man1"-  installOrdinaryFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]+main = defaultMain
− bootstrap.sh 
@@ -1,549 +0,0 @@-#!/bin/sh-set -e--# A script to bootstrap cabal-install.--# It works by downloading and installing the Cabal, zlib and-# HTTP packages. It then installs cabal-install itself.-# It expects to be run inside the cabal-install directory.--# Install settings, you can override these by setting environment vars. E.g. if-# you don't want profiling and dynamic versions of libraries to be installed in-# addition to vanilla, run 'EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh'--#VERBOSE-DEFAULT_CONFIGURE_OPTS="--enable-library-profiling --enable-shared"-EXTRA_CONFIGURE_OPTS=${EXTRA_CONFIGURE_OPTS-$DEFAULT_CONFIGURE_OPTS}-#EXTRA_BUILD_OPTS-#EXTRA_INSTALL_OPTS--die() {-    printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2-    exit 2-}--# programs, you can override these by setting environment vars-GHC="${GHC:-ghc}"-GHC_PKG="${GHC_PKG:-ghc-pkg}"-GHC_VER="$(${GHC} --numeric-version)"-HADDOCK=${HADDOCK:-haddock}-WGET="${WGET:-wget}"-CURL="${CURL:-curl}"-FETCH="${FETCH:-fetch}"-TAR="${TAR:-tar}"-GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}"--# The variable SCOPE_OF_INSTALLATION can be set on the command line to-# use/install the libraries needed to build cabal-install to a custom package-# database instead of the user or global package database.-#-# Example:-#-# $ ghc-pkg init /my/package/database-# $ SCOPE_OF_INSTALLATION='--package-db=/my/package/database' ./bootstrap.sh-#-# You can also combine SCOPE_OF_INSTALLATION with PREFIX:-#-# $ ghc-pkg init /my/prefix/packages.conf.d-# $ SCOPE_OF_INSTALLATION='--package-db=/my/prefix/packages.conf.d' \-#   PREFIX=/my/prefix ./bootstrap.sh-#-# If you use the --global,--user or --sandbox arguments, this will-# override the SCOPE_OF_INSTALLATION setting and not use the package-# database you pass in the SCOPE_OF_INSTALLATION variable.--SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}"-DEFAULT_PREFIX="${HOME}/.cabal"--TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX)-export TMPDIR--# Check for a C compiler, using user-set $CC, if any, first.-for c in $CC gcc clang cc icc; do-  $c --version 1>/dev/null 2>&1 && CC=$c &&-  echo "Using $c for C compiler. If this is not what you want, set CC." >&2 &&-  break-done--# None found.-[ -"$CC"- = -""- ] && die 'C compiler not found (or could not be run).-  If a C compiler is installed make sure it is on your PATH, or set $CC.'--# Find the correct linker/linker-wrapper.-#-# See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153.-LINK="$(for link in collect2 ld; do-          if [ $($CC -print-prog-name=$link) = $link ]-          then-              continue-          else-              $CC -print-prog-name=$link && break-          fi-        done)"--# Fall back to "ld"... might work.-[ -$LINK- = -""- ] && LINK=ld--# And finally, see if we can compile and link something.-  echo 'int main(){}' | $CC -xc - -o /dev/null ||-    die "C compiler and linker could not compile a simple test program.-    Please check your toolchain."--# Warn that were's overriding $LD if set (if you want).-[ -"$LD"- != -""- ] && [ -"$LD"- != -"$LINK"- ] &&-  echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2-  echo "Using $LINK instead." >&2--# Set LD, overriding environment if necessary.-export LD=$LINK--# Check we're in the right directory, etc.-grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 ||-  die "The bootstrap.sh script must be run in the cabal-install directory"--${GHC} --numeric-version > /dev/null 2>&1  ||-  die "${GHC} not found (or could not be run).-       If ghc is installed,  make sure it is on your PATH,-       or set the GHC and GHC_PKG vars."--${GHC_PKG} --version     > /dev/null 2>&1  || die "${GHC_PKG} not found."--GHC_PKG_VER="$(${GHC_PKG} --version | cut -d' ' -f 5)"--[ ${GHC_VER} = ${GHC_PKG_VER} ] ||-  die "Version mismatch between ${GHC} and ${GHC_PKG}.-       If you set the GHC variable then set GHC_PKG too."--JOBS="-j1"-while [ "$#" -gt 0 ]; do-  case "${1}" in-    "--user")-      SCOPE_OF_INSTALLATION="${1}"-      shift;;-    "--global")-      SCOPE_OF_INSTALLATION="${1}"-      DEFAULT_PREFIX="/usr/local"-      shift;;-    "--sandbox")-      shift-      # check if there is another argument which doesn't start with ---      if [ "$#" -le 0 ] || [ ! -z $(echo "${1}" | grep "^--") ]-      then-          SANDBOX=".cabal-sandbox"-      else-          SANDBOX="${1}"-          shift-      fi;;-    "--no-doc")-      NO_DOCUMENTATION=1-      shift;;-    "--no-install")-      NO_INSTALL=1-      shift;;-    "-j"|"--jobs")-        shift-        # check if there is another argument which doesn't start with - or ---        if [ "$#" -le 0 ] \-            || [ ! -z $(echo "${1}" | grep "^-") ] \-            || [ ! -z $(echo "${1}" | grep "^--") ]-        then-            JOBS="-j"-        else-            JOBS="-j${1}"-            shift-        fi;;-    *)-      echo "Unknown argument or option, quitting: ${1}"-      echo "usage: bootstrap.sh [OPTION]"-      echo-      echo "options:"-      echo "   -j/--jobs       Number of concurrent workers to use (Default: 1)"-      echo "                   -j without an argument will use all available cores"-      echo "   --user          Install for the local user (default)"-      echo "   --global        Install systemwide (must be run as root)"-      echo "   --no-doc        Do not generate documentation for installed"\-           "packages"-      echo "   --sandbox       Install to a sandbox in the default location"\-           "(.cabal-sandbox)"-      echo "   --sandbox path  Install to a sandbox located at path"-      exit;;-  esac-done--# Do not try to use -j with GHC 7.8 or older-case $GHC_VER in-    7.4*|7.6*|7.8*)-        JOBS=""-        ;;-    *)-        ;;-esac--abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";;-             esac; }--if [ ! -z "$SANDBOX" ]-then # set up variables for sandbox bootstrap-  # Make the sandbox path absolute since it will be used from-  # different working directories when the dependency packages are-  # installed.-  SANDBOX=$(abspath "$SANDBOX")-  # Get the name of the package database which cabal sandbox would use.-  GHC_ARCH=$(ghc --info |-    sed -n 's/.*"Target platform".*"\([^-]\+\)-[^-]\+-\([^"]\+\)".*/\1-\2/p')-  PACKAGEDB="$SANDBOX/${GHC_ARCH}-ghc-${GHC_VER}-packages.conf.d"-  # Assume that if the directory is already there, it is already a-  # package database. We will get an error immediately below if it-  # isn't. Uses -r to try to be compatible with Solaris, and allow-  # symlinks as well as a normal dir/file.-  [ ! -r "$PACKAGEDB" ] && ghc-pkg init "$PACKAGEDB"-  PREFIX="$SANDBOX"-  SCOPE_OF_INSTALLATION="--package-db=$PACKAGEDB"-  echo Bootstrapping in sandbox at \'$SANDBOX\'.-fi--# Check for haddock unless no documentation should be generated.-if [ ! ${NO_DOCUMENTATION} ]-then-  ${HADDOCK} --version     > /dev/null 2>&1  || die "${HADDOCK} not found."-fi--PREFIX=${PREFIX:-${DEFAULT_PREFIX}}--# Versions of the packages to install.-# The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.13.0"; PARSEC_VER_REGEXP="[3]\.[1]\."-                       # >= 3.1 && < 3.2-DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."-                       # >= 1.1 && < 2-BINARY_VER="0.8.5.1";  BINARY_VER_REGEXP="[0]\.[78]\."-                       # >= 0.7 && < 0.9-TEXT_VER="1.2.3.0";    TEXT_VER_REGEXP="[1]\.[2]\."-                       # >= 1.2 && < 1.3-NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])"-                       # >= 2.6.0.2 && < 2.7-NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\."-                       # >= 2.0 && < 2.7-CABAL_VER="3.2.0.0";   CABAL_VER_REGEXP="3\.2\.[0-9]"-                       # >= 3.2 && < 3.3-TRANS_VER="0.5.5.0";   TRANS_VER_REGEXP="0\.[45]\."-                       # >= 0.2.* && < 0.6-MTL_VER="2.2.2";       MTL_VER_REGEXP="[2]\."-                       #  >= 2.0 && < 3-HTTP_VER="4000.3.12";  HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"-                       # >= 4000.2.5 < 4000.4-ZLIB_VER="0.6.2";      ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"-                       # >= 0.5.3 && <= 0.7-TIME_VER="1.9.1"       TIME_VER_REGEXP="1\.[1-9]\.?"-                       # >= 1.1 && < 1.10-RANDOM_VER="1.1"       RANDOM_VER_REGEXP="1\.[01]\.?"-                       # >= 1 && < 1.2-STM_VER="2.4.5.0";     STM_VER_REGEXP="2\."-                       # == 2.*-HASHABLE_VER="1.2.7.0"; HASHABLE_VER_REGEXP="1\."-                       # 1.*-ASYNC_VER="2.2.1";     ASYNC_VER_REGEXP="2\."-                       # 2.*-BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1"-                       # 0.1.*-BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\."-                       # >=1.0-CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"-                       # 0.11.*-RESOLV_VER="0.1.1.1";  RESOLV_VER_REGEXP="0\.1\.[1-9]"-                       # >= 0.1.1 && < 0.2-MINTTY_VER="0.1.2";    MINTTY_VER_REGEXP="0\.1\.?"-                       # 0.1.*-ECHO_VER="0.1.3";      ECHO_VER_REGEXP="0\.1\.[3-9]"-                       # >= 0.1.3 && < 0.2-EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?"-                       # 0.2.2.*-ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"-                       # 0.0.*-HACKAGE_SECURITY_VER="0.6.0.0"; HACKAGE_SECURITY_VER_REGEXP="0\.6\."-                       # >= 0.7.0.0 && < 0.7-TAR_VER="0.5.1.0";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?"-                       # >= 0.5.0.3  && < 0.6-DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)"-                       # >= 0.0.1.2 && < 0.1-LUKKO_VER="0.1.1";     LUKKO_VER_REGEXP="0\.1\.[1-9]"-                       # >= 0.1.1 && <0.2--HACKAGE_URL="https://hackage.haskell.org/package"--# Haddock fails for hackage-security for GHC <8,-# c.f. https://github.com/well-typed/hackage-security/issues/149-NO_DOCS_PACKAGES_VER_REGEXP="hackage-security-0\.5\.[0-9]+\.[0-9]+"--# Cache the list of packages:-echo "Checking installed packages for ghc-${GHC_VER}..."-${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list ||-  die "running '${GHC_PKG} list' failed"-trap "rm ghc-pkg.list" EXIT--# Will we need to install this package, or is a suitable version installed?-need_pkg () {-  PKG=$1-  VER_MATCH=$2-  if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1-  then-    return 1;-  else-    return 0;-  fi-  #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it.-}--info_pkg () {-  PKG=$1-  VER=$2-  VER_MATCH=$3--  if need_pkg ${PKG} ${VER_MATCH}-  then-    if [ -d "${PKG}-${VER}" ]-    then-      echo "${PKG}-${VER} will be installed from local directory."-    elif [ -r "${PKG}-${VER}.tar.gz" ]-    then-      echo "${PKG}-${VER} will be installed from local tarball."-    else-      echo "${PKG}-${VER} will be downloaded and installed."-    fi-  else-    echo "${PKG} is already installed and the version is ok."-  fi-}--fetch_pkg () {-  PKG=$1-  VER=$2--  URL_PKG=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz-  URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal-  if which ${CURL} > /dev/null-  then-    ${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}."-    ${CURL} -L --fail -C - -O ${URL_PKGDESC} \-        || die "Failed to download '${PKG}.cabal'."-  elif which ${WGET} > /dev/null-  then-    ${WGET} -c ${URL_PKG} || die "Failed to download ${PKG}."-    ${WGET} -c ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."-  elif which ${FETCH} > /dev/null-    then-      ${FETCH} ${URL_PKG} || die "Failed to download ${PKG}."-      ${FETCH} ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."-  else-    die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."-  fi-  [ -f "${PKG}-${VER}.tar.gz" ] ||-     die "Downloading ${URL_PKG} did not create ${PKG}-${VER}.tar.gz"-  [ -f "${PKG}.cabal" ] ||-     die "Downloading ${URL_PKGDESC} did not create ${PKG}.cabal"-  mv "${PKG}.cabal" "${PKG}.cabal.hackage"-}--unpack_pkg () {-  PKG=$1-  VER=$2--  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"-  ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf --  [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz"-  cp "${PKG}.cabal.hackage" "${PKG}-${VER}/${PKG}.cabal"-}--install_pkg () {-  [ ${NO_INSTALL} ] && return 0--  PKG=$1-  VER=$2--  [ -x Setup ] && ./Setup clean-  [ -f Setup ] && rm Setup--  PKG_DBS=$(printf '%s\n' "${SCOPE_OF_INSTALLATION}" \-             | sed -e 's/--package-db/-package-db/' \-                   -e 's/--global/-global-package-db/' \-                   -e 's/--user/-user-package-db/')--  ${GHC} --make ${JOBS} ${PKG_DBS} Setup -o Setup -XRank2Types -XFlexibleContexts ||-    die "Compiling the Setup script failed."--  [ -x Setup ] || die "The Setup script does not exist or cannot be run"--  args="${SCOPE_OF_INSTALLATION} --prefix=${PREFIX} --with-compiler=${GHC}"-  args="$args --with-hc-pkg=${GHC_PKG} --with-gcc=${CC} --with-ld=${LD}"-  args="$args ${EXTRA_CONFIGURE_OPTS} ${VERBOSE}"--  ./Setup configure $args || die "Configuring the ${PKG} package failed."--  ./Setup build ${JOBS} ${EXTRA_BUILD_OPTS} ${VERBOSE} ||-     die "Building the ${PKG} package failed."--  if [ ! ${NO_DOCUMENTATION} ]-  then-    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} \-        > /dev/null 2>&1-    then-      echo "Skipping documentation for the ${PKG} package."-    else-      ./Setup haddock --with-ghc=${GHC} --with-haddock=${HADDOCK} ${VERBOSE} ||-        die "Documenting the ${PKG} package failed."-    fi-  fi--  ./Setup install ${EXTRA_INSTALL_OPTS} ${VERBOSE} ||-     die "Installing the ${PKG} package failed."-}--do_pkg () {-  PKG=$1-  VER=$2-  VER_MATCH=$3--  if need_pkg ${PKG} ${VER_MATCH}-  then-    echo-    if [ -d "${PKG}-${VER}" ]-    then-      echo "Using local directory for ${PKG}-${VER}."-    else-      if [ -r "${PKG}-${VER}.tar.gz" ]-      then-        echo "Using local tarball for ${PKG}-${VER}."-      else-        echo "Downloading ${PKG}-${VER}..."-        fetch_pkg ${PKG} ${VER}-      fi-      unpack_pkg "${PKG}" "${VER}"-    fi-    (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER})-  fi-}--# If we're bootstrapping from a Git clone, install the local version of Cabal-# instead of downloading one from Hackage.-do_Cabal_pkg () {-    if [ -d "../.git" ]-    then-        if need_pkg "Cabal" ${CABAL_VER_REGEXP}-        then-            echo "Cabal-${CABAL_VER} will be installed from the local Git clone."-            (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP})-        else-            echo "Cabal is already installed and the version is ok."-        fi-    else-        info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}-        do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}-    fi-}--# Actually do something!--info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}-info_pkg "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP}-info_pkg "time"         ${TIME_VER}    ${TIME_VER_REGEXP}-info_pkg "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP}-info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}-info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP}-info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}-info_pkg "network-uri"  ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}-info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP}-info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP}-info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}-info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP}-info_pkg "hashable"     ${HASHABLE_VER}  ${HASHABLE_VER_REGEXP}-info_pkg "async"        ${ASYNC_VER}   ${ASYNC_VER_REGEXP}-info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \-    ${BASE16_BYTESTRING_VER_REGEXP}-info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \-    ${BASE64_BYTESTRING_VER_REGEXP}-info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \-    ${CRYPTOHASH_SHA256_VER_REGEXP}-info_pkg "resolv"        ${RESOLV_VER}        ${RESOLV_VER_REGEXP}-info_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP}-info_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP}-info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}-info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}-info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}-info_pkg "digest"            ${DIGEST_VER}           ${DIGEST_REGEXP}-info_pkg "lukko"        ${LUKKO_VER}   ${LUKKO_REGEXP}-info_pkg "hackage-security"  ${HACKAGE_SECURITY_VER} \-    ${HACKAGE_SECURITY_VER_REGEXP}--do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}-do_pkg   "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP}-do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP}--# Cabal might depend on these-do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP}-do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}-do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP}-do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}--# Install the Cabal library from the local Git clone if possible.-do_Cabal_pkg--do_pkg   "network-uri"  ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}-do_pkg   "HTTP"         ${HTTP_VER}       ${HTTP_VER_REGEXP}-do_pkg   "zlib"         ${ZLIB_VER}       ${ZLIB_VER_REGEXP}-do_pkg   "random"       ${RANDOM_VER}     ${RANDOM_VER_REGEXP}-do_pkg   "stm"          ${STM_VER}        ${STM_VER_REGEXP}-do_pkg   "hashable"     ${HASHABLE_VER}   ${HASHABLE_VER_REGEXP}-do_pkg   "async"        ${ASYNC_VER}      ${ASYNC_VER_REGEXP}-do_pkg   "base16-bytestring" ${BASE16_BYTESTRING_VER} \-    ${BASE16_BYTESTRING_VER_REGEXP}-do_pkg   "base64-bytestring" ${BASE64_BYTESTRING_VER} \-    ${BASE64_BYTESTRING_VER_REGEXP}-do_pkg   "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \-    ${CRYPTOHASH_SHA256_VER_REGEXP}-do_pkg "resolv"        ${RESOLV_VER}        ${RESOLV_VER_REGEXP}-do_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP}-do_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP}-do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}-do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}-do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}-do_pkg   "digest"            ${DIGEST_VER}           ${DIGEST_REGEXP}-do_pkg   "lukko"       ${LUKKO_VER}      ${LUKKO_REGEXP}-do_pkg   "hackage-security"  ${HACKAGE_SECURITY_VER} \-    ${HACKAGE_SECURITY_VER_REGEXP}---install_pkg "cabal-install"-[ ${NO_INSTALL} ] && exit 0--# Use the newly built cabal to turn the prefix/package database into a-# legit cabal sandbox. This works because 'cabal sandbox init' will-# reuse the already existing package database and other files if they-# are in the expected locations.-[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal v1-sandbox init --sandbox $SANDBOX--echo-echo "==========================================="-CABAL_BIN="$PREFIX/bin"-if [ -x "$CABAL_BIN/cabal" ]-then-    echo "The 'cabal' program has been installed in $CABAL_BIN/"-    echo "You should either add $CABAL_BIN to your PATH"-    echo "or copy the cabal program to a directory that is on your PATH."-    echo-    echo "The first thing to do is to get the latest list of packages with:"-    echo "  cabal update"-    echo "This will also create a default config file (if it does not already"-    echo "exist) at $HOME/.cabal/config"-    echo-    echo "By default cabal will install programs to $HOME/.cabal/bin"-    echo "If you do not want to add this directory to your PATH then you can"-    echo "change the setting in the config file, for example you could use:"-    echo "installdir: $HOME/bin"-else-    echo "Sorry, something went wrong."-    echo "The 'cabal' executable was not successfully installed into"-    echo "$CABAL_BIN/"-fi-echo
cabal-install.cabal view
@@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name:               cabal-install-Version:            3.2.0.0+Version:            3.4.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -18,9 +18,9 @@ Maintainer:         Cabal Development Team <cabal-devel@haskell.org> Copyright:          2003-2020, Cabal Development Team Category:           Distribution-Build-type:         Custom+Build-type:         Simple Extra-Source-Files:-  README.md bash-completion/cabal bootstrap.sh changelog+  README.md bash-completion/cabal changelog    -- Generated with 'make gen-extra-source-files'   -- Do NOT edit this section manually; instead, run the script.@@ -80,8 +80,10 @@   tests/IntegrationTests2/targets/multiple-tests/cabal.project   tests/IntegrationTests2/targets/multiple-tests/p.cabal   tests/IntegrationTests2/targets/simple/P.hs+  tests/IntegrationTests2/targets/simple/app/Main.hs   tests/IntegrationTests2/targets/simple/cabal.project   tests/IntegrationTests2/targets/simple/p.cabal+  tests/IntegrationTests2/targets/simple/q/Q.hs   tests/IntegrationTests2/targets/simple/q/QQ.hs   tests/IntegrationTests2/targets/simple/q/q.cabal   tests/IntegrationTests2/targets/test-only/p.cabal@@ -126,13 +128,6 @@   default:      True   manual:       True -custom-setup-   setup-depends:-       Cabal     >= 2.2,-       base,-       process   >= 1.1.0.1  && < 1.7,-       filepath  >= 1.3      && < 1.5- executable cabal     main-is:        Main.hs     hs-source-dirs: main@@ -144,7 +139,10 @@       if impl(ghc < 8.8)         ghc-options: -Wnoncanonical-monadfail-instances +      if impl(ghc >=8.10)+        ghc-options: -Wunused-packages +     ghc-options: -rtsopts -threaded      -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a@@ -156,10 +154,10 @@         -- they are needed for as long until cabal-install moves to parsec parser         Distribution.Deprecated.ParseUtils         Distribution.Deprecated.ReadP-        Distribution.Deprecated.Text         Distribution.Deprecated.ViewAsFieldDescr          Distribution.Client.BuildReports.Anonymous+        Distribution.Client.BuildReports.Lens         Distribution.Client.BuildReports.Storage         Distribution.Client.BuildReports.Types         Distribution.Client.BuildReports.Upload@@ -168,19 +166,20 @@         Distribution.Client.CmdBuild         Distribution.Client.CmdClean         Distribution.Client.CmdConfigure-        Distribution.Client.CmdUpdate         Distribution.Client.CmdErrorMessages         Distribution.Client.CmdExec         Distribution.Client.CmdFreeze         Distribution.Client.CmdHaddock         Distribution.Client.CmdInstall         Distribution.Client.CmdInstall.ClientInstallFlags+        Distribution.Client.CmdInstall.ClientInstallTargetSelector+        Distribution.Client.CmdLegacy+        Distribution.Client.CmdListBin         Distribution.Client.CmdRepl         Distribution.Client.CmdRun-        Distribution.Client.CmdRun.ClientRunFlags-        Distribution.Client.CmdTest-        Distribution.Client.CmdLegacy         Distribution.Client.CmdSdist+        Distribution.Client.CmdTest+        Distribution.Client.CmdUpdate         Distribution.Client.Compat.Directory         Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.FilePerms@@ -207,27 +206,36 @@         Distribution.Client.HashValue         Distribution.Client.HttpUtils         Distribution.Client.IndexUtils+        Distribution.Client.IndexUtils.ActiveRepos+        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.Licenses+        Distribution.Client.Init.Prompt         Distribution.Client.Init.Types+        Distribution.Client.Init.Utils         Distribution.Client.Install         Distribution.Client.InstallPlan         Distribution.Client.InstallSymlink         Distribution.Client.JobControl         Distribution.Client.List         Distribution.Client.Manpage+        Distribution.Client.ManpageFlags         Distribution.Client.Nix+        Distribution.Client.NixStyleOptions         Distribution.Client.Outdated         Distribution.Client.PackageHash-        Distribution.Client.PackageUtils         Distribution.Client.ParseUtils         Distribution.Client.ProjectBuilding         Distribution.Client.ProjectBuilding.Types         Distribution.Client.ProjectConfig         Distribution.Client.ProjectConfig.Legacy         Distribution.Client.ProjectConfig.Types+        Distribution.Client.ProjectFlags         Distribution.Client.ProjectOrchestration         Distribution.Client.ProjectPlanOutput         Distribution.Client.ProjectPlanning@@ -236,10 +244,7 @@         Distribution.Client.Reconfigure         Distribution.Client.Run         Distribution.Client.Sandbox-        Distribution.Client.Sandbox.Index         Distribution.Client.Sandbox.PackageEnvironment-        Distribution.Client.Sandbox.Timestamp-        Distribution.Client.Sandbox.Types         Distribution.Client.SavedFlags         Distribution.Client.Security.DNS         Distribution.Client.Security.HTTP@@ -247,13 +252,28 @@         Distribution.Client.SetupWrapper         Distribution.Client.SolverInstallPlan         Distribution.Client.SourceFiles-        Distribution.Client.SourceRepo         Distribution.Client.SrcDist         Distribution.Client.Store         Distribution.Client.Tar+        Distribution.Client.TargetProblem         Distribution.Client.TargetSelector         Distribution.Client.Targets         Distribution.Client.Types+        Distribution.Client.Types.AllowNewer+        Distribution.Client.Types.BuildResults+        Distribution.Client.Types.ConfiguredId+        Distribution.Client.Types.ConfiguredPackage+        Distribution.Client.Types.Credentials+        Distribution.Client.Types.InstallMethod+        Distribution.Client.Types.OverwritePolicy+        Distribution.Client.Types.PackageLocation+        Distribution.Client.Types.PackageSpecifier+        Distribution.Client.Types.ReadyPackage+        Distribution.Client.Types.Repo+        Distribution.Client.Types.RepoName+        Distribution.Client.Types.SourcePackageDb+        Distribution.Client.Types.SourceRepo+        Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils@@ -316,11 +336,11 @@     build-depends:         async      >= 2.0      && < 2.3,         array      >= 0.4      && < 0.6,-        base       >= 4.8      && < 4.14,+        base       >= 4.8      && < 4.15,         base16-bytestring >= 0.1.1 && < 0.2,         binary     >= 0.7.3    && < 0.9,         bytestring >= 0.10.6.0 && < 0.11,-        Cabal      == 3.2.*,+        Cabal      == 3.4.*,         containers >= 0.5.6.2  && < 0.7,         cryptohash-sha256 >= 0.11 && < 0.12,         deepseq    >= 1.4.1.1  && < 1.5,@@ -332,18 +352,19 @@         HTTP       >= 4000.1.5 && < 4000.4,         mtl        >= 2.0      && < 2.3,         network-uri >= 2.6.0.2 && < 2.7,-        network    >= 2.6      && < 3.2,         pretty     >= 1.1      && < 1.2,         process    >= 1.2.3.0  && < 1.7,-        random     >= 1        && < 1.2,+        random     >= 1.2      && < 1.3,         stm        >= 2.0      && < 2.6,         tar        >= 0.5.0.3  && < 0.6,-        time       >= 1.5.0.1  && < 1.10,+        time       >= 1.5.0.1  && < 1.11,         transformers >= 0.4.2.0 && < 0.6,         zlib       >= 0.5.3    && < 0.7,-        hackage-security >= 0.6.0.0 && < 0.7,+        hackage-security >= 0.6.0.1 && < 0.7,         text       >= 1.2.3    && < 1.3,-        parsec     >= 3.1.13.0 && < 3.2+        parsec     >= 3.1.13.0 && < 3.2,+        regex-base  >= 0.94.0.0 && <0.95,+        regex-posix >= 0.96.0.0 && <0.97      if !impl(ghc >= 8.0)         build-depends: fail        == 4.9.*@@ -356,7 +377,8 @@         build-depends: resolv      >= 0.1.1 && < 0.2      if os(windows)-      build-depends: Win32 >= 2 && < 3+      -- newer directory for symlinks+      build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0     else       build-depends: unix >= 2.5 && < 2.9
changelog view
@@ -1,5 +1,8 @@ -*-change-log-*- +3.4.0.0 Oleg Grenrus <oleg.grenrus@iki.fi> February 2021+	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md+ 3.2.0.0 Herbert Valerio Riedel <hvr@gnu.org> April 2020 	* `v2-build` (and other `v2-`prefixed commands) now accept the 	  `--benchmark-option(s)` flags, which pass options to benchmark executables
main/Main.hs view
@@ -21,10 +21,10 @@          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand          , reconfigureCommand          , configCompilerAux', configPackageDB'-         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+         , BuildFlags(..)          , buildCommand, replCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand, uninstallCommand+         , installCommand          , FetchFlags(..), fetchCommand          , FreezeFlags(..), freezeCommand          , genBoundsCommand@@ -33,16 +33,13 @@          , checkCommand          , formatCommand          , UpdateFlags(..), updateCommand-         , ListFlags(..), listCommand+         , ListFlags(..), listCommand, listNeedsCompiler          , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand          , runCommand          , InitFlags(initVerbosity, initHcPath), initCommand-         , SDistFlags(..), sdistCommand-         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand          , ActAsSetupFlags(..), actAsSetupCommand-         , SandboxFlags(..), sandboxCommand          , ExecFlags(..), execCommand          , UserConfigFlags(..), userConfigCommand          , reportCommand@@ -93,6 +90,7 @@ import qualified Distribution.Client.CmdExec      as CmdExec import qualified Distribution.Client.CmdClean     as CmdClean import qualified Distribution.Client.CmdSdist     as CmdSdist+import qualified Distribution.Client.CmdListBin   as CmdListBin import           Distribution.Client.CmdLegacy  import Distribution.Client.Install            (install)@@ -107,39 +105,20 @@ --import Distribution.Client.Clean            (clean) import qualified Distribution.Client.Upload as Upload import Distribution.Client.Run                (run, splitRunArgs)-import Distribution.Client.SrcDist            (sdist) import Distribution.Client.Get                (get) import Distribution.Client.Reconfigure        (Check(..), reconfigure) import Distribution.Client.Nix                (nixInstantiate                                               ,nixShell-                                              ,nixShellIfSandboxed)-import Distribution.Client.Sandbox            (sandboxInit-                                              ,sandboxAddSource-                                              ,sandboxDelete-                                              ,sandboxDeleteSource-                                              ,sandboxListSources-                                              ,sandboxHcPkg-                                              ,dumpPackageEnvironment--                                              ,loadConfigOrSandboxConfig+                                              )+import Distribution.Client.Sandbox            (loadConfigOrSandboxConfig                                               ,findSavedDistPref-                                              ,initPackageDBIfNeeded-                                              ,maybeWithSandboxDirOnSearchPath-                                              ,maybeWithSandboxPackageInfo-                                              ,tryGetIndexFilePath-                                              ,sandboxBuildDir-                                              ,updateSandboxConfigFileFlag                                               ,updateInstallDirs-                                               ,getPersistOrConfigCompiler)-import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB)-import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)-import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Tar                (createTarGzFile)-import Distribution.Client.Types              (Password (..))+import Distribution.Client.Types.Credentials  (Password (..)) import Distribution.Client.Init               (initCabal)-import Distribution.Client.Manpage            (manpage)-import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import Distribution.Client.Manpage            (manpageCmd)+import Distribution.Client.ManpageFlags       (ManpageFlags (..)) import Distribution.Client.Utils              (determineNumJobs                                               ,relaxEncodingErrors                                               )@@ -160,7 +139,7 @@          ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)          , CommandType(..), commandsRun, commandAddAction, hiddenCommand          , commandFromSpec, commandShowOptions )-import Distribution.Simple.Compiler (Compiler(..), PackageDBStack)+import Distribution.Simple.Compiler (PackageDBStack) import Distribution.Simple.Configure          ( configCompilerAuxEx, ConfigStateFileError(..)          , getPersistBuildConfig, interpretPackageDbFlags@@ -185,44 +164,19 @@  import Distribution.Compat.ResponseFile import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure, exitSuccess) import System.FilePath          ( dropExtension, splitExtension                                 , takeExtension, (</>), (<.>) ) import System.IO                ( BufferMode(LineBuffering), hSetBuffering                                 , stderr, stdout ) import System.Directory         (doesFileExist, getCurrentDirectory) import Data.Monoid              (Any(..))-import Control.Exception        (SomeException(..), try)-import Control.Monad            (mapM_)+import Control.Exception        (try) import Data.Version             (showVersion) -#ifdef MONOLITHIC-import qualified UnitTests-import qualified MemoryUsageTests-import qualified SolverQuickCheck-import qualified IntegrationTests2-import qualified System.Environment as Monolithic-#endif- -- | Entry point -- main :: IO ()-#ifdef MONOLITHIC main = do-    mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE"-    case mb_exec of-        Just "UnitTests"         -> UnitTests.main-        Just "MemoryUsageTests"  -> MemoryUsageTests.main-        Just "SolverQuickCheck"  -> SolverQuickCheck.main-        Just "IntegrationTests2" -> IntegrationTests2.main-        Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE"-        Nothing -> main'-#else-main = main'-#endif--main' :: IO ()-main' = do   -- Enable line buffering so that we can get fast feedback even when piped.   -- This is especially important for CI and build systems.   hSetBuffering stdout LineBuffering@@ -255,9 +209,7 @@           CommandList     opts           -> printOptionsList opts           CommandErrors   errs           -> maybe (printErrors errs) go maybeScriptAndArgs where             go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs-          CommandReadyToGo action        -> do-            globalFlags' <- updateSandboxConfigFileFlag globalFlags-            action globalFlags'+          CommandReadyToGo action        -> action globalFlags    where     printCommandHelp help = do@@ -297,12 +249,10 @@       , regularCmd genBoundsCommand genBoundsAction       , regularCmd outdatedCommand outdatedAction       , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref-      , hiddenCmd  uninstallCommand uninstallAction       , hiddenCmd  formatCommand formatAction-      , hiddenCmd  upgradeCommand upgradeAction-      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction       , hiddenCmd  actAsSetupCommand actAsSetupAction       , hiddenCmd  manpageCommand (manpageAction commandSpecs)+      , regularCmd CmdListBin.listbinCommand     CmdListBin.listbinAction        ] ++ concat       [ newCmd  CmdConfigure.configureCommand CmdConfigure.configureAction@@ -331,12 +281,10 @@       , legacyCmd benchmarkCommand benchmarkAction       , legacyCmd execCommand execAction       , legacyCmd cleanCommand cleanAction-      , legacyCmd sdistCommand sdistAction       , legacyCmd doctestCommand doctestAction       , legacyWrapperCmd copyCommand copyVerbosity copyDistPref       , legacyWrapperCmd registerCommand regVerbosity regDistPref       , legacyCmd reconfigureCommand reconfigureAction-      , legacyCmd sandboxCommand sandboxAction       ]  type Action = GlobalFlags -> IO ()@@ -369,7 +317,7 @@     { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do     let verbosity = fromFlagOrDefault normal (verbosityFlag flags)     load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-    let config = either (\(SomeException _) -> mempty) snd load+    let config = either (\(SomeException _) -> mempty) id load     distPref <- findSavedDistPref config (distPrefFlag flags)     let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }     setupWrapper verbosity setupScriptOptions Nothing@@ -379,7 +327,7 @@                 -> [String] -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+  config <- updateInstallDirs (configUserInstall configFlags)                           <$> loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (configDistPref configFlags)   nixInstantiate verbosity distPref True globalFlags config@@ -389,43 +337,24 @@         globalFlags'   = savedGlobalFlags      config `mappend` globalFlags     (comp, platform, progdb) <- configCompilerAuxEx configFlags' -    -- If we're working inside a sandbox and the user has set the -w option, we-    -- may need to create a sandbox-local package DB for this compiler and add a-    -- timestamp record for this compiler to the timestamp file.-    let configFlags''  = case useSandbox of-          NoSandbox               -> configFlags'-          (UseSandbox sandboxDir) -> setPackageDB sandboxDir-                                    comp platform configFlags'--    writeConfigFlags verbosity distPref (configFlags'', configExFlags')+    writeConfigFlags verbosity distPref (configFlags', configExFlags')      -- What package database(s) to use     let packageDBs :: PackageDBStack         packageDBs           = interpretPackageDbFlags-            (fromFlag (configUserInstall configFlags''))-            (configPackageDBs configFlags'')--    whenUsingSandbox useSandbox $ \sandboxDir -> do-      initPackageDBIfNeeded verbosity configFlags'' comp progdb-      -- NOTE: We do not write the new sandbox package DB location to-      -- 'cabal.sandbox.config' here because 'configure -w' must not affect-      -- subsequent 'install' (for UI compatibility with non-sandboxed mode).--      indexFile     <- tryGetIndexFilePath verbosity config-      maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-        (compilerId comp) platform+            (fromFlag (configUserInstall configFlags'))+            (configPackageDBs configFlags') -    maybeWithSandboxDirOnSearchPath useSandbox $-      withRepoContext verbosity globalFlags' $ \repoContext ->+    withRepoContext verbosity globalFlags' $ \repoContext ->         configure verbosity packageDBs repoContext-                  comp platform progdb configFlags'' configExFlags' extraArgs+                  comp platform progdb configFlags' configExFlags' extraArgs  reconfigureAction :: (ConfigFlags, ConfigExFlags)                   -> [String] -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+  config <- updateInstallDirs (configUserInstall configFlags)                           <$> loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (configDistPref configFlags)   let checkFlags = Check $ \_ saved -> do@@ -442,26 +371,23 @@   nixInstantiate verbosity distPref True globalFlags config   _ <-     reconfigure configureAction-    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    verbosity distPref NoFlag     checkFlags [] globalFlags config   pure () -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do+buildAction :: BuildFlags -> [String] -> Action+buildAction buildFlags extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)-      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (buildDistPref buildFlags)   -- Calls 'configureAction' to do the real work, so nothing special has to be   -- done to support sandboxes.   config' <-     reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    verbosity distPref (buildNumJobs buildFlags)     mempty [] globalFlags config   nixShell verbosity distPref globalFlags config $ do-    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags extraArgs+    build verbosity config' distPref buildFlags extraArgs   -- | Actually do the work of building the package. This is separate from@@ -501,10 +427,10 @@     numJobsCmdLineFlag = buildNumJobs buildFlags  -replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action-replAction (replFlags, buildExFlags) extraArgs globalFlags = do+replAction :: ReplFlags -> [String] -> Action+replAction replFlags extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (replDistPref replFlags)   cwd     <- getCurrentDirectory   pkgDesc <- findPackageDesc cwd@@ -512,16 +438,11 @@     -- There is a .cabal file in the current directory: start a REPL and load     -- the project's modules.     onPkgDesc = do-      let noAddSource = case replReload replFlags of-            Flag True -> SkipAddSourceDepsCheck-            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck-                        (buildOnly buildExFlags)-       -- Calls 'configureAction' to do the real work, so nothing special has to       -- be done to support sandboxes.       _ <-         reconfigure configureAction-        verbosity distPref useSandbox noAddSource NoFlag+        verbosity distPref NoFlag         mempty [] globalFlags config       let progDb = defaultProgramDb           setupOptions = defaultSetupScriptOptions@@ -533,10 +454,8 @@             , replDistPref  = toFlag distPref             } -      nixShell verbosity distPref globalFlags config $ do-        maybeWithSandboxDirOnSearchPath useSandbox $-          setupWrapper verbosity setupOptions Nothing-          (Cabal.replCommand progDb) (const replFlags') (const extraArgs)+      nixShell verbosity distPref globalFlags config $+        setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs)      -- No .cabal file in the current directory: just start the REPL (possibly     -- using the sandbox package DB).@@ -559,11 +478,10 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags   | fromFlagOrDefault False (installOnly installFlags) = do       let verb = fromFlagOrDefault normal (configVerbosity configFlags)-      (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags+      config <- loadConfigOrSandboxConfig verb globalFlags       dist <- findSavedDistPref config (configDistPref configFlags)       let setupOpts = defaultSetupScriptOptions { useDistPref = dist }-      nixShellIfSandboxed verb dist globalFlags config useSandbox $-        setupWrapper+      setupWrapper         verb setupOpts Nothing         installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty))                        (const [])@@ -573,29 +491,14 @@   , haddockFlags, testFlags, benchmarkFlags )   extraArgs globalFlags = do   let verb = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+  config <- updateInstallDirs (configUserInstall configFlags)                           <$> loadConfigOrSandboxConfig verb globalFlags -  let sandboxDist =-        case useSandbox of-          NoSandbox             -> NoFlag-          UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-  dist <- findSavedDistPref config-          (configDistPref configFlags `mappend` sandboxDist)+  dist <- findSavedDistPref config (configDistPref configFlags) -  nixShellIfSandboxed verb dist globalFlags config useSandbox $ do+  do     targets <- readUserTargets verb extraArgs -    -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to-    -- 'configure' when run inside a sandbox.  Right now, running-    ---    -- \$ cabal sandbox init && cabal configure -w /path/to/ghc-    --   && cabal build && cabal install-    ---    -- performs the compilation twice unless you also pass -w to 'install'.-    -- However, this is the same behaviour that 'cabal install' has in the normal-    -- mode of operation, so we stick to it for consistency.-     let configFlags'    = maybeForceTests installFlags' $                           savedConfigureFlags   config `mappend`                           configFlags { configDistPref = toFlag dist }@@ -614,39 +517,18 @@                           benchmarkFlags { benchmarkDistPref = toFlag dist }         globalFlags'    = savedGlobalFlags      config `mappend` globalFlags     (comp, platform, progdb) <- configCompilerAux' configFlags'+     -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the     -- future.     progdb' <- configureAllKnownPrograms verb progdb -    -- If we're working inside a sandbox and the user has set the -w option, we-    -- may need to create a sandbox-local package DB for this compiler and add a-    -- timestamp record for this compiler to the timestamp file.-    configFlags'' <- case useSandbox of-      NoSandbox               -> configAbsolutePaths $ configFlags'-      (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform-                                                      configFlags'--    whenUsingSandbox useSandbox $ \sandboxDir -> do-      initPackageDBIfNeeded verb configFlags'' comp progdb'--      indexFile     <- tryGetIndexFilePath verb config-      maybeAddCompilerTimestampRecord verb sandboxDir indexFile-        (compilerId comp) platform+    configFlags'' <- configAbsolutePaths configFlags' -    -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means-    -- that 'cabal install some-package' inside a sandbox will sometimes reinstall-    -- modified add-source deps, even if they are not among the dependencies of-    -- 'some-package'. This can also prevent packages that depend on older-    -- versions of add-source'd packages from building (see #1362).-    maybeWithSandboxPackageInfo verb configFlags'' globalFlags'-                                comp platform progdb useSandbox $ \mSandboxPkgInfo ->-                                maybeWithSandboxDirOnSearchPath useSandbox $-      withRepoContext verb globalFlags' $ \repoContext ->+    withRepoContext verb globalFlags' $ \repoContext ->         install verb                 (configPackageDB' configFlags'')                 repoContext                 comp platform progdb'-                useSandbox mSandboxPkgInfo                 globalFlags' configFlags'' configExFlags'                 installFlags' haddockFlags' testFlags' benchmarkFlags'                 targets@@ -658,15 +540,13 @@           then configFlags' { configTests = toFlag True }           else configFlags' -testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags+testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags            -> IO ()-testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+testAction (buildFlags, testFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal (buildVerbosity buildFlags)+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (testDistPref testFlags)-  let noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck-                      (buildOnly buildExFlags)-      buildFlags'    = buildFlags+  let buildFlags'    = buildFlags                       { buildVerbosity = testVerbosity testFlags }       checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->         if fromFlagOrDefault False (configTests configFlags)@@ -678,11 +558,9 @@                         )             pure (Any True, flags') -  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.   _ <-     reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    verbosity distPref (buildNumJobs buildFlags')     checkFlags [] globalFlags config   nixShell verbosity distPref globalFlags config $ do     let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }@@ -698,12 +576,8 @@                                     | LBI.CTestName name <- names' ]           | otherwise      = extraArgs -    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config distPref buildFlags' extraArgs'--    maybeWithSandboxDirOnSearchPath useSandbox $-      setupWrapper verbosity setupOptions Nothing-      Cabal.testCommand (const testFlags') (const extraArgs')+    build verbosity config distPref buildFlags' extraArgs'+    setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs')  data ComponentNames = ComponentNamesUnknown                     | ComponentNames [LBI.ComponentName]@@ -734,21 +608,19 @@          else return $! (ComponentNames names) -benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)+benchmarkAction :: (BuildFlags, BenchmarkFlags)                    -> [String] -> GlobalFlags                    -> IO () benchmarkAction-  (benchmarkFlags, buildFlags, buildExFlags)+  (buildFlags, benchmarkFlags)   extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal-                       (benchmarkVerbosity benchmarkFlags)+                       (buildVerbosity buildFlags) -  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)   let buildFlags'    = buildFlags                       { buildVerbosity = benchmarkVerbosity benchmarkFlags }-      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck-                      (buildOnly buildExFlags)    let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->         if fromFlagOrDefault False (configBenchmarks configFlags)@@ -760,12 +632,9 @@                         )             pure (Any True, flags') --  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.   config' <-     reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    verbosity distPref (buildNumJobs buildFlags')     checkFlags [] globalFlags config   nixShell verbosity distPref globalFlags config $ do     let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }@@ -781,21 +650,17 @@                                     | LBI.CBenchName name <- names']           | otherwise      = extraArgs -    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags' extraArgs'--    maybeWithSandboxDirOnSearchPath useSandbox $-      setupWrapper verbosity setupOptions Nothing-      Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')+    build verbosity config' distPref buildFlags' extraArgs'+    setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')  haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do   let verbosity = fromFlag (haddockVerbosity haddockFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (haddockDistPref haddockFlags)   config' <-     reconfigure configureAction-    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    verbosity distPref NoFlag     mempty [] globalFlags config   nixShell verbosity distPref globalFlags config $ do     let haddockFlags' = defaultHaddockFlags      `mappend`@@ -823,7 +688,7 @@ cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do   load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-  let config = either (\(SomeException _) -> mempty) snd load+  let config = either (\(SomeException _) -> mempty) id load   distPref <- findSavedDistPref config (cleanDistPref cleanFlags)   let setupScriptOptions = defaultSetupScriptOptions                            { useDistPref = distPref@@ -838,21 +703,24 @@ listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags' = savedConfigureFlags config-      configFlags  = configFlags' {-        configPackageDBs = configPackageDBs configFlags'+      configFlags  = configFlags'+        { configPackageDBs = configPackageDBs configFlags'                            `mappend` listPackageDBs listFlags+        , configHcPath     = listHcPath listFlags         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAux' configFlags+  compProgdb <- if listNeedsCompiler listFlags +      then do+          (comp, _, progdb) <- configCompilerAux' configFlags+          return (Just (comp, progdb))+      else return Nothing   withRepoContext verbosity globalFlags' $ \repoContext ->     List.list verbosity        (configPackageDB' configFlags)        repoContext-       comp-       progdb+       compProgdb        listFlags        extraArgs @@ -860,8 +728,7 @@ infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags' = savedConfigureFlags config       configFlags  = configFlags' {         configPackageDBs = configPackageDBs configFlags'@@ -884,30 +751,11 @@   let verbosity = fromFlag (updateVerbosity updateFlags)   unless (null extraArgs) $     die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let globalFlags' = savedGlobalFlags config `mappend` globalFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     update verbosity updateFlags repoContext -upgradeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags-                 , HaddockFlags, TestFlags, BenchmarkFlags )-              -> [String] -> Action-upgradeAction (configFlags, _, _, _, _, _) _ _ = die' verbosity $-    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"- ++ "You can install the latest version of a package using 'cabal install'. "- ++ "The 'cabal upgrade' command has been removed because people found it "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."- where-  verbosity = fromFlag (configVerbosity configFlags)- fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do   let verbosity = fromFlag (fetchVerbosity fetchFlags)@@ -926,51 +774,41 @@ freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do   let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config NoFlag   nixShell verbosity distPref globalFlags config $ do     let configFlags  = savedConfigureFlags config         globalFlags' = savedGlobalFlags config `mappend` globalFlags     (comp, platform, progdb) <- configCompilerAux' configFlags -    maybeWithSandboxPackageInfo-      verbosity configFlags globalFlags'-      comp platform progdb useSandbox $ \mSandboxPkgInfo ->-        maybeWithSandboxDirOnSearchPath useSandbox $-        withRepoContext verbosity globalFlags' $ \repoContext ->-          freeze verbosity+    withRepoContext verbosity globalFlags' $ \repoContext ->+        freeze verbosity             (configPackageDB' configFlags)             repoContext             comp platform progdb-            mSandboxPkgInfo             globalFlags' freezeFlags  genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do   let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config NoFlag   nixShell verbosity distPref globalFlags config $ do     let configFlags  = savedConfigureFlags config         globalFlags' = savedGlobalFlags config `mappend` globalFlags     (comp, platform, progdb) <- configCompilerAux' configFlags -    maybeWithSandboxPackageInfo-      verbosity configFlags globalFlags'-      comp platform progdb useSandbox $ \mSandboxPkgInfo ->-        maybeWithSandboxDirOnSearchPath useSandbox $-        withRepoContext verbosity globalFlags' $ \repoContext ->-          genBounds verbosity+    withRepoContext verbosity globalFlags' $ \repoContext ->+        genBounds verbosity                 (configPackageDB' configFlags)                 repoContext                 comp platform progdb-                mSandboxPkgInfo                 globalFlags' freezeFlags  outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () outdatedAction outdatedFlags _extraArgs globalFlags = do   let verbosity = fromFlag (outdatedVerbosity outdatedFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, _progdb) <- configCompilerAux' configFlags@@ -1060,29 +898,6 @@   -- Uses 'writeFileAtomic' under the hood.   writeGenericPackageDescription path pkgDesc -uninstallAction :: Flag Verbosity -> [String] -> Action-uninstallAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag-      package = case extraArgs of-        p:_ -> p-        _   -> "PACKAGE_NAME"-  die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' "-    ++ "operation. "-    ++ "It will likely be implemented at some point in the future; "-    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "-    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."---sdistAction :: SDistFlags -> [String] -> Action-sdistAction sdistFlags extraArgs globalFlags = do-  let verbosity = fromFlag (sDistVerbosity sdistFlags)-  unless (null extraArgs) $-    die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs-  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-  let config = either (\(SomeException _) -> mempty) snd load-  distPref <- findSavedDistPref config (sDistDistPref sdistFlags)-  sdist sdistFlags { sDistDistPref = toFlag distPref }- reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do   let verbosity = fromFlag (reportVerbosity reportFlags)@@ -1097,35 +912,27 @@     (flagToMaybe $ reportUsername reportFlags')     (flagToMaybe $ reportPassword reportFlags') -runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-runAction (buildFlags, buildExFlags) extraArgs globalFlags = do+runAction :: BuildFlags -> [String] -> Action+runAction buildFlags extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (buildDistPref buildFlags)-  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)-  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.   config' <-     reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    verbosity distPref (buildNumJobs buildFlags)     mempty [] globalFlags config   nixShell verbosity distPref globalFlags config $ do     lbi <- getPersistBuildConfig distPref     (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs -    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]--    maybeWithSandboxDirOnSearchPath useSandbox $-      run verbosity lbi exe exeArgs+    build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]+    run verbosity lbi exe exeArgs  getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do   let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let globalFlags' = savedGlobalFlags config `mappend` globalFlags   withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->    get verbosity@@ -1143,8 +950,7 @@   let verbosity = fromFlag (initVerbosity initFlags)   when (extraArgs /= []) $     die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })+  config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config `mappend`                      -- override with `--with-compiler` from CLI if available                      mempty { configHcPath = initHcPath initFlags }@@ -1159,78 +965,35 @@             progdb             initFlags' -sandboxAction :: SandboxFlags -> [String] -> Action-sandboxAction sandboxFlags extraArgs globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  case extraArgs of-    -- Basic sandbox commands.-    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags-    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags-    ("add-source":extra) -> do-        when (noExtraArgs extra) $-          die' verbosity "The 'sandbox add-source' command expects at least one argument"-        sandboxAddSource verbosity extra sandboxFlags globalFlags-    ("delete-source":extra) -> do-        when (noExtraArgs extra) $-          die' verbosity ("The 'sandbox delete-source' command expects " ++-              "at least one argument")-        sandboxDeleteSource verbosity extra sandboxFlags globalFlags-    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags--    -- More advanced commands.-    ("hc-pkg":extra) -> do-        when (noExtraArgs extra) $-            die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument"-        sandboxHcPkg verbosity sandboxFlags globalFlags extra-    ["buildopts"] -> die' verbosity "Not implemented!"--    -- Hidden commands.-    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags--    -- Error handling.-    [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')"-    _  -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs--  where-    noExtraArgs = (<1) . length- execAction :: ExecFlags -> [String] -> Action execAction execFlags extraArgs globalFlags = do   let verbosity = fromFlag (execVerbosity execFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (execDistPref execFlags)   let configFlags = savedConfigureFlags config       configFlags' = configFlags { configDistPref = Flag distPref }   (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags'-  exec verbosity useSandbox comp platform progdb extraArgs+  exec verbosity comp platform progdb extraArgs  userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do   let verbosity  = fromFlag (userConfigVerbosity ucflags)-      force      = fromFlag (userConfigForce ucflags)+      frc        = fromFlag (userConfigForce ucflags)       extraLines = fromFlag (userConfigAppendLines ucflags)   case extraArgs of     ("init":_) -> do       path       <- configFile       fileExists <- doesFileExist path-      if (not fileExists || (fileExists && force))+      if (not fileExists || (fileExists && frc))       then void $ createDefaultConfigFile verbosity extraLines path       else die' verbosity $ path ++ " already exists."-    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines+    ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines     ("update":_) -> userConfigUpdate verbosity globalFlags extraLines     -- Error handling.     [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"     _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs   where configFile = getConfigFilePath (globalConfigFile globalFlags) --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.----win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action-win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do-  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)-  Win32SelfUpgrade.deleteOldExeFile verbosity (fromMaybe (error $ "panic! read pid=" ++ show pid) $ readMaybe pid) path -- TODO: eradicateNoParse-win32SelfUpgradeAction _ _ _ = return ()- -- | Used as an entry point when cabal-install needs to invoke itself -- as a setup script. This can happen e.g. when doing parallel builds. --@@ -1244,13 +1007,13 @@     Make      -> Make.defaultMainArgs args     Custom    -> error "actAsSetupAction Custom" -manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action-manpageAction commands flagVerbosity extraArgs _ = do-  let verbosity = fromFlag flagVerbosity+manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action+manpageAction commands flags extraArgs _ = do+  let verbosity = fromFlag (manpageVerbosity flags)   unless (null extraArgs) $     die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs   pname <- getProgName   let cabalCmd = if takeExtension pname == ".exe"                  then dropExtension pname                  else pname-  putStrLn $ manpage cabalCmd commands+  manpageCmd cabalCmd commands flags
tests/IntegrationTests2/targets/complex/q/q.cabal view
@@ -5,7 +5,8 @@  library   exposed-modules: Q-  build-depends: base, filepath+  -- we rely that filepath has filepath-tests component+  build-depends: base, filepath >=1.4.0.0  executable buildable-false   main-is: Main.hs
+ tests/IntegrationTests2/targets/simple/app/Main.hs view
tests/IntegrationTests2/targets/simple/p.cabal view
@@ -10,3 +10,8 @@ executable pexe   main-is: Main.hs   other-modules: PMain++executable ppexe+  main-is: Main.hs+  hs-source-dirs: app+  other-modules: PMain
+ tests/IntegrationTests2/targets/simple/q/Q.hs view
tests/IntegrationTests2/targets/simple/q/q.cabal view
@@ -5,6 +5,7 @@  library   exposed-modules: QQ+  other-modules: Q   build-depends: base  executable qexe