{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}

module Distribution.Solver.Types.ProjectConfigPath
    (
    -- * Project Config Path Manipulation
      ProjectConfigPath(..)
    , projectConfigPathRoot
    , nullProjectConfigPath
    , consProjectConfigPath
    , unconsProjectConfigPath

    -- * Messages
    , docProjectConfigPath
    , docProjectConfigFiles
    , cyclicalImportMsg
    , untrimmedUriImportMsg
    , docProjectConfigPathFailReason
    , quoteUntrimmed

    -- * Checks and Normalization
    , isCyclicConfigPath
    , isTopLevelConfigPath
    , isUntrimmedUriConfigPath
    , canonicalizeConfigPath
    ) where

import Distribution.Solver.Compat.Prelude hiding (toList, (<>))
import qualified Distribution.Solver.Compat.Prelude as P ((<>))
import Prelude (sequence)

import Data.Coerce (coerce)
import Data.List.NonEmpty ((<|))
import Network.URI (parseURI, parseAbsoluteURI)
import System.Directory
import System.FilePath hiding (splitPath)
import qualified System.FilePath as FP (splitPath)
import qualified System.FilePath.Posix as Posix
import qualified System.FilePath.Windows as Windows
import qualified Data.List.NonEmpty as NE
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
-- list representing a path to an import.  The path is a non-empty list that we
-- build up by prepending relative imports with @consProjectConfigPath@.
--
-- An import can be a URI, such as [a stackage
-- cabal.config](https://www.stackage.org/nightly/cabal.config), but we do not
-- support URIs in the middle of the path, URIs that import other URIs, or URIs
-- that import local files.
--
-- 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 (ProjectConfigPath -> ProjectConfigPath -> Bool
(ProjectConfigPath -> ProjectConfigPath -> Bool)
-> (ProjectConfigPath -> ProjectConfigPath -> Bool)
-> Eq ProjectConfigPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectConfigPath -> ProjectConfigPath -> Bool
== :: ProjectConfigPath -> ProjectConfigPath -> Bool
$c/= :: ProjectConfigPath -> ProjectConfigPath -> Bool
/= :: ProjectConfigPath -> ProjectConfigPath -> Bool
Eq, Int -> ProjectConfigPath -> ShowS
[ProjectConfigPath] -> ShowS
ProjectConfigPath -> FilePath
(Int -> ProjectConfigPath -> ShowS)
-> (ProjectConfigPath -> FilePath)
-> ([ProjectConfigPath] -> ShowS)
-> Show ProjectConfigPath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectConfigPath -> ShowS
showsPrec :: Int -> ProjectConfigPath -> ShowS
$cshow :: ProjectConfigPath -> FilePath
show :: ProjectConfigPath -> FilePath
$cshowList :: [ProjectConfigPath] -> ShowS
showList :: [ProjectConfigPath] -> ShowS
Show, (forall x. ProjectConfigPath -> Rep ProjectConfigPath x)
-> (forall x. Rep ProjectConfigPath x -> ProjectConfigPath)
-> Generic ProjectConfigPath
forall x. Rep ProjectConfigPath x -> ProjectConfigPath
forall x. ProjectConfigPath -> Rep ProjectConfigPath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ProjectConfigPath -> Rep ProjectConfigPath x
from :: forall x. ProjectConfigPath -> Rep ProjectConfigPath x
$cto :: forall x. Rep ProjectConfigPath x -> ProjectConfigPath
to :: forall x. Rep ProjectConfigPath x -> ProjectConfigPath
Generic)

instance Pretty ProjectConfigPath where
  pretty :: ProjectConfigPath -> Doc
pretty = ProjectConfigPath -> Doc
docProjectConfigPath

-- | 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
-- lexical.
--
-- The project itself, a single element root path, compared to any of the
-- configuration paths it imports, should always sort first. Comparing one
-- project root path against another is done lexically.
--
-- For comparison purposes, path separators are normalized to the @buildOS@
-- platform's path separator.
--
-- >>> let abFwd = ProjectConfigPath $ "a/b.config" :| []
-- >>> let abBwd = ProjectConfigPath $ "a\\b.config" :| []
-- >>> compare abFwd abBwd
-- EQ
instance Ord ProjectConfigPath where
    compare :: ProjectConfigPath -> ProjectConfigPath -> Ordering
compare pa :: ProjectConfigPath
pa@(ProjectConfigPath (NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList -> [FilePath]
as)) pb :: ProjectConfigPath
pb@(ProjectConfigPath (NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList -> [FilePath]
bs)) =
        case ([FilePath]
as, [FilePath]
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.
            ([FilePath
a], [FilePath
b]) -> [FilePath] -> [FilePath] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FilePath -> [FilePath]
splitPath FilePath
a) (FilePath -> [FilePath]
splitPath FilePath
b)
            ([FilePath
_], [FilePath]
_) -> Ordering
LT
            ([FilePath]
_, [FilePath
_]) -> Ordering
GT

            (FilePath
a:[FilePath]
_, FilePath
b:[FilePath]
_) -> case (FilePath -> Maybe URI
parseAbsoluteURI FilePath
a, FilePath -> Maybe URI
parseAbsoluteURI FilePath
b) of
                (Just URI
ua, Just URI
ub) -> URI -> URI -> Ordering
forall a. Ord a => a -> a -> Ordering
compare URI
ua URI
ub Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
P.<> Maybe ProjectConfigPath -> Maybe ProjectConfigPath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe ProjectConfigPath
aImporters Maybe ProjectConfigPath
bImporters
                (Just URI
_, Maybe URI
Nothing) -> Ordering
GT
                (Maybe URI
Nothing, Just URI
_) -> Ordering
LT
                (Maybe URI
Nothing, Maybe URI
Nothing) -> [FilePath] -> [FilePath] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FilePath -> [FilePath]
splitPath FilePath
a) (FilePath -> [FilePath]
splitPath FilePath
b) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
P.<> Maybe ProjectConfigPath -> Maybe ProjectConfigPath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe ProjectConfigPath
aImporters Maybe ProjectConfigPath
bImporters
            ([FilePath], [FilePath])
