diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Lens.hs b/Distribution/Client/BuildReports/Lens.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Lens.hs @@ -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)) diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs --- a/Distribution/Client/BuildReports/Storage.hs +++ b/Distribution/Client/BuildReports/Storage.hs @@ -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 ] diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs --- a/Distribution/Client/BuildReports/Types.hs +++ b/Distribution/Client/BuildReports/Types.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -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)), diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -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 diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs --- a/Distribution/Client/CmdBench.hs +++ b/Distribution/Client/CmdBench.hs @@ -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 " diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -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 = diff --git a/Distribution/Client/CmdClean.hs b/Distribution/Client/CmdClean.hs --- a/Distribution/Client/CmdClean.hs +++ b/Distribution/Client/CmdClean.hs @@ -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 diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs --- a/Distribution/Client/CmdConfigure.hs +++ b/Distribution/Client/CmdConfigure.hs @@ -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 <> "'" diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs --- a/Distribution/Client/CmdErrorMessages.hs +++ b/Distribution/Client/CmdErrorMessages.hs @@ -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 diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs --- a/Distribution/Client/CmdExec.hs +++ b/Distribution/Client/CmdExec.hs @@ -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} diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs --- a/Distribution/Client/CmdFreeze.hs +++ b/Distribution/Client/CmdFreeze.hs @@ -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. diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs --- a/Distribution/Client/CmdHaddock.hs +++ b/Distribution/Client/CmdHaddock.hs @@ -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 diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs --- a/Distribution/Client/CmdInstall.hs +++ b/Distribution/Client/CmdInstall.hs @@ -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=" + ++ "or use --installdir=. 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 = diff --git a/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/Distribution/Client/CmdInstall/ClientInstallFlags.hs --- a/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -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 diff --git a/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -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)) + ] diff --git a/Distribution/Client/CmdLegacy.hs b/Distribution/Client/CmdLegacy.hs --- a/Distribution/Client/CmdLegacy.hs +++ b/Distribution/Client/CmdLegacy.hs @@ -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 } diff --git a/Distribution/Client/CmdListBin.hs b/Distribution/Client/CmdListBin.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdListBin.hs @@ -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." diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -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." - diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -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." diff --git a/Distribution/Client/CmdRun/ClientRunFlags.hs b/Distribution/Client/CmdRun/ClientRunFlags.hs deleted file mode 100644 --- a/Distribution/Client/CmdRun/ClientRunFlags.hs +++ /dev/null @@ -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 - ] diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs --- a/Distribution/Client/CmdSdist.hs +++ b/Distribution/Client/CmdSdist.hs @@ -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 -- diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs --- a/Distribution/Client/CmdTest.hs +++ b/Distribution/Client/CmdTest.hs @@ -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 " diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs --- a/Distribution/Client/CmdUpdate.hs +++ b/Distribution/Client/CmdUpdate.hs @@ -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 [,] 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" diff --git a/Distribution/Client/Compat/Directory.hs b/Distribution/Client/Compat/Directory.hs --- a/Distribution/Client/Compat/Directory.hs +++ b/Distribution/Client/Compat/Directory.hs @@ -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 diff --git a/Distribution/Client/Compat/ExecutablePath.hs b/Distribution/Client/Compat/ExecutablePath.hs --- a/Distribution/Client/Compat/ExecutablePath.hs +++ b/Distribution/Client/Compat/ExecutablePath.hs @@ -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. diff --git a/Distribution/Client/Compat/FilePerms.hs b/Distribution/Client/Compat/FilePerms.hs --- a/Distribution/Client/Compat/FilePerms.hs +++ b/Distribution/Client/Compat/FilePerms.hs @@ -6,6 +6,8 @@ setFileHidden, ) where +import Prelude (FilePath, IO, return, ($)) + #ifndef mingw32_HOST_OS import System.Posix.Types ( FileMode ) diff --git a/Distribution/Client/Compat/Orphans.hs b/Distribution/Client/Compat/Orphans.hs --- a/Distribution/Client/Compat/Orphans.hs +++ b/Distribution/Client/Compat/Orphans.hs @@ -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" [] diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs --- a/Distribution/Client/Compat/Prelude.hs +++ b/Distribution/Client/Compat/Prelude.hs @@ -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) diff --git a/Distribution/Client/Compat/Process.hs b/Distribution/Client/Compat/Process.hs --- a/Distribution/Client/Compat/Process.hs +++ b/Distribution/Client/Compat/Process.hs @@ -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 diff --git a/Distribution/Client/Compat/Semaphore.hs b/Distribution/Client/Compat/Semaphore.hs --- a/Distribution/Client/Compat/Semaphore.hs +++ b/Distribution/Client/Compat/Semaphore.hs @@ -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) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -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 diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -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 diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -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) diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -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. diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -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 diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs --- a/Distribution/Client/Exec.hs +++ b/Distribution/Client/Exec.hs @@ -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 diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -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) diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -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"] } diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs --- a/Distribution/Client/FileMonitor.hs +++ b/Distribution/Client/FileMonitor.hs @@ -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) diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs --- a/Distribution/Client/Freeze.hs +++ b/Distribution/Client/Freeze.hs @@ -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 diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs --- a/Distribution/Client/GZipUtils.hs +++ b/Distribution/Client/GZipUtils.hs @@ -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) diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -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 diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -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) $ diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs --- a/Distribution/Client/Glob.hs +++ b/Distribution/Client/Glob.hs @@ -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 diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs --- a/Distribution/Client/GlobalFlags.hs +++ b/Distribution/Client/GlobalFlags.hs @@ -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 ] diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -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 diff --git a/Distribution/Client/HashValue.hs b/Distribution/Client/HashValue.hs --- a/Distribution/Client/HashValue.hs +++ b/Distribution/Client/HashValue.hs @@ -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) ----------------------------------------------- diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -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 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 ] diff --git a/Distribution/Client/IndexUtils/ActiveRepos.hs b/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -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 diff --git a/Distribution/Client/IndexUtils/IndexState.hs b/Distribution/Client/IndexUtils/IndexState.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/IndexUtils/IndexState.hs @@ -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 diff --git a/Distribution/Client/IndexUtils/Timestamp.hs b/Distribution/Client/IndexUtils/Timestamp.hs --- a/Distribution/Client/IndexUtils/Timestamp.hs +++ b/Distribution/Client/IndexUtils/Timestamp.hs @@ -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 diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -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 ) diff --git a/Distribution/Client/Init/Command.hs b/Distribution/Client/Init/Command.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Command.hs @@ -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." diff --git a/Distribution/Client/Init/Defaults.hs b/Distribution/Client/Init/Defaults.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Defaults.hs @@ -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" diff --git a/Distribution/Client/Init/FileCreators.hs b/Distribution/Client/Init/FileCreators.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/FileCreators.hs @@ -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 diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -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 ] diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs --- a/Distribution/Client/Init/Licenses.hs +++ b/Distribution/Client/Init/Licenses.hs @@ -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 diff --git a/Distribution/Client/Init/Prompt.hs b/Distribution/Client/Init/Prompt.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Prompt.hs @@ -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 diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -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 ] ] diff --git a/Distribution/Client/Init/Utils.hs b/Distribution/Client/Init/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Utils.hs @@ -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 diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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 [] diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -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" diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -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 diff --git a/Distribution/Client/JobControl.hs b/Distribution/Client/JobControl.hs --- a/Distribution/Client/JobControl.hs +++ b/Distribution/Client/JobControl.hs @@ -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 diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -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) diff --git a/Distribution/Client/Manpage.hs b/Distribution/Client/Manpage.hs --- a/Distribution/Client/Manpage.hs +++ b/Distribution/Client/Manpage.hs @@ -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 diff --git a/Distribution/Client/ManpageFlags.hs b/Distribution/Client/ManpageFlags.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/ManpageFlags.hs @@ -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 + ] diff --git a/Distribution/Client/Nix.hs b/Distribution/Client/Nix.hs --- a/Distribution/Client/Nix.hs +++ b/Distribution/Client/Nix.hs @@ -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 diff --git a/Distribution/Client/NixStyleOptions.hs b/Distribution/Client/NixStyleOptions.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/NixStyleOptions.hs @@ -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 + } diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs --- a/Distribution/Client/Outdated.hs +++ b/Distribution/Client/Outdated.hs @@ -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 = diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -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 diff --git a/Distribution/Client/PackageUtils.hs b/Distribution/Client/PackageUtils.hs deleted file mode 100644 --- a/Distribution/Client/PackageUtils.hs +++ /dev/null @@ -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) diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs --- a/Distribution/Client/ParseUtils.hs +++ b/Distribution/Client/ParseUtils.hs @@ -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 diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -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 diff --git a/Distribution/Client/ProjectBuilding/Types.hs b/Distribution/Client/ProjectBuilding/Types.hs --- a/Distribution/Client/ProjectBuilding/Types.hs +++ b/Distribution/Client/ProjectBuilding/Types.hs @@ -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) ------------------------------------------------------------------------------ diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -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 diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -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 diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -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, diff --git a/Distribution/Client/ProjectFlags.hs b/Distribution/Client/ProjectFlags.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/ProjectFlags.hs @@ -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 diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -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 diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -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 diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -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 diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -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: diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs --- a/Distribution/Client/RebuildMonad.hs +++ b/Distribution/Client/RebuildMonad.hs @@ -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 diff --git a/Distribution/Client/Reconfigure.hs b/Distribution/Client/Reconfigure.hs --- a/Distribution/Client/Reconfigure.hs +++ b/Distribution/Client/Reconfigure.hs @@ -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) diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs --- a/Distribution/Client/Run.hs +++ b/Distribution/Client/Run.hs @@ -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' diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -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) -- diff --git a/Distribution/Client/Sandbox/Index.hs b/Distribution/Client/Sandbox/Index.hs deleted file mode 100644 --- a/Distribution/Client/Sandbox/Index.hs +++ /dev/null @@ -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 ++ "'" diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -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 diff --git a/Distribution/Client/Sandbox/Timestamp.hs b/Distribution/Client/Sandbox/Timestamp.hs deleted file mode 100644 --- a/Distribution/Client/Sandbox/Timestamp.hs +++ /dev/null @@ -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 ." diff --git a/Distribution/Client/Sandbox/Types.hs b/Distribution/Client/Sandbox/Types.hs deleted file mode 100644 --- a/Distribution/Client/Sandbox/Types.hs +++ /dev/null @@ -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. - } diff --git a/Distribution/Client/SavedFlags.hs b/Distribution/Client/SavedFlags.hs --- a/Distribution/Client/SavedFlags.hs +++ b/Distribution/Client/SavedFlags.hs @@ -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) diff --git a/Distribution/Client/Security/DNS.hs b/Distribution/Client/Security/DNS.hs --- a/Distribution/Client/Security/DNS.hs +++ b/Distribution/Client/Security/DNS.hs @@ -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 diff --git a/Distribution/Client/Security/HTTP.hs b/Distribution/Client/Security/HTTP.hs --- a/Distribution/Client/Security/HTTP.hs +++ b/Distribution/Client/Security/HTTP.hs @@ -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 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) diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 = diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -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 diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs --- a/Distribution/Client/SolverInstallPlan.hs +++ b/Distribution/Client/SolverInstallPlan.hs @@ -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])) diff --git a/Distribution/Client/SourceFiles.hs b/Distribution/Client/SourceFiles.hs --- a/Distribution/Client/SourceFiles.hs +++ b/Distribution/Client/SourceFiles.hs @@ -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) diff --git a/Distribution/Client/SourceRepo.hs b/Distribution/Client/SourceRepo.hs deleted file mode 100644 --- a/Distribution/Client/SourceRepo.hs +++ /dev/null @@ -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 #-} diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -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 diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs --- a/Distribution/Client/Store.hs +++ b/Distribution/Client/Store.hs @@ -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 diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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 diff --git a/Distribution/Client/TargetProblem.hs b/Distribution/Client/TargetProblem.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/TargetProblem.hs @@ -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 diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs --- a/Distribution/Client/TargetSelector.hs +++ b/Distribution/Client/TargetSelector.hs @@ -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 ------------------------------ diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -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 diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -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 diff --git a/Distribution/Client/Types/AllowNewer.hs b/Distribution/Client/Types/AllowNewer.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/AllowNewer.hs @@ -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 = (<>) diff --git a/Distribution/Client/Types/BuildResults.hs b/Distribution/Client/Types/BuildResults.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/BuildResults.hs @@ -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 diff --git a/Distribution/Client/Types/ConfiguredId.hs b/Distribution/Client/Types/ConfiguredId.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/ConfiguredId.hs @@ -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) diff --git a/Distribution/Client/Types/ConfiguredPackage.hs b/Distribution/Client/Types/ConfiguredPackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/ConfiguredPackage.hs @@ -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 + + + diff --git a/Distribution/Client/Types/Credentials.hs b/Distribution/Client/Types/Credentials.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/Credentials.hs @@ -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 } diff --git a/Distribution/Client/Types/InstallMethod.hs b/Distribution/Client/Types/InstallMethod.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/InstallMethod.hs @@ -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" diff --git a/Distribution/Client/Types/OverwritePolicy.hs b/Distribution/Client/Types/OverwritePolicy.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/OverwritePolicy.hs @@ -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" diff --git a/Distribution/Client/Types/PackageLocation.hs b/Distribution/Client/Types/PackageLocation.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/PackageLocation.hs @@ -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 diff --git a/Distribution/Client/Types/PackageSpecifier.hs b/Distribution/Client/Types/PackageSpecifier.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/PackageSpecifier.hs @@ -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)) diff --git a/Distribution/Client/Types/ReadyPackage.hs b/Distribution/Client/Types/ReadyPackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/ReadyPackage.hs @@ -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) diff --git a/Distribution/Client/Types/Repo.hs b/Distribution/Client/Types/Repo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/Repo.hs @@ -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 diff --git a/Distribution/Client/Types/RepoName.hs b/Distribution/Client/Types/RepoName.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/RepoName.hs @@ -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 == '.') diff --git a/Distribution/Client/Types/SourcePackageDb.hs b/Distribution/Client/Types/SourcePackageDb.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/SourcePackageDb.hs @@ -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 diff --git a/Distribution/Client/Types/SourceRepo.hs b/Distribution/Client/Types/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/SourceRepo.hs @@ -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 #-} diff --git a/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -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 diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -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" diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -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 -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 () diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -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 diff --git a/Distribution/Client/Utils/Assertion.hs b/Distribution/Client/Utils/Assertion.hs --- a/Distribution/Client/Utils/Assertion.hs +++ b/Distribution/Client/Utils/Assertion.hs @@ -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 diff --git a/Distribution/Client/Utils/Json.hs b/Distribution/Client/Utils/Json.hs --- a/Distribution/Client/Utils/Json.hs +++ b/Distribution/Client/Utils/Json.hs @@ -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 diff --git a/Distribution/Client/VCS.hs b/Distribution/Client/VCS.hs --- a/Distribution/Client/VCS.hs +++ b/Distribution/Client/VCS.hs @@ -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 +-- +-- 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 == '.' diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs --- a/Distribution/Client/Win32SelfUpgrade.hs +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -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 diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -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 '"') diff --git a/Distribution/Deprecated/ParseUtils.hs b/Distribution/Deprecated/ParseUtils.hs --- a/Distribution/Deprecated/ParseUtils.hs +++ b/Distribution/Deprecated/ParseUtils.hs @@ -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 diff --git a/Distribution/Deprecated/Text.hs b/Distribution/Deprecated/Text.hs deleted file mode 100644 --- a/Distribution/Deprecated/Text.hs +++ /dev/null @@ -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 diff --git a/Distribution/Deprecated/ViewAsFieldDescr.hs b/Distribution/Deprecated/ViewAsFieldDescr.hs --- a/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -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) diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs --- a/Distribution/Solver/Modular.hs +++ b/Distribution/Solver/Modular.hs @@ -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 diff --git a/Distribution/Solver/Modular/Assignment.hs b/Distribution/Solver/Modular/Assignment.hs --- a/Distribution/Solver/Modular/Assignment.hs +++ b/Distribution/Solver/Modular/Assignment.hs @@ -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 diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs --- a/Distribution/Solver/Modular/Builder.hs +++ b/Distribution/Solver/Modular/Builder.hs @@ -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. -- diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs --- a/Distribution/Solver/Modular/Dependency.hs +++ b/Distribution/Solver/Modular/Dependency.hs @@ -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 diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs --- a/Distribution/Solver/Modular/Explore.hs +++ b/Distribution/Solver/Modular/Explore.hs @@ -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) = diff --git a/Distribution/Solver/Modular/Index.hs b/Distribution/Solver/Modular/Index.hs --- a/Distribution/Solver/Modular/Index.hs +++ b/Distribution/Solver/Modular/Index.hs @@ -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)) diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs --- a/Distribution/Solver/Modular/IndexConversion.hs +++ b/Distribution/Solver/Modular/IndexConversion.hs @@ -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 ] diff --git a/Distribution/Solver/Modular/LabeledGraph.hs b/Distribution/Solver/Modular/LabeledGraph.hs --- a/Distribution/Solver/Modular/LabeledGraph.hs +++ b/Distribution/Solver/Modular/LabeledGraph.hs @@ -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 {------------------------------------------------------------------------------- diff --git a/Distribution/Solver/Modular/Linking.hs b/Distribution/Solver/Modular/Linking.hs --- a/Distribution/Solver/Modular/Linking.hs +++ b/Distribution/Solver/Modular/Linking.hs @@ -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 () diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs --- a/Distribution/Solver/Modular/Message.hs +++ b/Distribution/Solver/Modular/Message.hs @@ -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 diff --git a/Distribution/Solver/Modular/Package.hs b/Distribution/Solver/Modular/Package.hs --- a/Distribution/Solver/Modular/Package.hs +++ b/Distribution/Solver/Modular/Package.hs @@ -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 diff --git a/Distribution/Solver/Modular/Preference.hs b/Distribution/Solver/Modular/Preference.hs --- a/Distribution/Solver/Modular/Preference.hs +++ b/Distribution/Solver/Modular/Preference.hs @@ -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 diff --git a/Distribution/Solver/Modular/RetryLog.hs b/Distribution/Solver/Modular/RetryLog.hs --- a/Distribution/Solver/Modular/RetryLog.hs +++ b/Distribution/Solver/Modular/RetryLog.hs @@ -11,6 +11,9 @@ , tryWith ) where +import Distribution.Solver.Compat.Prelude +import Prelude () + import Distribution.Solver.Modular.Message import Distribution.Solver.Types.Progress diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs --- a/Distribution/Solver/Modular/Solver.hs +++ b/Distribution/Solver/Modular/Solver.hs @@ -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 $ diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs --- a/Distribution/Solver/Modular/Tree.hs +++ b/Distribution/Solver/Modular/Tree.hs @@ -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 diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs --- a/Distribution/Solver/Modular/Validate.hs +++ b/Distribution/Solver/Modular/Validate.hs @@ -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. diff --git a/Distribution/Solver/Modular/Version.hs b/Distribution/Solver/Modular/Version.hs --- a/Distribution/Solver/Modular/Version.hs +++ b/Distribution/Solver/Modular/Version.hs @@ -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 diff --git a/Distribution/Solver/Types/ComponentDeps.hs b/Distribution/Solver/Types/ComponentDeps.hs --- a/Distribution/Solver/Types/ComponentDeps.hs +++ b/Distribution/Solver/Types/ComponentDeps.hs @@ -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 diff --git a/Distribution/Solver/Types/ConstraintSource.hs b/Distribution/Solver/Types/ConstraintSource.hs --- a/Distribution/Solver/Types/ConstraintSource.hs +++ b/Distribution/Solver/Types/ConstraintSource.hs @@ -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 = diff --git a/Distribution/Solver/Types/DependencyResolver.hs b/Distribution/Solver/Types/DependencyResolver.hs --- a/Distribution/Solver/Types/DependencyResolver.hs +++ b/Distribution/Solver/Types/DependencyResolver.hs @@ -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 ) diff --git a/Distribution/Solver/Types/Flag.hs b/Distribution/Solver/Types/Flag.hs --- a/Distribution/Solver/Types/Flag.hs +++ b/Distribution/Solver/Types/Flag.hs @@ -2,5 +2,7 @@ ( FlagType(..) ) where +import Prelude (Eq, Show) + data FlagType = Manual | Automatic deriving (Eq, Show) diff --git a/Distribution/Solver/Types/InstSolverPackage.hs b/Distribution/Solver/Types/InstSolverPackage.hs --- a/Distribution/Solver/Types/InstSolverPackage.hs +++ b/Distribution/Solver/Types/InstSolverPackage.hs @@ -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. diff --git a/Distribution/Solver/Types/InstalledPreference.hs b/Distribution/Solver/Types/InstalledPreference.hs --- a/Distribution/Solver/Types/InstalledPreference.hs +++ b/Distribution/Solver/Types/InstalledPreference.hs @@ -2,6 +2,8 @@ ( InstalledPreference(..), ) where +import Prelude (Show) + -- | Whether we prefer an installed version of a package or simply the latest -- version. -- diff --git a/Distribution/Solver/Types/OptionalStanza.hs b/Distribution/Solver/Types/OptionalStanza.hs --- a/Distribution/Solver/Types/OptionalStanza.hs +++ b/Distribution/Solver/Types/OptionalStanza.hs @@ -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 diff --git a/Distribution/Solver/Types/PackageConstraint.hs b/Distribution/Solver/Types/PackageConstraint.hs --- a/Distribution/Solver/Types/PackageConstraint.hs +++ b/Distribution/Solver/Types/PackageConstraint.hs @@ -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 diff --git a/Distribution/Solver/Types/PackageIndex.hs b/Distribution/Solver/Types/PackageIndex.hs --- a/Distribution/Solver/Types/PackageIndex.hs +++ b/Distribution/Solver/Types/PackageIndex.hs @@ -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) + ] diff --git a/Distribution/Solver/Types/PackagePath.hs b/Distribution/Solver/Types/PackagePath.hs --- a/Distribution/Solver/Types/PackagePath.hs +++ b/Distribution/Solver/Types/PackagePath.hs @@ -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 diff --git a/Distribution/Solver/Types/PkgConfigDb.hs b/Distribution/Solver/Types/PkgConfigDb.hs --- a/Distribution/Solver/Types/PkgConfigDb.hs +++ b/Distribution/Solver/Types/PkgConfigDb.hs @@ -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) diff --git a/Distribution/Solver/Types/Progress.hs b/Distribution/Solver/Types/Progress.hs --- a/Distribution/Solver/Types/Progress.hs +++ b/Distribution/Solver/Types/Progress.hs @@ -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) diff --git a/Distribution/Solver/Types/ResolverPackage.hs b/Distribution/Solver/Types/ResolverPackage.hs --- a/Distribution/Solver/Types/ResolverPackage.hs +++ b/Distribution/Solver/Types/ResolverPackage.hs @@ -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. diff --git a/Distribution/Solver/Types/Settings.hs b/Distribution/Solver/Types/Settings.hs --- a/Distribution/Solver/Types/Settings.hs +++ b/Distribution/Solver/Types/Settings.hs @@ -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 ] diff --git a/Distribution/Solver/Types/SolverId.hs b/Distribution/Solver/Types/SolverId.hs --- a/Distribution/Solver/Types/SolverId.hs +++ b/Distribution/Solver/Types/SolverId.hs @@ -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 diff --git a/Distribution/Solver/Types/SolverPackage.hs b/Distribution/Solver/Types/SolverPackage.hs --- a/Distribution/Solver/Types/SolverPackage.hs +++ b/Distribution/Solver/Types/SolverPackage.hs @@ -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 diff --git a/Distribution/Solver/Types/SourcePackage.hs b/Distribution/Solver/Types/SourcePackage.hs --- a/Distribution/Solver/Types/SourcePackage.hs +++ b/Distribution/Solver/Types/SourcePackage.hs @@ -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. diff --git a/Distribution/Solver/Types/Variable.hs b/Distribution/Solver/Types/Variable.hs --- a/Distribution/Solver/Types/Variable.hs +++ b/Distribution/Solver/Types/Variable.hs @@ -1,5 +1,7 @@ module Distribution.Solver.Types.Variable where +import Prelude (Eq, Show) + import Distribution.Solver.Types.OptionalStanza import Distribution.PackageDescription (FlagName) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/bootstrap.sh b/bootstrap.sh deleted file mode 100644 --- a/bootstrap.sh +++ /dev/null @@ -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 diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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 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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,8 @@ -*-change-log-*- +3.4.0.0 Oleg Grenrus 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 April 2020 * `v2-build` (and other `v2-`prefixed commands) now accept the `--benchmark-option(s)` flags, which pass options to benchmark executables diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/tests/IntegrationTests2/targets/complex/q/q.cabal b/tests/IntegrationTests2/targets/complex/q/q.cabal --- a/tests/IntegrationTests2/targets/complex/q/q.cabal +++ b/tests/IntegrationTests2/targets/complex/q/q.cabal @@ -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 diff --git a/tests/IntegrationTests2/targets/simple/app/Main.hs b/tests/IntegrationTests2/targets/simple/app/Main.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/app/Main.hs diff --git a/tests/IntegrationTests2/targets/simple/p.cabal b/tests/IntegrationTests2/targets/simple/p.cabal --- a/tests/IntegrationTests2/targets/simple/p.cabal +++ b/tests/IntegrationTests2/targets/simple/p.cabal @@ -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 diff --git a/tests/IntegrationTests2/targets/simple/q/Q.hs b/tests/IntegrationTests2/targets/simple/q/Q.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/q/Q.hs diff --git a/tests/IntegrationTests2/targets/simple/q/q.cabal b/tests/IntegrationTests2/targets/simple/q/q.cabal --- a/tests/IntegrationTests2/targets/simple/q/q.cabal +++ b/tests/IntegrationTests2/targets/simple/q/q.cabal @@ -5,6 +5,7 @@ library exposed-modules: QQ + other-modules: Q build-depends: base executable qexe