{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Project configuration imports.
module Distribution.Client.ProjectConfig.Import
  ( -- * Parsing skeleton
    ProjectConfigSkeleton
  , projectSkeletonImports
  , fetchImport

    -- * Messages
  , docProjectConfigFiles
  , cyclicalImportMsg
  , untrimmedUriImportMsg

    -- * Checks
  , reportDuplicateImports
  ) where

import Control.Arrow (Kleisli (..), arr, second, (>>>))
import qualified Data.ByteString.Char8 as BS
import Data.Coerce (coerce)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List ((\\))
import qualified Data.Map as Map
import Distribution.Client.Compat.Prelude hiding (empty, (<>))
import qualified Distribution.Client.Compat.Prelude as Prelude ((<>))
import Distribution.Client.HttpUtils
import Distribution.Client.ProjectConfig.Types
import Distribution.Compat.Lens (view)
import Distribution.PackageDescription (ConfVar (..))
import Distribution.Simple.Utils (debug, noticeDoc, ordNub)
import Distribution.Solver.Types.ProjectConfigPath
import Distribution.Types.CondTree (CondTree (..), traverseCondTreeA)
import Distribution.Utils.String (trim)
import Network.URI (URI (..), parseURI)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (isAbsolute, isPathSeparator, makeValid, (</>))
import Text.PrettyPrint (Doc, empty, int, nest, semi, text, vcat, (<>))

-- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping
-- a config. It can be finalized by providing the conditional resolution info
-- and then resolving and downloading the imports
type ProjectConfigSkeleton = CondTree ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)

projectSkeletonImports :: ProjectConfigSkeleton -> [(Maybe URI, ProjectConfigPath)]
projectSkeletonImports :: ProjectConfigSkeleton -> [(Maybe URI, ProjectConfigPath)]
projectSkeletonImports = ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> [(Maybe URI, ProjectConfigPath)]
forall a b. (a, b) -> a
fst (([(Maybe URI, ProjectConfigPath)], ProjectConfig)
 -> [(Maybe URI, ProjectConfigPath)])
-> (ProjectConfigSkeleton
    -> ([(Maybe URI, ProjectConfigPath)], ProjectConfig))
