merge queue: embarking master (423442c), #11773 and #11711 together

.hlint.yaml

@@ -51,10 +51,11 @@
     - --ignore-glob=Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs
     - --ignore-glob=Cabal-tests/tests/custom-setup/IdrisSetup.hs
     - --ignore-glob=cabal-testsuite/PackageTests/BuildWays/q/app/Main.hs
+    - --ignore-glob=cabal-testsuite/PackageTests/CppOptions/CppOpts/Main.hs
     - --ignore-glob=cabal-testsuite/PackageTests/CMain/10168/src/Lib.hs
-    - --ignore-glob=cabal-testsuite/PackageTests/CmmSources/src/Demo.hs
-    - --ignore-glob=cabal-testsuite/PackageTests/CmmSourcesDyn/src/Demo.hs
-    - --ignore-glob=cabal-testsuite/PackageTests/CmmSourcesExe/src/Demo.hs
+    - --ignore-glob=cabal-testsuite/PackageTests/Cmm/CmmSources/src/Demo.hs
+    - --ignore-glob=cabal-testsuite/PackageTests/Cmm/CmmSourcesDyn/src/Demo.hs
+    - --ignore-glob=cabal-testsuite/PackageTests/Cmm/CmmSourcesExe/src/Demo.hs
     - --ignore-glob=cabal-testsuite/PackageTests/NewBuild/CmdRun/Script/script.hs
     - --ignore-glob=cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/script.lhs
     - --ignore-glob=cabal-testsuite/PackageTests/Regression/T5309/lib/Bio/Character/Exportable/Class.hs

cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs

@@ -5,6 +5,8 @@ module Distribution.Solver.Types.ProjectConfigPath
     (
     -- * Project Config Path Manipulation
       ProjectConfigPath(..)
+    , compareLexicographically
+    , compareSegmentally
     , projectConfigPathRoot
     , nullProjectConfigPath
     , consProjectConfigPath
@@ -14,9 +16,6 @@ module Distribution.Solver.Types.ProjectConfigPath
     -- * Messages
     , docProjectConfigPath
     , docProjectImportedBy
-    , docProjectConfigFiles
-    , cyclicalImportMsg
-    , untrimmedUriImportMsg
     , docProjectConfigPathFailReason
     , quoteUntrimmed
 
@@ -44,7 +43,6 @@ import Distribution.Solver.Modular.Version (VR)
 import Distribution.Pretty (prettyShow, Pretty(..))
 import Distribution.Utils.String (trim)
 import Text.PrettyPrint
-import Distribution.Simple.Utils (ordNub)
 import Distribution.System (OS(Windows), buildOS)
 
 -- | Path to a configuration file, either a singleton project root, or a longer
@@ -59,10 +57,10 @@ import Distribution.System (OS(Windows), buildOS)
 -- List elements are relative to each other but once canonicalized, elements are
 -- relative to the directory of the project root.
 newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath)
-    deriving (Eq, Show, Generic)
+    deriving (Eq, Generic)
 
-instance Pretty ProjectConfigPath where
-  pretty = docProjectConfigPath
+instance Pretty ProjectConfigPath where pretty = docProjectConfigPath
+instance Show ProjectConfigPath where show = prettyShow
 
 -- | Sorts URIs after local file paths and longer file paths after shorter ones
 -- as measured by the number of path segments. If still equal, then sorting is
@@ -79,43 +77,91 @@ instance Pretty ProjectConfigPath where
 -- >>> let abBwd = ProjectConfigPath $ "a\\b.config" :| []
 -- >>> compare abFwd abBwd
 -- EQ
+--
+-- >>> let abc = ProjectConfigPath $ "a/b/c.config" :| []
+-- >>> let yz = ProjectConfigPath $ "y/z.config" :| []
+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)
+-- (GT,False)
+--
+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]
+-- >>> let bcd = ProjectConfigPath $ "D.config" :| ["C.config", "B.project"]
+-- >>> (compare abc bcd, let xs = [abc, bcd] in xs == sort xs)
+-- (LT,True)
+--
+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]
+-- >>> let yz = ProjectConfigPath $ "Z.config" :| ["Y.project"]
+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)
+-- (GT,False)
 instance Ord ProjectConfigPath where