_ ->
                Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
as) ([FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
bs)
                Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
P.<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([[FilePath]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[FilePath]]
aPaths) ([[FilePath]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[FilePath]]
bPaths)
                Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
P.<> [[FilePath]] -> [[FilePath]] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [[FilePath]]
aPaths [[FilePath]]
bPaths
        where
            splitPath :: FilePath -> [FilePath]
splitPath = FilePath -> [FilePath]
FP.splitPath (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normSep where
                normSep :: ShowS
normSep FilePath
p =
                    if OS
buildOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows
                        then
                            [FilePath] -> FilePath
Windows.joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
Windows.splitDirectories
                            [if Char -> Bool
Posix.isPathSeparator Char
c then Char
Windows.pathSeparator else Char
c| Char
c <- FilePath
p]
                        else
                            [FilePath] -> FilePath
Posix.joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
Posix.splitDirectories
                            [if Char -> Bool
Windows.isPathSeparator Char
c then Char
Posix.pathSeparator else Char
c| Char
c <- FilePath
p]

            aPaths :: [[FilePath]]
aPaths = FilePath -> [FilePath]
splitPath (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
as
            bPaths :: [[FilePath]]
bPaths = FilePath -> [FilePath]
splitPath (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
bs
            aImporters :: Maybe ProjectConfigPath
aImporters = (FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath
forall a b. (a, b) -> b
snd ((FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath)
-> (FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath)
unconsProjectConfigPath ProjectConfigPath
pa
            bImporters :: Maybe ProjectConfigPath
bImporters = (FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath
forall a b. (a, b) -> b
snd ((FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath)
-> (FilePath, Maybe ProjectConfigPath) -> Maybe ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath)
unconsProjectConfigPath ProjectConfigPath
pb

instance Binary ProjectConfigPath
instance Structured ProjectConfigPath

-- | Renders the path like this;
--
-- >D.config
-- >  imported by: C.config
-- >  imported by: B.config
-- >  imported by: A.project
--
-- >>> render . docProjectConfigPath $ ProjectConfigPath $ "D.config" :| ["C.config", "B.config", "A.project"]
-- "D.config\n  imported by: C.config\n  imported by: B.config\n  imported by: A.project"
docProjectConfigPath :: ProjectConfigPath -> Doc
docProjectConfigPath :: ProjectConfigPath -> Doc
docProjectConfigPath (ProjectConfigPath (FilePath
p :| [])) = FilePath -> Doc
quoteUntrimmed FilePath
p
docProjectConfigPath (ProjectConfigPath (FilePath
p :| [FilePath]
ps)) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
quoteUntrimmed FilePath
p Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
    [ FilePath -> Doc
text FilePath
" " Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"imported by:" Doc -> Doc -> Doc
<+> FilePath -> Doc
quoteUntrimmed FilePath
l | FilePath
l <- [FilePath]
ps ]

-- | If the path has leading or trailing spaces then show it quoted.
quoteUntrimmed :: FilePath -> Doc
quoteUntrimmed :: FilePath -> Doc
quoteUntrimmed FilePath
s = if ShowS
trim FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
s then Doc -> Doc
quotes (FilePath -> Doc
text FilePath
s) else FilePath -> Doc
text FilePath
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 :: [ProjectConfigPath] -> Doc
docProjectConfigFiles [ProjectConfigPath]
ps = [Doc] -> Doc
vcat
    [ FilePath -> Doc
text FilePath
"-" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
p
    | FilePath
p <- [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
ordNub [ FilePath
p | ProjectConfigPath (FilePath
p :| [FilePath]
_) <- [ProjectConfigPath]
ps ]
    ]

-- | A message for a cyclical import, a "cyclical import of".
cyclicalImportMsg :: ProjectConfigPath -> Doc
cyclicalImportMsg :: ProjectConfigPath -> Doc
cyclicalImportMsg path :: ProjectConfigPath
path@(ProjectConfigPath (FilePath
duplicate :| [FilePath]
_)) =
    [Doc] -> Doc
vcat
    [ FilePath -> Doc
text FilePath
"cyclical import of" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
duplicate Doc -> Doc -> Doc
<> Doc
semi
    , Int -> Doc -> Doc
nest Int
2 (ProjectConfigPath -> Doc
docProjectConfigPath ProjectConfigPath
path)
    ]

-- | A message for an import that has leading or trailing spaces.
untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc
untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc
untrimmedUriImportMsg Doc
intro ProjectConfigPath
path =
    [Doc] -> Doc
vcat
    [ Doc
intro Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"import has leading or trailing whitespace" Doc -> Doc -> Doc
<> Doc
semi
    , Int -> Doc -> Doc
nest Int
2 (ProjectConfigPath -> Doc
docProjectConfigPath ProjectConfigPath
path)
    ]

docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc
docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc
docProjectConfigPathFailReason VR
vr ProjectConfigPath
pcp
    | ProjectConfigPath (FilePath
p :| []) <- ProjectConfigPath
pcp =
        FilePath -> Doc
constraint FilePath
p
    | ProjectConfigPath (FilePath
p :| [FilePath]
ps) <- ProjectConfigPath
pcp = [Doc] -> Doc
vcat
        [ FilePath -> Doc
constraint FilePath
p
        , [Doc] -> Doc
cat [Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text FilePath
"imported by:" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
l | FilePath
l <- [FilePath]
ps ]
        ]
    where
        pathRequiresVersion :: FilePath -> Doc
pathRequiresVersion FilePath
p = FilePath -> Doc
text FilePath
p Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"requires" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (VR -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow VR
vr)
        constraint :: FilePath -> Doc
constraint FilePath
p = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text FilePath
"constraint from" Doc -> Doc -> Doc
<+> FilePath -> Doc
pathRequiresVersion FilePath
p

-- | The root of the path, the project itself.
projectConfigPathRoot :: ProjectConfigPath -> FilePath
projectConfigPathRoot :: ProjectConfigPath -> FilePath
projectConfigPathRoot (ProjectConfigPath NonEmpty FilePath
xs) = NonEmpty FilePath -> FilePath
forall a. NonEmpty a -> a
last NonEmpty FilePath
xs

-- | Used by some tests as a dummy "unused" project root.
nullProjectConfigPath :: ProjectConfigPath
nullProjectConfigPath :: ProjectConfigPath
nullProjectConfigPath = NonEmpty FilePath -> ProjectConfigPath
ProjectConfigPath (NonEmpty FilePath -> ProjectConfigPath)
-> NonEmpty FilePath -> ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ FilePath
"unused" FilePath -> [FilePath] -> NonEmpty FilePath
forall a. a -> [a] -> NonEmpty a
:| []

-- | Check if the path has duplicates. A cycle of imports is not allowed. This
-- check should only be done after the path has been canonicalized with
-- @canonicalizeConfigPath@. This is because the import path may contain paths
-- that are the same in relation to their importers but different in relation to
-- the project root directory.
isCyclicConfigPath :: ProjectConfigPath -> Bool
isCyclicConfigPath :: ProjectConfigPath -> Bool
isCyclicConfigPath (ProjectConfigPath NonEmpty FilePath
p) = NonEmpty FilePath -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FilePath
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty FilePath -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NonEmpty FilePath -> NonEmpty FilePath
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub NonEmpty FilePath
p)

-- | Check if the last segment of the path (root or importee) is a URI that has
-- leading or trailing spaces.
isUntrimmedUriConfigPath :: ProjectConfigPath -> Bool
isUntrimmedUriConfigPath :: ProjectConfigPath -> Bool
isUntrimmedUriConfigPath (ProjectConfigPath (FilePath
p :| [FilePath]
_)) = let p' :: FilePath
p' = ShowS
trim FilePath
p in FilePath
p' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
p Bool -> Bool -> Bool
&& FilePath -> Bool
isURI FilePath
p'

-- | Check if the project config path is top-level, meaning it was not included by
-- some other project config.
isTopLevelConfigPath :: ProjectConfigPath -> Bool
isTopLevelConfigPath :: ProjectConfigPath -> Bool
isTopLevelConfigPath (ProjectConfigPath NonEmpty FilePath
p) = NonEmpty FilePath -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty FilePath
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

-- | Prepends the path of the importee to the importer path.
consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath FilePath
p ProjectConfigPath
ps = NonEmpty FilePath -> ProjectConfigPath
ProjectConfigPath (FilePath
p FilePath -> NonEmpty FilePath -> NonEmpty FilePath
forall a. a -> NonEmpty a -> NonEmpty a
<| ProjectConfigPath -> NonEmpty FilePath
forall a b. Coercible a b => a -> b
coerce ProjectConfigPath
ps)

-- | Split the path into the importee and the importer path.
unconsProjectConfigPath :: ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath)
unconsProjectConfigPath :: ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath)
unconsProjectConfigPath ProjectConfigPath
ps = (NonEmpty FilePath -> ProjectConfigPath)
-> Maybe (NonEmpty FilePath) -> Maybe ProjectConfigPath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty FilePath -> ProjectConfigPath
ProjectConfigPath (Maybe (NonEmpty FilePath) -> Maybe ProjectConfigPath)
-> (FilePath, Maybe (NonEmpty FilePath))
-> (FilePath, Maybe ProjectConfigPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty FilePath -> (FilePath, Maybe (NonEmpty FilePath))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NE.uncons (ProjectConfigPath -> NonEmpty FilePath
forall a b. Coercible a b => a -> b
coerce ProjectConfigPath
ps)

-- | Make paths relative to the directory of the root of the project, not
-- relative to the file they were imported from.
makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
makeRelativeConfigPath FilePath
dir (ProjectConfigPath NonEmpty FilePath
p) =
    NonEmpty FilePath -> ProjectConfigPath
ProjectConfigPath
    (NonEmpty FilePath -> ProjectConfigPath)
-> NonEmpty FilePath -> ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ (\segment :: FilePath
segment@(ShowS
trim -> FilePath
trimSegment) -> (if FilePath -> Bool
isURI FilePath
trimSegment then FilePath
trimSegment else FilePath -> ShowS
makeRelative FilePath
dir FilePath
segment))
    ShowS -> NonEmpty FilePath -> NonEmpty FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty FilePath
p

-- | Normalizes and canonicalizes a path removing '.' and '..' indirections.
-- Makes the path relative to the given directory (typically the project root)
-- instead of relative to the file it was imported from.
--
-- It converts paths like this:
--
-- >   hops-0.project
-- >   └─ hops/hops-1.config
-- >      └─ ../hops-2.config
-- >         └─ hops/hops-3.config
-- >            └─ ../hops-4.config
-- >               └─ hops/hops-5.config
-- >                  └─ ../hops-6.config
-- >                     └─ hops/hops-7.config
-- >                        └─ ../hops-8.config
-- >                           └─ hops/hops-9.config
--
-- Into paths like this:
--
-- >   hops-0.project
-- >   └─ hops/hops-1.config
-- >      └─ hops-2.config
-- >         └─ hops/hops-3.config
-- >            └─ hops-4.config
-- >               └─ hops/hops-5.config
-- >                  └─ hops-6.config
-- >                     └─ hops/hops-7.config
-- >                        └─ hops-8.config
-- >                           └─ hops/hops-9.config
--
-- That way we have @hops-8.config@ instead of
-- @./hops/../hops/../hops/../hops/../hops-8.config@.
--
-- Let's see how @canonicalizePath@ works that is used in the implementation
-- then we'll see how @canonicalizeConfigPath@ works.
--
-- >>> let d = testDir
-- >>> makeRelative d <$> canonicalizePath (d </> "hops/../hops/../hops/../hops/../hops-8.config")
-- "hops-8.config"
--
-- >>> let d = testDir
-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ (d </> "hops/../hops/../hops/../hops/../hops-8.config") :| [])
-- >>> render $ docProjectConfigPath p
-- "hops-8.config"
--
-- >>> :{
--   do
--     let expected = unlines
--           [ "hops/hops-9.config"
--           , "  imported by: hops-8.config"
--           , "  imported by: hops/hops-7.config"
--           , "  imported by: hops-6.config"
--           , "  imported by: hops/hops-5.config"
--           , "  imported by: hops-4.config"
--           , "  imported by: hops/hops-3.config"
--           , "  imported by: hops-2.config"
--           , "  imported by: hops/hops-1.config"
--           , "  imported by: hops-0.project"
--           ]
--     let d = testDir
--     let configPath = ProjectConfigPath ("hops/hops-9.config" :|
--           [ "../hops-8.config"
--           , "hops/hops-7.config"
--           , "../hops-6.config"
--           , "hops/hops-5.config"
--           , "../hops-4.config"
--           , "hops/hops-3.config"
--           , "../hops-2.config"
--           , "hops/hops-1.config"
--           , d </> "hops-0.project"])
--     p <- canonicalizeConfigPath d configPath
--     return $ expected == render (docProjectConfigPath p) ++ "\n"
-- :}
-- True
--
-- "A string is a valid URL potentially surrounded by spaces if, after stripping leading and trailing whitespace from it, it is a valid URL."
-- [W3C/HTML5/URLs](https://www.w3.org/TR/2010/WD-html5-20100624/urls.html)
--
-- Trailing spaces for @ProjectConfigPath@ URLs are trimmed.
--
-- >>> p <- canonicalizeConfigPath "" (ProjectConfigPath $ ("https://www.stackage.org/nightly-2024-12-05/cabal.config ") :| [])
-- >>> render $ docProjectConfigPath p
-- "https://www.stackage.org/nightly-2024-12-05/cabal.config"
--
-- >>> let d = testDir
-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ ("https://www.stackage.org/nightly-2024-12-05/cabal.config ") :| [d </> "cabal.project"])
-- >>> render $ docProjectConfigPath p
-- "https://www.stackage.org/nightly-2024-12-05/cabal.config\n  imported by: cabal.project"
canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath
canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath
canonicalizeConfigPath FilePath
d (ProjectConfigPath NonEmpty FilePath
p) = do
    NonEmpty FilePath
xs <- NonEmpty (IO FilePath) -> IO (NonEmpty FilePath)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
sequence (NonEmpty (IO FilePath) -> IO (NonEmpty FilePath))
-> NonEmpty (IO FilePath) -> IO (NonEmpty FilePath)
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO FilePath -> IO FilePath)
-> IO FilePath -> NonEmpty FilePath -> NonEmpty (IO FilePath)
forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> f a -> NonEmpty b
NE.scanr (\importee :: FilePath
importee@(ShowS
trim -> FilePath
trimImportee) -> (IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \importer :: FilePath
importer@(ShowS
trim -> FilePath
trimImporter) ->
            if FilePath -> Bool
isURI FilePath
trimImportee Bool -> Bool -> Bool
|| FilePath -> Bool
isURI FilePath
trimImporter
                then FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
trimImportee
                else FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
d FilePath -> ShowS
</> ShowS
takeDirectory FilePath
importer FilePath -> ShowS
</> FilePath
importee))
            (FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
".") NonEmpty FilePath
p
    ProjectConfigPath -> IO ProjectConfigPath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfigPath -> IO ProjectConfigPath)
-> ([FilePath] -> ProjectConfigPath)
-> [FilePath]
-> IO ProjectConfigPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ProjectConfigPath -> ProjectConfigPath
makeRelativeConfigPath FilePath
d (ProjectConfigPath -> ProjectConfigPath)
-> ([FilePath] -> ProjectConfigPath)
-> [FilePath]
-> ProjectConfigPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty FilePath -> ProjectConfigPath
ProjectConfigPath (NonEmpty FilePath -> ProjectConfigPath)
-> ([FilePath] -> NonEmpty FilePath)
-> [FilePath]
-> ProjectConfigPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> NonEmpty FilePath
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([FilePath] -> IO ProjectConfigPath)
-> [FilePath] -> IO ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.init NonEmpty FilePath
xs

isURI :: FilePath -> Bool
isURI :: FilePath -> Bool
isURI = Maybe URI -> Bool
forall a. Maybe a -> Bool
isJust (Maybe URI -> Bool) -> (FilePath -> Maybe URI) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe URI
parseURI

-- $setup
-- >>> import Data.List
-- >>> testDir <- makeAbsolute =<< canonicalizePath "../cabal-testsuite/PackageTests/ConditionalAndImport"