|
| 1 | +{-# LANGUAGE DeriveGeneric #-} |
| 2 | +{-# LANGUAGE LambdaCase #-} |
| 3 | + |
| 4 | +module Distribution.Solver.Types.ProjectConfigPath |
| 5 | + ( |
| 6 | + -- * Project Config Path Manipulation |
| 7 | + ProjectConfigPath(..) |
| 8 | + , projectConfigPathRoot |
| 9 | + , nullProjectConfigPath |
| 10 | + , consProjectConfigPath |
| 11 | + |
| 12 | + -- * Messages |
| 13 | + , docProjectConfigPath |
| 14 | + , cyclicalImportMsg |
| 15 | + , docProjectConfigPathFailReason |
| 16 | + |
| 17 | + -- * Checks and Normalization |
| 18 | + , isCyclicConfigPath |
| 19 | + , canonicalizeConfigPath |
| 20 | + ) where |
| 21 | + |
| 22 | +import Distribution.Solver.Compat.Prelude hiding (toList, (<>)) |
| 23 | +import Prelude (sequence) |
| 24 | + |
| 25 | +import Data.Coerce (coerce) |
| 26 | +import Data.List.NonEmpty ((<|)) |
| 27 | +import Network.URI (parseURI) |
| 28 | +import System.Directory |
| 29 | +import System.FilePath |
| 30 | +import qualified Data.List.NonEmpty as NE |
| 31 | +import Distribution.Solver.Modular.Version (VR) |
| 32 | +import Distribution.Pretty (prettyShow) |
| 33 | +import Text.PrettyPrint |
| 34 | + |
| 35 | +-- | Path to a configuration file, either a singleton project root, or a longer |
| 36 | +-- list representing a path to an import. The path is a non-empty list that we |
| 37 | +-- build up by prepending relative imports with @consProjectConfigPath@. |
| 38 | +-- |
| 39 | +-- An import can be a URI, such as [a stackage |
| 40 | +-- cabal.config](https://www.stackage.org/nightly/cabal.config), but we do not |
| 41 | +-- support URIs in the middle of the path, URIs that import other URIs, or URIs |
| 42 | +-- that import local files. |
| 43 | +-- |
| 44 | +-- List elements are relative to each other but once canonicalized, elements are |
| 45 | +-- relative to the directory of the project root. |
| 46 | +newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath) |
| 47 | + deriving (Eq, Ord, Show, Generic) |
| 48 | + |
| 49 | +instance Binary ProjectConfigPath |
| 50 | +instance Structured ProjectConfigPath |
| 51 | + |
| 52 | +-- | Renders the path like this; |
| 53 | +-- @ |
| 54 | +-- D.config |
| 55 | +-- imported by: C.config |
| 56 | +-- imported by: B.config |
| 57 | +-- imported by: A.project |
| 58 | +-- @ |
| 59 | +-- >>> render . docProjectConfigPath $ ProjectConfigPath $ "D.config" :| ["C.config", "B.config", "A.project" ] |
| 60 | +-- "D.config\n imported by: C.config\n imported by: B.config\n imported by: A.project" |
| 61 | +docProjectConfigPath :: ProjectConfigPath -> Doc |
| 62 | +docProjectConfigPath (ProjectConfigPath (p :| [])) = text p |
| 63 | +docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ |
| 64 | + text p : [ text " " <+> text "imported by:" <+> text l | l <- ps ] |
| 65 | + |
| 66 | +-- | A message for a cyclical import, assuming the head of the path is the |
| 67 | +-- duplicate. |
| 68 | +cyclicalImportMsg :: ProjectConfigPath -> Doc |
| 69 | +cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) = |
| 70 | + vcat |
| 71 | + [ text "cyclical import of" <+> text duplicate <> semi |
| 72 | + , nest 2 (docProjectConfigPath path) |
| 73 | + ] |
| 74 | + |
| 75 | +docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc |
| 76 | +docProjectConfigPathFailReason vr pcp |
| 77 | + | ProjectConfigPath (p :| []) <- pcp = |
| 78 | + constraint p |
| 79 | + | ProjectConfigPath (p :| ps) <- pcp = vcat |
| 80 | + [ constraint p |
| 81 | + , cat [nest 2 $ text "imported by:" <+> text l | l <- ps ] |
| 82 | + ] |
| 83 | + where |
| 84 | + pathRequiresVersion p = text p <+> text "requires" <+> text (prettyShow vr) |
| 85 | + constraint p = parens $ text "constraint from" <+> pathRequiresVersion p |
| 86 | + |
| 87 | +-- | The root of the path, the project itself. |
| 88 | +projectConfigPathRoot :: ProjectConfigPath -> FilePath |
| 89 | +projectConfigPathRoot (ProjectConfigPath xs) = last xs |
| 90 | + |
| 91 | +-- | Used by some tests as a dummy "unused" project root. |
| 92 | +nullProjectConfigPath :: ProjectConfigPath |
| 93 | +nullProjectConfigPath = ProjectConfigPath $ "unused" :| [] |
| 94 | + |
| 95 | +-- | Check if the path has duplicates. A cycle of imports is not allowed. This |
| 96 | +-- check should only be done after the path has been canonicalized with |
| 97 | +-- @canonicalizeConfigPath@. This is because the import path may contain paths |
| 98 | +-- that are the same in relation to their importers but different in relation to |
| 99 | +-- the project root directory. |
| 100 | +isCyclicConfigPath :: ProjectConfigPath -> Bool |
| 101 | +isCyclicConfigPath (ProjectConfigPath p) = length p /= length (NE.nub p) |
| 102 | + |
| 103 | +-- | Prepends the path of the importee to the importer path. |
| 104 | +consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath |
| 105 | +consProjectConfigPath p ps = ProjectConfigPath (p <| coerce ps) |
| 106 | + |
| 107 | +-- | Make paths relative to the directory of the root of the project, not |
| 108 | +-- relative to the file they were imported from. |
| 109 | +makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath |
| 110 | +makeRelativeConfigPath dir (ProjectConfigPath p) = |
| 111 | + ProjectConfigPath |
| 112 | + $ (\segment -> (if isURI segment then segment else makeRelative dir segment)) |
| 113 | + <$> p |
| 114 | + |
| 115 | +-- | Normalizes and canonicalizes a path removing '.' and '..' indirections. |
| 116 | +-- Makes the path relative to the given directory (typically the project root) |
| 117 | +-- instead of relative to the file it was imported from. |
| 118 | +-- |
| 119 | +-- It converts paths like this: |
| 120 | +-- @ |
| 121 | +-- └─ hops-0.project |
| 122 | +-- └─ hops/hops-1.config |
| 123 | +-- └─ ../hops-2.config |
| 124 | +-- └─ hops/hops-3.config |
| 125 | +-- └─ ../hops-4.config |
| 126 | +-- └─ hops/hops-5.config |
| 127 | +-- └─ ../hops-6.config |
| 128 | +-- └─ hops/hops-7.config |
| 129 | +-- └─ ../hops-8.config |
| 130 | +-- └─ hops/hops-9.config |
| 131 | +-- @ |
| 132 | +-- |
| 133 | +-- Into paths like this: |
| 134 | +-- @ |
| 135 | +-- └─ hops-0.project |
| 136 | +-- └─ hops/hops-1.config |
| 137 | +-- └─ hops-2.config |
| 138 | +-- └─ hops/hops-3.config |
| 139 | +-- └─ hops-4.config |
| 140 | +-- └─ hops/hops-5.config |
| 141 | +-- └─ hops-6.config |
| 142 | +-- └─ hops/hops-7.config |
| 143 | +-- └─ hops-8.config |
| 144 | +-- └─ hops/hops-9.config |
| 145 | +-- @ |
| 146 | +-- |
| 147 | +-- That way we have @hops-8.config@ instead of |
| 148 | +-- @./hops/../hops/../hops/../hops/../hops-8.config@. |
| 149 | +-- |
| 150 | +-- Let's see how @canonicalizePath@ works that is used in the implementation |
| 151 | +-- then we'll see how @canonicalizeConfigPath@ works. |
| 152 | +-- |
| 153 | +-- >>> let d = testDir |
| 154 | +-- >>> makeRelative d <$> canonicalizePath (d </> "hops/../hops/../hops/../hops/../hops-8.config") |
| 155 | +-- "hops-8.config" |
| 156 | +-- |
| 157 | +-- >>> let d = testDir |
| 158 | +-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ (d </> "hops/../hops/../hops/../hops/../hops-8.config") :| []) |
| 159 | +-- >>> render $ docProjectConfigPath p |
| 160 | +-- "hops-8.config" |
| 161 | +-- |
| 162 | +-- >>> :{ |
| 163 | +-- do |
| 164 | +-- let expected = unlines |
| 165 | +-- [ "hops/hops-9.config" |
| 166 | +-- , " imported by: hops-8.config" |
| 167 | +-- , " imported by: hops/hops-7.config" |
| 168 | +-- , " imported by: hops-6.config" |
| 169 | +-- , " imported by: hops/hops-5.config" |
| 170 | +-- , " imported by: hops-4.config" |
| 171 | +-- , " imported by: hops/hops-3.config" |
| 172 | +-- , " imported by: hops-2.config" |
| 173 | +-- , " imported by: hops/hops-1.config" |
| 174 | +-- , " imported by: hops-0.project" |
| 175 | +-- ] |
| 176 | +-- let d = testDir |
| 177 | +-- let configPath = ProjectConfigPath ("hops/hops-9.config" :| |
| 178 | +-- [ "../hops-8.config" |
| 179 | +-- , "hops/hops-7.config" |
| 180 | +-- , "../hops-6.config" |
| 181 | +-- , "hops/hops-5.config" |
| 182 | +-- , "../hops-4.config" |
| 183 | +-- , "hops/hops-3.config" |
| 184 | +-- , "../hops-2.config" |
| 185 | +-- , "hops/hops-1.config" |
| 186 | +-- , d </> "hops-0.project"]) |
| 187 | +-- p <- canonicalizeConfigPath d configPath |
| 188 | +-- return $ expected == render (docProjectConfigPath p) ++ "\n" |
| 189 | +-- :} |
| 190 | +-- True |
| 191 | +canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath |
| 192 | +canonicalizeConfigPath d (ProjectConfigPath p) = do |
| 193 | + xs <- sequence $ NE.scanr (\importee -> (>>= \importer -> |
| 194 | + if isURI importee |
| 195 | + then pure importee |
| 196 | + else canonicalizePath $ d </> takeDirectory importer </> importee)) |
| 197 | + (pure ".") p |
| 198 | + return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs |
| 199 | + |
| 200 | +isURI :: FilePath -> Bool |
| 201 | +isURI = isJust . parseURI |
| 202 | + |
| 203 | +-- $setup |
| 204 | +-- >>> import Data.List |
| 205 | +-- >>> testDir <- makeAbsolute =<< canonicalizePath "../cabal-testsuite/PackageTests/ConditionalAndImport" |
![mergify[bot]](https://avatars.githubusercontent.com/in/10562?v=4&size=40){kind=avatar}
0 commit comments