-- |
-- Module      :  Distribution.PackageDescription.Check.Common
-- Copyright   :  Francesco Ariis 2022
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Common types/functions to various check modules which are *no* part of
-- Distribution.PackageDescription.Check.Monad.
module Distribution.PackageDescription.Check.Common
  ( AssocDep
  , CabalField
  , PathKind (..)
  , checkCustomField
  , partitionDeps
  , checkPVP
  , checkPVPs
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compat.NonEmptySet (toNonEmpty)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Check.Monad
import Distribution.Utils.Generic (isAscii)
import Distribution.Version

import Control.Monad

-- Type of FilePath.
data PathKind
  = PathKindFile
  | PathKindDirectory
  | PathKindGlob
  deriving (PathKind -> PathKind -> Bool
(PathKind -> PathKind -> Bool)
-> (PathKind -> PathKind -> Bool) -> Eq PathKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathKind -> PathKind -> Bool
== :: PathKind -> PathKind -> Bool
$c/= :: PathKind -> PathKind -> Bool
/= :: PathKind -> PathKind -> Bool
Eq)

-- | .cabal field we are referring to. As now it is just a synonym to help
-- reading the code, in the future it might take advantage of typification
-- in Cabal-syntax.
type CabalField = String

checkCustomField :: Monad m => (String, String) -> CheckM m ()
checkCustomField :: forall (m :: * -> *). Monad m => (String, String) -> CheckM m ()
checkCustomField (String
n, String
_) =
  Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
    ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAscii) String
n)
    (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ [String] -> CheckExplanation
NonASCIICustomField [String
n])

-- ------------------------------------------------------------
-- PVP types/functions
-- ------------------------------------------------------------

-- A library name / dependencies association list. Ultimately to be
-- fed to PVP check.
type AssocDep = (UnqualComponentName, [Dependency])

-- Convenience function to partition important dependencies by name. To
-- be used together with checkPVP. Important: usually “base” or “Cabal”,
-- as the error is slightly different.
-- Note that `partitionDeps` will also filter out dependencies which are
-- already present in a inherithed fashion (e.g. an exe which imports the
-- main library will not need to specify upper bounds on shared dependencies,
-- hence we do not return those).
--
partitionDeps
  :: Monad m
  => [AssocDep] -- Possibly inherited dependencies, i.e.
  -- dependencies from internal/main libs.
  -> [UnqualComponentName] -- List of package names ("base", "Cabal"…)
  -> [Dependency] -- Dependencies to check.
  -> CheckM m ([Dependency], [Dependency])
partitionDeps :: forall (m :: * -> *).
Monad m =>
[AssocDep]
-> [UnqualComponentName]
-> [Dependency]
-> CheckM m ([Dependency], [Dependency])
partitionDeps [AssocDep]
ads [UnqualComponentName]
ns [Dependency]
ds = do
  -- Shared dependencies from “intra .cabal” libraries.
  let
    -- names of our dependencies
    dqs :: [UnqualComponentName]
dqs = (Dependency -> UnqualComponentName)
-> [Dependency] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> UnqualComponentName
unqualName [Dependency]
ds
    -- shared targets that match
    fads :: [AssocDep]
fads = (AssocDep -> Bool) -> [AssocDep] -> [AssocDep]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnqualComponentName -> [UnqualComponentName] -> Bool)
-> [UnqualComponentName] -> UnqualComponentName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnqualComponentName -> [UnqualComponentName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [UnqualComponentName]
dqs (UnqualComponentName -> Bool)
-> (AssocDep -> UnqualComponentName) -> AssocDep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssocDep -> UnqualComponentName
forall a b. (a, b) -> a
fst) [AssocDep]
ads
    -- the names of such targets
    inNam :: [UnqualComponentName]
inNam = [UnqualComponentName] -> [UnqualComponentName]
forall a. Eq a => [a] -> [a]
nub ([UnqualComponentName] -> [UnqualComponentName])
-> [UnqualComponentName] -> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ (AssocDep -> UnqualComponentName)
-> [AssocDep] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map AssocDep -> UnqualComponentName
forall a b. (a, b) -> a
fst [AssocDep]
fads :: [UnqualComponentName]
    -- the dependencies of such targets
    inDep :: [Dependency]
inDep = (AssocDep -> [Dependency]) -> [AssocDep] -> [Dependency]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AssocDep -> [Dependency]
forall a b. (a, b) -> b
snd [AssocDep]
fads :: [Dependency]

  -- We exclude from checks:
  -- 1. dependencies which are shared with main library / a
  --    sublibrary; and of course
  -- 2. the names of main library / sub libraries themselves.
  --
  -- So in myPackage.cabal
  -- library
  --      build-depends: text < 5
  -- ⁝
  --      build-depends: myPackage,        ← no warning, internal
  --                     text,             ← no warning, inherited
  --                     monadacme         ← warning!
  let fFun :: Dependency -> Bool