-> ProjectConfigSkeleton
-> [(Maybe URI, ProjectConfigPath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
  ProjectConfigSkeleton
  ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> ProjectConfigSkeleton
-> ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall a s. Getting a s a -> s -> a
view Getting
  ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
  ProjectConfigSkeleton
  ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall v a b (f :: * -> *).
Applicative f =>
LensLike f (CondTree v a) (CondTree v b) a b
traverseCondTreeA

-- | Fetch a local file import or remote URL import and parse it.
fetchImport
  :: (ProjectConfigToParse -> IO a)
  -> FilePath
  -> HttpTransport
  -> Verbosity
  -> FilePath
  -> ProjectConfigPath
  -> IO (Maybe URI, a)
fetchImport :: forall a.
(ProjectConfigToParse -> IO a)
-> String
-> HttpTransport
-> Verbosity
-> String
-> ProjectConfigPath
-> IO (Maybe URI, a)
fetchImport ProjectConfigToParse -> IO a
parser String
cacheDir HttpTransport
httpTransport Verbosity
verbosity String
projectDir ProjectConfigPath
normLocPath =
  ProjectConfigPath -> IO (Maybe URI, ByteString)
fetchImportConfig ProjectConfigPath
normLocPath IO (Maybe URI, ByteString)
-> ((Maybe URI, ByteString) -> IO (Maybe URI, a))
-> IO (Maybe URI, a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kleisli IO (Maybe URI, ByteString) (Maybe URI, a)
-> (Maybe URI, ByteString) -> IO (Maybe URI, a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli IO ByteString a
-> Kleisli IO (Maybe URI, ByteString) (Maybe URI, a)
forall b c d. Kleisli IO b c -> Kleisli IO (d, b) (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((ByteString -> ProjectConfigToParse)
-> Kleisli IO ByteString ProjectConfigToParse
forall b c. (b -> c) -> Kleisli IO b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ByteString -> ProjectConfigToParse
ProjectConfigToParse Kleisli IO ByteString ProjectConfigToParse
-> Kleisli IO ProjectConfigToParse a -> Kleisli IO ByteString a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (ProjectConfigToParse -> IO a) -> Kleisli IO ProjectConfigToParse a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ProjectConfigToParse -> IO a
parser))
  where
    fetchImportConfig :: ProjectConfigPath -> IO (Maybe URI, BS.ByteString)
    fetchImportConfig :: ProjectConfigPath -> IO (Maybe URI, ByteString)
fetchImportConfig (ProjectConfigPath (String
pci :| [String]
_)) = do
      Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"fetching import: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pci
      let mbUri :: Maybe URI
mbUri = String -> Maybe URI
parseURI (String -> String
trim String
pci)
      (Maybe URI
mbUri,) (ByteString -> (Maybe URI, ByteString))
-> IO ByteString -> IO (Maybe URI, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe URI
mbUri of
        Just URI
uri -> do
          let fp :: String
fp = String
cacheDir String -> String -> String
</> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isPathSeparator Char
x then Char
'_' else Char
x) (String -> String
makeValid (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
uri)
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir
          _ <- HttpTransport -> Verbosity -> URI -> String -> IO DownloadResult
downloadURI HttpTransport
httpTransport Verbosity
verbosity URI
uri String
fp
          BS.readFile fp
        Maybe URI
Nothing ->
          String -> IO ByteString
BS.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$
            if String -> Bool
isAbsolute String
pci then String
pci else String -> String
forall a b. Coercible a b => a -> b
coerce String
projectDir String -> String -> String
</> String
pci

-- | Not just any file path. The project itself.
newtype ProjectFilePath = ProjectFilePath FilePath
  deriving (ProjectFilePath -> ProjectFilePath -> Bool
(ProjectFilePath -> ProjectFilePath -> Bool)
-> (ProjectFilePath -> ProjectFilePath -> Bool)
-> Eq ProjectFilePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectFilePath -> ProjectFilePath -> Bool
== :: ProjectFilePath -> ProjectFilePath -> Bool
$c/= :: ProjectFilePath -> ProjectFilePath -> Bool
/= :: ProjectFilePath -> ProjectFilePath -> Bool
Eq, (forall x. ProjectFilePath -> Rep ProjectFilePath x)
-> (forall x. Rep ProjectFilePath x -> ProjectFilePath)
-> Generic ProjectFilePath
forall x. Rep ProjectFilePath x -> ProjectFilePath
forall x. ProjectFilePath -> Rep ProjectFilePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ProjectFilePath -> Rep ProjectFilePath x
from :: forall x. ProjectFilePath -> Rep ProjectFilePath x
$cto :: forall x. Rep ProjectFilePath x -> ProjectFilePath
to :: forall x. Rep ProjectFilePath x -> ProjectFilePath
Generic)

-- | Isomorphic with 'ProjectConfigPath' but with separate constructors for the
-- root, imported file and imported URI.
data ProjectNode a where
  ProjectRoot :: FilePath -> ProjectNode ProjectFilePath
  ProjectFileImport :: FilePath -> ProjectConfigPath -> ProjectNode FilePath
  ProjectUriImport :: URI -> ProjectConfigPath -> ProjectNode URI

instance Eq (ProjectNode a) where
  == :: ProjectNode a -> ProjectNode a -> Bool
(==) ProjectNode a
a ProjectNode a
b
    | ProjectRoot String
root <- ProjectNode a
a
    , ProjectRoot String
root' <- ProjectNode a
b =
        String
root String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
root'
    | ProjectFileImport String
importOf ProjectConfigPath
importBy <- ProjectNode a
a
    , ProjectFileImport String
importOf' ProjectConfigPath
importBy' <- ProjectNode a
b =
        ProjectConfigPath -> ProjectConfigPath -> Bool
forall a. Eq a => a -> a -> Bool
(==)
          (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
importOf ProjectConfigPath
importBy)
          (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
importOf' ProjectConfigPath
importBy')
    | ProjectUriImport URI
importOf ProjectConfigPath
importBy <- ProjectNode a
a
    , ProjectUriImport URI
importOf' ProjectConfigPath
importBy' <- ProjectNode a
b =
        ProjectConfigPath -> ProjectConfigPath -> Bool
forall a. Eq a => a -> a -> Bool
(==)
          (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath (URI -> String
forall a. Show a => a -> String
show URI
importOf) ProjectConfigPath
importBy)
          (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath (URI -> String
forall a. Show a => a -> String
show URI
importOf') ProjectConfigPath
importBy')

instance Pretty (ProjectNode a) where
  pretty :: ProjectNode a -> Doc
pretty = \case
    ProjectRoot String
root -> String -> Doc
text String
root
    ProjectFileImport String
importOf ProjectConfigPath
importBy -> ProjectConfigPath -> Doc
forall a. Pretty a => a -> Doc
pretty (ProjectConfigPath -> Doc) -> ProjectConfigPath -> Doc
forall a b. (a -> b) -> a -> b
$ String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
importOf ProjectConfigPath
importBy
    ProjectUriImport URI
importOf ProjectConfigPath
importBy -> ProjectConfigPath -> Doc
forall a. Pretty a => a -> Doc
pretty (ProjectConfigPath -> Doc) -> ProjectConfigPath -> Doc
forall a b. (a -> b) -> a -> b
$ String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath (URI -> String
forall a. Show a => a -> String
show URI
importOf) ProjectConfigPath
importBy

instance Show (ProjectNode a) where show :: ProjectNode a -> String
show = ProjectNode a -> String
forall a. Pretty a => a -> String
prettyShow

-- | Sorts the same as 'ProjectConfigPath' does.
instance Ord (ProjectNode a) where
  compare :: ProjectNode a -> ProjectNode a -> Ordering
compare =
    (ProjectConfigPath -> ProjectConfigPath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare :: ProjectConfigPath -> ProjectConfigPath -> Ordering)
      (ProjectConfigPath -> ProjectConfigPath -> Ordering)
-> (ProjectNode a -> ProjectConfigPath)
-> ProjectNode a
-> ProjectNode a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ( \case
              ProjectRoot String
root -> NonEmpty String -> ProjectConfigPath
ProjectConfigPath (NonEmpty String -> ProjectConfigPath)
-> NonEmpty String -> ProjectConfigPath
forall a b. (a -> b) -> a -> b
$ String
root String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
              ProjectFileImport String
importOf ProjectConfigPath
importBy -> String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
importOf ProjectConfigPath
importBy
              ProjectUriImport URI
importOf ProjectConfigPath
importBy -> String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath (URI -> String
forall a. Show a => a -> String
show URI
importOf) ProjectConfigPath
importBy
           )

-- | 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"
--
-- The listing puts projects first, URLs last and sorts the other paths
-- lexically, dropping any duplicates, like this:
--
-- >- cabal.project
-- >- 0.config
-- >- 2.config
-- >- cfg/1.config
-- >- cfg/3.config
-- >- with-ghc.config
-- >- https://www.stackage.org/lts-21.25/cabal.config
--
-- >>> let p = ProjectConfigPath $ "cabal.project" :| []
-- >>> let a = ProjectConfigPath $ "0.config" :| ["cabal.project"]
-- >>> let b = ProjectConfigPath $ "cfg/1.config" :| ["0.config", "cabal.project"]
-- >>> let c = ProjectConfigPath $ "with.config" :| ["0.config", "cabal.project"]
-- >>> let d = ProjectConfigPath $ "2.config" :| ["cfg/1.config", "0.config", "cabal.project"]
-- >>> let e = ProjectConfigPath $ "cfg/3.config" :| ["2.config", "cfg/1.config", "0.config", "cabal.project"]
-- >>> let f = ProjectConfigPath $ "https://www.stackage.org/lts-21.25/cabal.config" :| ["2.config", "cfg/1.config", "0.config", "cabal.project"]
-- >>> let g = ProjectConfigPath $ "https://www.stackage.org/lts-21.25/cabal.config" :| ["cfg/3.config", "2.config", "cfg/1.config", "0.config", "cabal.project"]
-- >>> let ps = [p, a, b, c, d, e, f, g]
-- >>> render $ docProjectConfigFiles ps
-- "- cabal.project\n- 0.config\n- 2.config\n- cfg/1.config\n- cfg/3.config\n- with.config\n- https://www.stackage.org/lts-21.25/cabal.config"
docProjectConfigFiles :: [ProjectConfigPath] -> Doc
docProjectConfigFiles :: [ProjectConfigPath] -> Doc
docProjectConfigFiles ((ProjectConfigPath -> ProjectConfigPath -> Ordering)
-> [ProjectConfigPath] -> [ProjectConfigPath]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ProjectConfigPath -> ProjectConfigPath -> Ordering
compareLexicographically -> [ProjectConfigPath]
ps) =
  [Doc] -> Doc
vcat
    [ String -> Doc
text String
"-" Doc -> Doc -> Doc
<+> String -> Doc
text String
p
    | String
p <- [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub [String
p | ProjectConfigPath (String
p :| [String]
_) <- [ProjectConfigPath]
ps]
    ]

-- | A message for a cyclical import, a "cyclical import of".
cyclicalImportMsg :: ProjectConfigPath -> Doc
cyclicalImportMsg :: ProjectConfigPath -> Doc
cyclicalImportMsg path :: ProjectConfigPath
path@(ProjectConfigPath (String
duplicate :| [String]
_)) =
  Doc -> ProjectNode String -> [ProjectNode String] -> Doc
forall a. Doc -> ProjectNode a -> [ProjectNode a] -> Doc
seenImportMsg
    (String -> Doc
text String
"cyclical import of" Doc -> Doc -> Doc
<+> String -> Doc
text String
duplicate Doc -> Doc -> Doc
<> Doc
semi)
    (String -> ProjectConfigPath -> ProjectNode String
ProjectFileImport String
duplicate ProjectConfigPath
path)
    []

-- | A message for a duplicate import, a "duplicate import of". If a check for
-- cyclical imports has already been made then this would report a duplicate
-- import by two different paths.
duplicateImportMsg :: Doc -> ProjectNode a -> [ProjectNode a] -> Doc
duplicateImportMsg :: forall a. Doc -> ProjectNode a -> [ProjectNode a] -> Doc
duplicateImportMsg Doc
intro = Doc -> ProjectNode a -> [ProjectNode a] -> Doc
forall a. Doc -> ProjectNode a -> [ProjectNode a] -> Doc
seenImportMsg Doc
intro

seenImportMsg :: Doc -> ProjectNode a -> [ProjectNode a] -> Doc
seenImportMsg :: forall a. Doc -> ProjectNode a -> [ProjectNode a] -> Doc
seenImportMsg Doc
intro ProjectNode a
projectNode [ProjectNode a]
seenImports =
  [Doc] -> Doc
vcat
    [ Doc
intro
    , Doc -> (ProjectConfigPath -> Doc) -> Maybe ProjectConfigPath -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc)
-> (ProjectConfigPath -> Doc) -> ProjectConfigPath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigPath -> Doc
docProjectConfigPath) Maybe ProjectConfigPath
path
    , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
vcat
          [ ProjectConfigPath -> Doc
docProjectConfigPath ProjectConfigPath
i
          | Just ProjectConfigPath
i <- ProjectNode a -> Maybe ProjectConfigPath
forall a. ProjectNode a -> Maybe ProjectConfigPath
importBy (ProjectNode a -> Maybe ProjectConfigPath)
-> [ProjectNode a] -> [Maybe ProjectConfigPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProjectNode a -> Bool) -> [ProjectNode a] -> [ProjectNode a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
duplicate String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (ProjectNode a -> String) -> ProjectNode a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectNode a -> String
forall a. ProjectNode a -> String
importOf) [ProjectNode a]
seenImports
          ]
    ]
  where
    duplicate :: String
duplicate = ProjectNode a -> String
forall a. ProjectNode a -> String
importOf ProjectNode a
projectNode
    path :: Maybe ProjectConfigPath
path = ProjectNode a -> Maybe ProjectConfigPath
forall a. ProjectNode a -> Maybe ProjectConfigPath
importBy ProjectNode a
projectNode

    importOf :: ProjectNode a -> FilePath
    importOf :: forall a. ProjectNode a -> String
importOf = \case
      ProjectRoot String
dup -> String
dup
      ProjectFileImport String
dup ProjectConfigPath
_ -> String
dup
      ProjectUriImport URI
dup ProjectConfigPath
_ -> URI -> String
forall a. Show a => a -> String
show URI
dup

    importBy :: ProjectNode a -> Maybe ProjectConfigPath
    importBy :: forall a. ProjectNode a -> Maybe ProjectConfigPath
importBy = \case
      ProjectRoot String
_ -> Maybe ProjectConfigPath
forall a. Maybe a
Nothing
      ProjectFileImport String
_ ProjectConfigPath
by -> ProjectConfigPath -> Maybe ProjectConfigPath
forall a. a -> Maybe a
Just ProjectConfigPath
by
      ProjectUriImport URI
_ ProjectConfigPath
by -> ProjectConfigPath -> Maybe ProjectConfigPath
forall a. a -> Maybe a
Just ProjectConfigPath
by

-- | 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
<+> String -> Doc
text String
"import has leading or trailing whitespace" Doc -> Doc -> Doc
<> Doc
semi
    , Int -> Doc -> Doc
nest Int
2 (ProjectConfigPath -> Doc
docProjectConfigPath ProjectConfigPath
path)
    ]

-- | Detect and report any duplicate imports, including those missed when parsing.
--
-- Parsing catches cyclical imports and some but not all duplicate imports. In
-- particular, it doesn't catch when the same project configuration is imported
-- via different import paths.
reportDuplicateImports :: Verbosity -> ProjectConfigSkeleton -> IO ()
reportDuplicateImports :: Verbosity -> ProjectConfigSkeleton -> IO ()
reportDuplicateImports Verbosity
verbosity ProjectConfigSkeleton
skeleton = do
  let (DupesMap ProjectFilePath
dupeRoots, DupesMap String
dupeFiles, DupesMap URI
dupeUris) = [(Maybe URI, ProjectConfigPath)]
-> (DupesMap ProjectFilePath, DupesMap String, DupesMap URI)
detectDupes ([(Maybe URI, ProjectConfigPath)]
 -> (DupesMap ProjectFilePath, DupesMap String, DupesMap URI))
-> [(Maybe URI, ProjectConfigPath)]
-> (DupesMap ProjectFilePath, DupesMap String, DupesMap URI)
forall a b. (a -> b) -> a -> b
$ ProjectConfigSkeleton -> [(Maybe URI, ProjectConfigPath)]
projectSkeletonImports ProjectConfigSkeleton
skeleton
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DupesMap ProjectFilePath -> Bool
forall k a. Map k a -> Bool
Map.null DupesMap ProjectFilePath
dupeRoots) (Verbosity -> Doc -> IO ()
noticeDoc Verbosity
verbosity (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((String, [Dupes ProjectFilePath]) -> Doc
forall a. (String, [Dupes a]) -> Doc
dupesMsg ((String, [Dupes ProjectFilePath]) -> Doc)
-> [(String, [Dupes ProjectFilePath])] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DupesMap ProjectFilePath -> [(String, [Dupes ProjectFilePath])]
forall k a. Map k a -> [(k, a)]
Map.toList DupesMap ProjectFilePath
dupeRoots))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DupesMap String -> Bool
forall k a. Map k a -> Bool
Map.null DupesMap String
dupeFiles) (Verbosity -> Doc -> IO ()
noticeDoc Verbosity
verbosity (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((String, [Dupes String]) -> Doc
forall a. (String, [Dupes a]) -> Doc
dupesMsg ((String, [Dupes String]) -> Doc)
-> [(String, [Dupes String])] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DupesMap String -> [(String, [Dupes String])]
forall k a. Map k a -> [(k, a)]
Map.toList DupesMap String
dupeFiles))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DupesMap URI -> Bool
forall k a. Map k a -> Bool
Map.null DupesMap URI
dupeUris) (Verbosity -> Doc -> IO ()
noticeDoc Verbosity
verbosity (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((String, [Dupes URI]) -> Doc
forall a. (String, [Dupes a]) -> Doc
dupesMsg ((String, [Dupes URI]) -> Doc) -> [(String, [Dupes URI])] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DupesMap URI -> [(String, [Dupes URI])]
forall k a. Map k a -> [(k, a)]
Map.toList DupesMap URI
dupeUris))

toDupes :: Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]
toDupes :: forall k a. Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]
toDupes [(k, [ProjectNode a])]
xs =
  [(k, [ProjectNode a])]
xs
    [(k, [ProjectNode a])]
-> ([(k, [ProjectNode a])] -> Map k [ProjectNode a])
-> Map k [ProjectNode a]
forall a b. a -> (a -> b) -> b
& ([ProjectNode a] -> [ProjectNode a] -> [ProjectNode a])
-> [(k, [ProjectNode a])] -> Map k [ProjectNode a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [ProjectNode a] -> [ProjectNode a] -> [ProjectNode a]
forall a. Semigroup a => a -> a -> a
(Prelude.<>)
    Map k [ProjectNode a]
-> (Map k [ProjectNode a] -> Map k [ProjectNode a])
-> Map k [ProjectNode a]
forall a b. a -> (a -> b) -> b
& ([ProjectNode a] -> Bool)
-> Map k [ProjectNode a] -> Map k [ProjectNode a]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool)
-> ([ProjectNode a] -> Int) -> [ProjectNode a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProjectNode a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
    Map k [ProjectNode a]
-> ([ProjectNode a] -> [Dupes a]) -> Map k [Dupes a]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[ProjectNode a]
ys -> [ProjectNode a -> [ProjectNode a] -> Dupes a
forall a. ProjectNode a -> [ProjectNode a] -> Dupes a
Dupes ProjectNode a
v [ProjectNode a]
ys | ProjectNode a
v <- [ProjectNode a]
ys]

detectDupes :: [(Maybe URI, ProjectConfigPath)] -> (DupesMap ProjectFilePath, DupesMap FilePath, DupesMap URI)
detectDupes :: [(Maybe URI, ProjectConfigPath)]
-> (DupesMap ProjectFilePath, DupesMap String, DupesMap URI)
detectDupes [(Maybe URI, ProjectConfigPath)]
xs = ([(String, [ProjectNode ProjectFilePath])]
-> DupesMap ProjectFilePath
forall k a. Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]
toDupes [(String, [ProjectNode ProjectFilePath])]
roots, [(String, [ProjectNode String])] -> DupesMap String
forall k a. Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]
toDupes [(String, [ProjectNode String])]
files, [(String, [ProjectNode URI])] -> DupesMap URI
forall k a. Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]
toDupes [(String, [ProjectNode URI])]
uris)
  where
    <$$> :: (a -> b) -> [(Maybe URI, a)] -> [(Maybe URI, b)]
(<$$>) = ((Maybe URI, a) -> (Maybe URI, b))
-> [(Maybe URI, a)] -> [(Maybe URI, b)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe URI, a) -> (Maybe URI, b))
 -> [(Maybe URI, a)] -> [(Maybe URI, b)])