-    compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) =
+    compare = compareSegmentally
+
+-- | A comparison that puts projects first, URLs last and sorts the other paths
+-- lexically.
+compareLexicographically :: ProjectConfigPath -> ProjectConfigPath -> Ordering
+compareLexicographically (ProjectConfigPath as) (ProjectConfigPath bs) =
+        case (as, bs) of
+            -- Single element paths are projects, they should always sort first.
+            (a :| [], b :| []) -> compare (splitPath a) (splitPath b)
+            (_ :| [], _) -> LT
+            (_, _ :| []) -> GT
+
+            (a :| aImporters, b :| bImporters) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of
+                (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters
+                (Just _, Nothing) -> GT
+                (Nothing, Just _) -> LT
+                (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters
+
+-- | A comparison that puts projects first, URLs last and sorts the other paths
+-- by putting longer paths after shorter ones as measured by the number of path
+-- segments. If still equal, then sorting is lexical.
+compareSegmentally:: ProjectConfigPath -> ProjectConfigPath -> Ordering
+compareSegmentally pa@(ProjectConfigPath as) pb@(ProjectConfigPath bs) =
         case (as, bs) of
             -- There should only ever be one root project path, only one path
             -- with length 1. Comparing it to itself should be EQ. Don't assume
             -- this though, do a comparison anyway when both sides have length
             -- 1.  The root path, the project itself, should always be the first
             -- path in a sorted listing.
-            ([a], [b]) -> compare (splitPath a) (splitPath b)
-            ([_], _) -> LT
-            (_, [_]) -> GT
+            (a :| [], b :| []) ->
+                let aPaths = splitPath a
+                    bPaths = splitPath b
+                in
+                    compare (length aPaths) (length bPaths)
+                    P.<> compare aPaths bPaths
+
+            (_ :| [], _) -> LT
+            (_, _ :| []) -> GT
 
-            (a:_, b:_) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of
+            (a :| _, b :| _) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of
                 (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters
                 (Just _, Nothing) -> GT
                 (Nothing, Just _) -> LT
-                (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters
-            _ ->
-                compare (length as) (length bs)
-                P.<> compare (length aPaths) (length bPaths)
-                P.<> compare aPaths bPaths
+                (Nothing, Nothing) ->
+                    let aPaths = splitPath a
+                        bPaths = splitPath b
+                    in
+                        compare (length as) (length bs)
+                        P.<> compare asPaths bsPaths
+                        P.<> compare (length aPaths) (length bPaths)
+                        P.<> compare aPaths bPaths
+                        P.<> compare aImporters bImporters
         where
-            splitPath = FP.splitPath . normSep where
-                normSep p =
-                    if buildOS == Windows
-                        then
-                            Windows.joinPath $ Windows.splitDirectories
-                            [if Posix.isPathSeparator c then Windows.pathSeparator else c| c <- p]
-                        else
-                            Posix.joinPath $ Posix.splitDirectories
-                            [if Windows.isPathSeparator c then Posix.pathSeparator else c| c <- p]
-
-            aPaths = splitPath <$> as
-            bPaths = splitPath <$> bs
+            asPaths = splitPath <$> as
+            bsPaths = splitPath <$> bs
             aImporters = snd $ unconsProjectConfigPath pa
             bImporters = snd $ unconsProjectConfigPath pb
 
+splitPath :: FilePath -> [FilePath]
+splitPath = FP.splitPath . normSep
+    where
+        normSep p =
+            if buildOS == Windows then
+                Windows.joinPath $ Windows.splitDirectories
+                [if Posix.isPathSeparator c then Windows.pathSeparator else c| c <- p]
+            else
+                Posix.joinPath $ Posix.splitDirectories
+                [if Windows.isPathSeparator c then Posix.pathSeparator else c| c <- p]
+
 instance Binary ProjectConfigPath
 instance NFData ProjectConfigPath
 instance Structured ProjectConfigPath
@@ -140,67 +186,10 @@ docProjectImportedBy (ProjectConfigPath (_ :| [])) = text ""
 docProjectImportedBy (ProjectConfigPath (_ :| ps)) = vcat $
     [ text " " <+> text "imported by:" <+> quoteUntrimmed l | l <- ps ]
 
-
 -- | If the path has leading or trailing spaces then show it quoted.
 quoteUntrimmed :: FilePath -> Doc
 quoteUntrimmed s = if trim s /= s then quotes (text s) else text s
 
--- | Renders the paths as a list without showing which path imports another,
--- like this;
---
--- >- cabal.project
--- >- project-cabal/constraints.config
--- >- project-cabal/ghc-latest.config
--- >- project-cabal/ghc-options.config
--- >- project-cabal/pkgs.config
--- >- project-cabal/pkgs/benchmarks.config
--- >- project-cabal/pkgs/buildinfo.config
--- >- project-cabal/pkgs/cabal.config
--- >- project-cabal/pkgs/install.config
--- >- project-cabal/pkgs/integration-tests.config
--- >- project-cabal/pkgs/tests.config
---
---
--- >>> :{
---   do
---     let ps =
---              [ ProjectConfigPath ("cabal.project" :| [])
---              , ProjectConfigPath ("project-cabal/constraints.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/ghc-latest.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/ghc-options.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/benchmarks.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/buildinfo.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/cabal.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/install.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/integration-tests.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/tests.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              ]
---     return . render $ docProjectConfigFiles ps
--- :}
--- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config"
-docProjectConfigFiles :: [ProjectConfigPath] -> Doc
-docProjectConfigFiles ps = vcat
-    [ text "-" <+> text p
-    | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ]
-    ]
-
--- | A message for a cyclical import, a "cyclical import of".
-cyclicalImportMsg :: ProjectConfigPath -> Doc
-cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =
-    vcat
-    [ text "cyclical import of" <+> text duplicate <> semi
-    , nest 2 (docProjectConfigPath path)
-    ]
-
--- | A message for an import that has leading or trailing spaces.
-untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc
-untrimmedUriImportMsg intro path =
-    vcat
-    [ intro <+> text "import has leading or trailing whitespace" <> semi
-    , nest 2 (docProjectConfigPath path)
-    ]
-
 docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc
 docProjectConfigPathFailReason vr pcp
     | ProjectConfigPath (p :| []) <- pcp =

cabal-install/cabal-install.cabal

@@ -185,6 +185,7 @@ library
         Distribution.Client.ProjectBuilding.Types
         Distribution.Client.ProjectConfig
         Distribution.Client.ProjectConfig.FieldGrammar
+        Distribution.Client.ProjectConfig.Import
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Lens
         Distribution.Client.ProjectConfig.Parsec

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -255,6 +255,7 @@ import System.IO
   , withBinaryFile
   )
 
+import Distribution.Client.ProjectConfig.Import (ProjectConfigSkeleton, docProjectConfigFiles, projectSkeletonImports)
 import Distribution.Deprecated.ProjectParseUtils (ProjectParseError (..), ProjectParseWarning)
 import Distribution.Solver.Types.ProjectConfigPath