fFun Dependency
d =
        UnqualComponentName -> [UnqualComponentName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Dependency -> UnqualComponentName
unqualName Dependency
d) [UnqualComponentName]
inNam
          Bool -> Bool -> Bool
&& UnqualComponentName -> [UnqualComponentName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem
            (Dependency -> UnqualComponentName
unqualName Dependency
d)
            ((Dependency -> UnqualComponentName)
-> [Dependency] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> UnqualComponentName
unqualName [Dependency]
inDep)
      ds' :: [Dependency]
ds' = (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter Dependency -> Bool
fFun [Dependency]
ds

  ([Dependency], [Dependency])
-> CheckM m ([Dependency], [Dependency])
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Dependency], [Dependency])
 -> CheckM m ([Dependency], [Dependency]))
-> ([Dependency], [Dependency])
-> CheckM m ([Dependency], [Dependency])
forall a b. (a -> b) -> a -> b
$ (Dependency -> Bool)
-> [Dependency] -> ([Dependency], [Dependency])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((UnqualComponentName -> [UnqualComponentName] -> Bool)
-> [UnqualComponentName] -> UnqualComponentName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnqualComponentName -> [UnqualComponentName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [UnqualComponentName]
ns (UnqualComponentName -> Bool)
-> (Dependency -> UnqualComponentName) -> Dependency -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> UnqualComponentName
unqualName) [Dependency]
ds'
  where
    -- Return *sublibrary* name if exists (internal),
    -- otherwise package name.
    unqualName :: Dependency -> UnqualComponentName
    unqualName :: Dependency -> UnqualComponentName
unqualName (Dependency PackageName
n VersionRange
_ NonEmptySet LibraryName
nel) =
      case NonEmpty LibraryName -> LibraryName
forall a. NonEmpty a -> a
head (NonEmptySet LibraryName -> NonEmpty LibraryName
forall a. NonEmptySet a -> NonEmpty a
toNonEmpty NonEmptySet LibraryName
nel) of
        (LSubLibName UnqualComponentName
ln) -> UnqualComponentName
ln
        LibraryName
_ -> PackageName -> UnqualComponentName
packageNameToUnqualComponentName PackageName
n

-- PVP dependency check (one warning message per dependency, usually
-- for important dependencies like base).
checkPVP
  :: Monad m
  => (String -> PackageCheck) -- Warn message dependend on name
  -- (e.g. "base", "Cabal").
  -> [Dependency]
  -> CheckM m ()
checkPVP :: forall (m :: * -> *).
Monad m =>
(String -> PackageCheck) -> [Dependency] -> CheckM m ()
checkPVP String -> PackageCheck
ckf [Dependency]
ds = do
  let ods :: [Dependency]
ods = [Dependency] -> [Dependency]
checkPVPPrim [Dependency]
ds
  (Dependency -> CheckM m ()) -> [Dependency] -> CheckM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP (PackageCheck -> CheckM m ())
-> (Dependency -> PackageCheck) -> Dependency -> CheckM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PackageCheck
ckf (String -> PackageCheck)
-> (Dependency -> String) -> Dependency -> PackageCheck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName (PackageName -> String)
-> (Dependency -> PackageName) -> Dependency -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> PackageName
depPkgName) [Dependency]
ods

-- PVP dependency check for a list of dependencies. Some code duplication
-- is sadly needed to provide more ergonimic error messages.
checkPVPs
  :: Monad m
  => ( [String]
       -> PackageCheck -- Grouped error message, depends on a
       -- set of names.
     )
  -> [Dependency] -- Deps to analyse.
  -> CheckM m ()
checkPVPs :: forall (m :: * -> *).
Monad m =>
([String] -> PackageCheck) -> [Dependency] -> CheckM m ()
checkPVPs [String] -> PackageCheck
cf [Dependency]
ds
  | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ns = () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP ([String] -> PackageCheck
cf [String]
ns)
  where
    ods :: [Dependency]
ods = [Dependency] -> [Dependency]
checkPVPPrim [Dependency]
ds
    ns :: [String]
ns = (Dependency -> String) -> [Dependency] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
unPackageName (PackageName -> String)
-> (Dependency -> PackageName) -> Dependency -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> PackageName
depPkgName) [Dependency]
ods

-- Returns dependencies without upper bounds.
checkPVPPrim :: [Dependency] -> [Dependency]
checkPVPPrim :: [Dependency] -> [Dependency]
checkPVPPrim [Dependency]
ds = (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter Dependency -> Bool
withoutUpper [Dependency]
ds
  where
    withoutUpper :: Dependency -> Bool
    withoutUpper :: Dependency -> Bool
withoutUpper (Dependency PackageName
_ VersionRange
ver NonEmptySet LibraryName
_) = Bool -> Bool
not (Bool -> Bool) -> (VersionRange -> Bool) -> VersionRange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> Bool
hasUpperBound (VersionRange -> Bool) -> VersionRange -> Bool
forall a b. (a -> b) -> a -> b
$ VersionRange
ver