-> ((a -> b) -> (Maybe URI, a) -> (Maybe URI, b))
-> (a -> b)
-> [(Maybe URI, a)]
-> [(Maybe URI, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (Maybe URI, a) -> (Maybe URI, b)
forall a b. (a -> b) -> (Maybe URI, a) -> (Maybe URI, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    roots :: [(String, [ProjectNode ProjectFilePath])]
roots =
      [ (String
h, [String -> ProjectNode ProjectFilePath
ProjectRoot String
h])
      | (Maybe URI
Nothing, (String
h, Maybe ProjectConfigPath
Nothing)) <- ProjectConfigPath -> (String, Maybe ProjectConfigPath)
unconsProjectConfigPath (ProjectConfigPath -> (String, Maybe ProjectConfigPath))
-> [(Maybe URI, ProjectConfigPath)]
-> [(Maybe URI, (String, Maybe ProjectConfigPath))]
forall {a} {b}. (a -> b) -> [(Maybe URI, a)] -> [(Maybe URI, b)]
<$$> [(Maybe URI, ProjectConfigPath)]
xs
      ]
    files :: [(String, [ProjectNode String])]
files =
      [ (String
h, [String -> ProjectConfigPath -> ProjectNode String
ProjectFileImport String
h (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
h ProjectConfigPath
t)])
      | (Maybe URI
Nothing, (String
h, Just ProjectConfigPath
t)) <- ProjectConfigPath -> (String, Maybe ProjectConfigPath)
unconsProjectConfigPath (ProjectConfigPath -> (String, Maybe ProjectConfigPath))
-> [(Maybe URI, ProjectConfigPath)]
-> [(Maybe URI, (String, Maybe ProjectConfigPath))]
forall {a} {b}. (a -> b) -> [(Maybe URI, a)] -> [(Maybe URI, b)]
<$$> [(Maybe URI, ProjectConfigPath)]
xs
      ]
    uris :: [(String, [ProjectNode URI])]
uris =
      [ (String
f, [URI -> ProjectConfigPath -> ProjectNode URI
ProjectUriImport URI
u (String -> ProjectConfigPath -> ProjectConfigPath
consProjectConfigPath String
f ProjectConfigPath
t)])
      | (Just URI
u, (String
f, Just ProjectConfigPath
t)) <- ProjectConfigPath -> (String, Maybe ProjectConfigPath)
unconsProjectConfigPath (ProjectConfigPath -> (String, Maybe ProjectConfigPath))
-> [(Maybe URI, ProjectConfigPath)]
-> [(Maybe URI, (String, Maybe ProjectConfigPath))]
forall {a} {b}. (a -> b) -> [(Maybe URI, a)] -> [(Maybe URI, b)]
<$$> [(Maybe URI, ProjectConfigPath)]
xs
      , URI -> String
forall a. Show a => a -> String
show URI
u String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f
      ]

data Dupes a = Dupes
  { forall a. Dupes a -> ProjectNode a
dupesImport :: ProjectNode a
  -- ^ The import that we're checking for duplicates.
  , forall a. Dupes a -> [ProjectNode a]
dupesImports :: [ProjectNode a]
  -- ^ All the imports of this file.
  }
  deriving (Dupes a -> Dupes a -> Bool
(Dupes a -> Dupes a -> Bool)
-> (Dupes a -> Dupes a -> Bool) -> Eq (Dupes a)
forall a. Dupes a -> Dupes a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Dupes a -> Dupes a -> Bool
== :: Dupes a -> Dupes a -> Bool
$c/= :: forall a. Dupes a -> Dupes a -> Bool
/= :: Dupes a -> Dupes a -> Bool
Eq)

instance Ord (Dupes a) where
  compare :: Dupes a -> Dupes a -> Ordering
compare Dupes a
x Dupes a
y =
    (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Dupes a -> Int) -> Dupes a -> Dupes a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [ProjectNode a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ProjectNode a] -> Int)
-> (Dupes a -> [ProjectNode a]) -> Dupes a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dupes a -> [ProjectNode a]
forall a. Dupes a -> [ProjectNode a]
dupesImports) Dupes a
x Dupes a
y
      Ordering -> Ordering -> Ordering
`thenCmp` ([ProjectNode a] -> [ProjectNode a] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([ProjectNode a] -> [ProjectNode a] -> Ordering)
-> (Dupes a -> [ProjectNode a]) -> Dupes a -> Dupes a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [ProjectNode a] -> [ProjectNode a]
forall a. Ord a => [a] -> [a]
sort ([ProjectNode a] -> [ProjectNode a])
-> (Dupes a -> [ProjectNode a]) -> Dupes a -> [ProjectNode a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dupes a -> [ProjectNode a]
forall a. Dupes a -> [ProjectNode a]
dupesImports) Dupes a
x Dupes a
y
      Ordering -> Ordering -> Ordering
`thenCmp` (ProjectNode a -> ProjectNode a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ProjectNode a -> ProjectNode a -> Ordering)
-> (Dupes a -> ProjectNode a) -> Dupes a -> Dupes a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Dupes a -> ProjectNode a
forall a. Dupes a -> ProjectNode a
dupesImport) Dupes a
x Dupes a
y
    where
      thenCmp :: Ordering -> Ordering -> Ordering
      thenCmp :: Ordering -> Ordering -> Ordering
thenCmp Ordering
EQ Ordering
o2 = Ordering
o2
      thenCmp Ordering
o1 Ordering
_ = Ordering
o1

type DupesMap a = Map FilePath [Dupes a]

dupesMsg :: (FilePath, [Dupes a]) -> Doc
dupesMsg :: forall a. (String, [Dupes a]) -> Doc
dupesMsg (String
duplicate, ds :: [Dupes a]
ds@(Int -> [Dupes a] -> [Dupes a]
forall a. Int -> [a] -> [a]
take Int
1 ([Dupes a] -> [Dupes a])
-> ([Dupes a] -> [Dupes a]) -> [Dupes a] -> [Dupes a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dupes a] -> [Dupes a]
forall a. Ord a => [a] -> [a]
sort -> [Dupes a]
dupes)) =
  [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    ((String -> Doc
text String
"Warning:" Doc -> Doc -> Doc
<+> Int -> Doc
int ([Dupes a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Dupes a]
ds) Doc -> Doc -> Doc
<+> String -> Doc
text String
"imports of" Doc -> Doc -> Doc
<+> String -> Doc
text String
duplicate) Doc -> Doc -> Doc
<> Doc
semi)
      Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: ((\Dupes{[ProjectNode a]
ProjectNode a
dupesImport :: forall a. Dupes a -> ProjectNode a
dupesImports :: forall a. Dupes a -> [ProjectNode a]
dupesImport :: ProjectNode a
dupesImports :: [ProjectNode a]
..} -> Doc -> ProjectNode a -> [ProjectNode a] -> Doc
forall a. Doc -> ProjectNode a -> [ProjectNode a] -> Doc
duplicateImportMsg Doc
empty ProjectNode a
dupesImport ([ProjectNode a] -> [ProjectNode a]
forall a. Ord a => [a] -> [a]
sort ([ProjectNode a] -> [ProjectNode a])
-> [ProjectNode a] -> [ProjectNode a]
forall a b. (a -> b) -> a -> b
$ [ProjectNode a]
dupesImports [ProjectNode a] -> [ProjectNode a] -> [ProjectNode a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [ProjectNode a
dupesImport])) (Dupes a -> Doc) -> [Dupes a] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dupes a]
dupes)

-- $setup
-- >>> import Text.PrettyPrint (render)