{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :  Distribution.PackageDescription.Check.Conditional
-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2023
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Checks on conditional targets (libraries, executables, etc. that are
-- still inside a CondTree and related checks that can only be performed
-- here (variables, duplicated modules).
module Distribution.PackageDescription.Check.Conditional
  ( checkCondTarget
  , checkDuplicateModules
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compiler
import Distribution.ModuleName (ModuleName)
import Distribution.PackageDescription
import Distribution.PackageDescription.Check.Monad
import Distribution.System

import qualified Data.Map as Map

import Control.Monad

-- As a prerequisite to some checks, we transform a target CondTree into
-- a CondTree of “target + useful context”.
-- This is slightly clearer, is easier to walk without resorting to
-- list comprehensions, allows us in the future to apply some sensible
-- “optimisations” to checks (exclusive branches, etc.).

-- | @nf@ function is needed to appropriately name some targets which need
-- to be spoonfed (otherwise name appears as "").
initTargetAnnotation
  :: Monoid a
  => (UnqualComponentName -> a -> a) -- Naming function for targets.
  -> UnqualComponentName
  -> TargetAnnotation a
initTargetAnnotation :: forall a.
Monoid a =>
(UnqualComponentName -> a -> a)
-> UnqualComponentName -> TargetAnnotation a
initTargetAnnotation UnqualComponentName -> a -> a
nf UnqualComponentName
n = a -> Bool -> TargetAnnotation a
forall a. a -> Bool -> TargetAnnotation a
TargetAnnotation (UnqualComponentName -> a -> a
nf UnqualComponentName
n a
forall a. Monoid a => a
mempty) Bool
False

-- | We “build up” target from various slices.
updateTargetAnnotation
  :: Monoid a
  => a -- A target (lib, exe, test, …)
  -> TargetAnnotation a
  -> TargetAnnotation a
updateTargetAnnotation :: forall a. Monoid a => a -> TargetAnnotation a -> TargetAnnotation a
updateTargetAnnotation a
t TargetAnnotation a
ta = TargetAnnotation a
ta{taTarget = taTarget ta <> t}

-- | Before walking a target 'CondTree', we need to annotate it with
-- information relevant to the checks (read 'TaraAnn' and 'checkCondTarget'
-- doc for more info).
annotateCondTree
  :: forall a
   . (Eq a, Monoid a)
  => [PackageFlag] -- User flags.
  -> TargetAnnotation a
  -> CondTree ConfVar a
  -> CondTree ConfVar (TargetAnnotation a)
annotateCondTree :: forall a.
(Eq a, Monoid a) =>
[PackageFlag]
-> TargetAnnotation a
-> CondTree ConfVar a
-> CondTree ConfVar (TargetAnnotation a)
annotateCondTree [PackageFlag]
fs TargetAnnotation a
ta (CondNode a
a [CondBranch ConfVar a]
bs) =
  let ta' :: TargetAnnotation a
ta' = a -> TargetAnnotation a -> TargetAnnotation a
forall a. Monoid a => a -> TargetAnnotation a -> TargetAnnotation a
updateTargetAnnotation a
a TargetAnnotation a
ta
      bs' :: [CondBranch ConfVar (TargetAnnotation a)]
bs' = (CondBranch ConfVar a -> CondBranch ConfVar (TargetAnnotation a))
-> [CondBranch ConfVar a]
-> [CondBranch ConfVar (TargetAnnotation a)]
forall a b. (a -> b) -> [a] -> [b]
map (TargetAnnotation a
-> CondBranch ConfVar a -> CondBranch ConfVar (TargetAnnotation a)
annotateBranch TargetAnnotation a
ta') [CondBranch ConfVar a]
bs
      bs'' :: [CondBranch ConfVar (TargetAnnotation a)]
bs'' = [PackageFlag]
-> [CondBranch ConfVar (TargetAnnotation a)]
-> [CondBranch ConfVar (TargetAnnotation a)]
forall a.
(Eq a, Monoid a) =>
[PackageFlag]
-> [CondBranch ConfVar (TargetAnnotation a)]
-> [CondBranch ConfVar (TargetAnnotation a)]
crossAnnotateBranches [PackageFlag]
defTrueFlags [CondBranch ConfVar (TargetAnnotation a)]
bs'
   in TargetAnnotation a
-> [CondBranch ConfVar (TargetAnnotation a)]
-> CondTree ConfVar (TargetAnnotation a)
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode TargetAnnotation a
ta' [CondBranch ConfVar (TargetAnnotation a)]
bs''
  where
    annotateBranch
      :: TargetAnnotation a
      -> CondBranch ConfVar a
      -> CondBranch ConfVar (TargetAnnotation a)
    annotateBranch :: TargetAnnotation a
-> CondBranch ConfVar a -> CondBranch ConfVar (TargetAnnotation a)
annotateBranch TargetAnnotation a
wta (CondBranch Condition ConfVar
k CondTree ConfVar a
t Maybe (CondTree ConfVar a)
mf) =
      let uf :: Bool
uf = Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
k
          wta' :: TargetAnnotation a
wta' = TargetAnnotation a
wta{taPackageFlag = taPackageFlag wta || uf}
          atf :: TargetAnnotation a
-> CondTree ConfVar a -> CondTree ConfVar (TargetAnnotation a)
atf = [PackageFlag]
-> TargetAnnotation a
-> CondTree ConfVar a
-> CondTree ConfVar (TargetAnnotation a)
forall a.
(Eq a, Monoid a) =>
[PackageFlag]
-> TargetAnnotation a
-> CondTree ConfVar a
-> CondTree ConfVar (TargetAnnotation a)
annotateCondTree [PackageFlag]
fs
       in Condition ConfVar
-> CondTree ConfVar (TargetAnnotation a)
-> Maybe (CondTree ConfVar (TargetAnnotation a))
-> CondBranch ConfVar (TargetAnnotation a)
forall v a.
Condition v
-> CondTree v a -> Maybe (CondTree v a) -> CondBranch v a
CondBranch
            Condition ConfVar
k
            (TargetAnnotation a
-> CondTree ConfVar a -> CondTree ConfVar (TargetAnnotation a)
atf TargetAnnotation a
wta' CondTree ConfVar a
t)
            (TargetAnnotation a
-> CondTree ConfVar a -> CondTree ConfVar (TargetAnnotation a)
atf TargetAnnotation a
wta (CondTree ConfVar a -> CondTree ConfVar (TargetAnnotation a))
-> Maybe (CondTree ConfVar a)
-> Maybe (CondTree ConfVar (TargetAnnotation a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CondTree ConfVar a)
mf)
    -- Note how we are passing the *old* wta
    -- in the `else` branch, since we are not
    -- under that flag.

    -- We only want to pick up variables that are flags and that are
    -- \*off* by default.
    isPkgFlagCond :: Condition ConfVar -> Bool
    isPkgFlagCond :: Condition ConfVar -> Bool
isPkgFlagCond (Lit Bool
_) = Bool
False
    isPkgFlagCond (Var (PackageFlag FlagName
f)) = FlagName
f FlagName -> [FlagName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FlagName]
defOffFlags
    isPkgFlagCond (Var ConfVar
_) = Bool
False
    isPkgFlagCond (CNot Condition ConfVar
cn) = Bool -> Bool
not (Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
cn)
    isPkgFlagCond (CAnd Condition ConfVar
ca Condition ConfVar
cb) = Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
ca Bool -> Bool -> Bool
|| Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
cb
    isPkgFlagCond (COr Condition ConfVar
ca Condition ConfVar
cb) = Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
ca Bool -> Bool -> Bool
&& Condition ConfVar -> Bool
isPkgFlagCond Condition ConfVar
cb

    -- Package flags that are off by default *and* that are manual.
    defOffFlags :: [FlagName]
defOffFlags =
      (PackageFlag -> FlagName) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
flagName ([PackageFlag] -> [FlagName]) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> a -> b
$
        (PackageFlag -> Bool) -> [PackageFlag] -> [PackageFlag]
forall a. (a -> Bool) -> [a] -> [a]
filter
          ( \PackageFlag
f ->
              Bool -> Bool
not (PackageFlag -> Bool
flagDefault PackageFlag
f)
                Bool -> Bool -> Bool
&& PackageFlag -> Bool
flagManual PackageFlag
f
          )
          [PackageFlag]
fs

    defTrueFlags :: [PackageFlag]
    defTrueFlags :: [PackageFlag]
defTrueFlags = (PackageFlag -> Bool) -> [PackageFlag] -> [PackageFlag]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageFlag -> Bool
flagDefault [PackageFlag]
fs

-- Propagate contextual information in CondTree branches. This is
-- needed as CondTree is a rosetree and not a binary tree.
crossAnnotateBranches
  :: forall a
   . (Eq a, Monoid a)
  => [PackageFlag] -- `default: true` flags.
  -> [CondBranch ConfVar (TargetAnnotation a)]
  -> [CondBranch ConfVar (TargetAnnotation a)]
crossAnnotateBranches :: forall a.
(Eq a, Monoid a) =>
[PackageFlag]
-> [CondBranch ConfVar (TargetAnnotation a)]
-> [CondBranch ConfVar (TargetAnnotation a)]
crossAnnotateBranches [PackageFlag]
fs [CondBranch ConfVar (TargetAnnotation a)]
bs = (CondBranch ConfVar (TargetAnnotation a)
 -> CondBranch ConfVar (TargetAnnotation a))
-> [CondBranch ConfVar (TargetAnnotation a)]
-> [CondBranch ConfVar (TargetAnnotation a)]
forall a b. (a -> b) -> [a] -> [b]
map CondBranch ConfVar (TargetAnnotation a)
-> CondBranch ConfVar (TargetAnnotation a)
crossAnnBranch [CondBranch ConfVar (TargetAnnotation a)]
bs
  where
    crossAnnBranch
      :: CondBranch ConfVar (TargetAnnotation a)
      -> CondBranch ConfVar (TargetAnnotation a)
    crossAnnBranch :: CondBranch ConfVar (TargetAnnotation a)
-> CondBranch ConfVar (TargetAnnotation a)
crossAnnBranch CondBranch ConfVar (TargetAnnotation a)
wr =
      let
        rs :: [CondBranch ConfVar (TargetAnnotation a)]
rs = (CondBranch ConfVar (TargetAnnotation a) -> Bool)
-> [CondBranch ConfVar (TargetAnnotation a)]
-> [CondBranch ConfVar (TargetAnnotation a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CondBranch ConfVar (TargetAnnotation a)
-> CondBranch ConfVar (TargetAnnotation a) -> Bool
forall a. Eq a => a -> a -> Bool
/= CondBranch ConfVar (TargetAnnotation a)
wr) [CondBranch ConfVar (TargetAnnotation a)]
bs
        ts :: [a]
ts = (CondBranch ConfVar (TargetAnnotation a) -> Maybe a)
-> [CondBranch ConfVar (TargetAnnotation a)] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CondBranch ConfVar (TargetAnnotation a) -> Maybe a
realiseBranch [CondBranch ConfVar (TargetAnnotation a)]
rs
       in
        a
-> CondBranch ConfVar (TargetAnnotation a)
-> CondBranch ConfVar (TargetAnnotation a)
updateTargetAnnBranch ([a] -> a
forall a. Monoid a => [a] -> a
mconcat [a]
ts) CondBranch ConfVar (TargetAnnotation a)
wr

    realiseBranch :: CondBranch ConfVar (TargetAnnotation a) -> Maybe a
    realiseBranch :: CondBranch ConfVar (TargetAnnotation a) -> Maybe a
realiseBranch CondBranch ConfVar (TargetAnnotation a)
b =
      let
        -- We are only interested in True by default package flags.
        realiseBranchFunction :: ConfVar -> Either ConfVar Bool
        realiseBranchFunction :: ConfVar -> Either ConfVar Bool
realiseBranchFunction (PackageFlag FlagName
n) | FlagName -> [FlagName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FlagName
n ((PackageFlag -> FlagName) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
flagName [PackageFlag]
fs) = Bool -> Either ConfVar Bool
forall a b. b -> Either a b
Right Bool
True
        realiseBranchFunction ConfVar
_ = Bool -> Either ConfVar Bool
forall a b. b -> Either a b
Right Bool
False
       in
        (ConfVar -> Either ConfVar Bool) -> CondBranch ConfVar a -> Maybe a
forall a v.
Semigroup a =>
(v -> Either v Bool) -> CondBranch v a -> Maybe a
simplifyCondBranch ConfVar -> Either ConfVar Bool
realiseBranchFunction ((TargetAnnotation a -> a)
-> CondBranch ConfVar (TargetAnnotation a) -> CondBranch ConfVar a
forall a b.
(a -> b) -> CondBranch ConfVar a -> CondBranch ConfVar b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TargetAnnotation a -> a
forall a. TargetAnnotation a -> a
taTarget CondBranch ConfVar (TargetAnnotation a)
b)

    updateTargetAnnBranch
      :: a
      -> CondBranch ConfVar (TargetAnnotation a)
      -> CondBranch ConfVar (TargetAnnotation a)
    updateTargetAnnBranch :: a
-> CondBranch ConfVar (TargetAnnotation a)
-> CondBranch ConfVar (TargetAnnotation a)
updateTargetAnnBranch a
a (CondBranch Condition ConfVar
k CondTree ConfVar (TargetAnnotation a)
t Maybe (CondTree ConfVar (TargetAnnotation a))
mt) =
      let updateTargetAnnTree :: CondTree v (TargetAnnotation a) -> CondTree v (TargetAnnotation a)
updateTargetAnnTree (CondNode TargetAnnotation a
ka [CondBranch v (TargetAnnotation a)]
wbs) =
            TargetAnnotation a
-> [CondBranch v (TargetAnnotation a)]
-> CondTree v (TargetAnnotation a)
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode (a -> TargetAnnotation a -> TargetAnnotation a
forall a. Monoid a => a -> TargetAnnotation a -> TargetAnnotation a
updateTargetAnnotation a
a TargetAnnotation a
ka) [CondBranch v (TargetAnnotation a)]
wbs
       in Condition ConfVar
-> CondTree ConfVar (TargetAnnotation a)
-> Maybe (CondTree ConfVar (TargetAnnotation a))
-> CondBranch ConfVar (TargetAnnotation a)
forall v a.
Condition v
-> CondTree v a -> Maybe (CondTree v a) -> CondBranch v a
CondBranch Condition ConfVar
k (CondTree ConfVar (TargetAnnotation a)
-> CondTree ConfVar (TargetAnnotation a)
forall {v}.
CondTree v (TargetAnnotation a) -> CondTree v (TargetAnnotation a)
updateTargetAnnTree CondTree ConfVar (TargetAnnotation a)
t) (CondTree ConfVar (TargetAnnotation a)
-> CondTree ConfVar (TargetAnnotation a)
forall {v}.
CondTree v (TargetAnnotation a) -> CondTree v (TargetAnnotation a)
updateTargetAnnTree (CondTree ConfVar (TargetAnnotation a)
 -> CondTree ConfVar (TargetAnnotation a))
-> Maybe (CondTree ConfVar (TargetAnnotation a))
-> Maybe (CondTree ConfVar (TargetAnnotation a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CondTree ConfVar (TargetAnnotation a))
mt)

-- | A conditional target is a library, exe, benchmark etc., destructured
-- in a CondTree. Traversing method: we render the branches, pass a
-- relevant context, collect checks.
checkCondTarget
  :: forall m a
   . (Monad m, Eq a, Monoid a)
  => [PackageFlag] -- User flags.
  -> (a -> CheckM m ()) -- Check function (a = target).
  -> (UnqualComponentName -> a -> a)
  -- Naming function (some targets
  -- need to have their name
  -- spoonfed to them.
  -> (UnqualComponentName, CondTree ConfVar a)
  -- Target name/condtree.
  -> CheckM m ()
checkCondTarget :: forall (m :: * -> *) a.
(Monad m, Eq a, Monoid a) =>
[PackageFlag]
-> (a -> CheckM m ())
-> (UnqualComponentName -> a -> a)
-> (UnqualComponentName, CondTree ConfVar a)
-> CheckM m ()
checkCondTarget [PackageFlag]
fs a -> CheckM m ()
cf UnqualComponentName -> a -> a
nf (UnqualComponentName
unqualName, CondTree ConfVar a
ct) =
  CondTree ConfVar (TargetAnnotation a) -> CheckM m ()
wTree (CondTree ConfVar (TargetAnnotation a) -> CheckM m ())
-> CondTree ConfVar (TargetAnnotation a) -> CheckM m ()
forall a b. (a -> b) -> a -> b
$ [PackageFlag]
-> TargetAnnotation a
-> CondTree ConfVar a
-> CondTree ConfVar (TargetAnnotation a)
forall a.
(Eq a, Monoid a) =>
[PackageFlag]
-> TargetAnnotation a
-> CondTree ConfVar a
-> CondTree ConfVar (TargetAnnotation a)
annotateCondTree [PackageFlag]
fs ((UnqualComponentName -> a -> a)
-> UnqualComponentName -> TargetAnnotation a
forall a.
Monoid a =>
(UnqualComponentName -> a -> a)
-> UnqualComponentName -> TargetAnnotation a
initTargetAnnotation UnqualComponentName -> a -> a
nf UnqualComponentName
unqualName) CondTree ConfVar a
ct
  where
    -- Walking the tree. Remember that CondTree is not a binary
    -- tree but a /rose/tree.
    wTree
      :: CondTree ConfVar (TargetAnnotation a)
      -> CheckM m ()
    wTree :: CondTree ConfVar (TargetAnnotation a) -> CheckM m ()
wTree (CondNode TargetAnnotation a
ta [CondBranch ConfVar (TargetAnnotation a)]
bs)
      -- There are no branches ([] == True) *or* every branch
      -- is “simple” (i.e. missing a 'condBranchIfFalse' part).
      -- This is convenient but not necessarily correct in all
      -- cases; a more precise way would be to check incompatibility
      -- among simple branches conditions (or introduce a principled
      -- `cond` construct in `.cabal` files.
      | (CondBranch ConfVar (TargetAnnotation a) -> Bool)
-> [CondBranch ConfVar (TargetAnnotation a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CondBranch ConfVar (TargetAnnotation a) -> Bool
isSimple [CondBranch ConfVar (TargetAnnotation a)]
bs = do
          (CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m ()
forall (m :: * -> *).
Monad m =>
(CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m ()
localCM (TargetAnnotation a -> CheckCtx m -> CheckCtx m
forall a (m :: * -> *).
TargetAnnotation a -> CheckCtx m -> CheckCtx m
initCheckCtx TargetAnnotation a
ta) (a -> CheckM m ()
cf (a -> CheckM m ()) -> a -> CheckM m ()
forall a b. (a -> b) -> a -> b
$ TargetAnnotation a -> a
forall a. TargetAnnotation a -> a
taTarget TargetAnnotation a
ta)
          (CondBranch ConfVar (TargetAnnotation a) -> CheckM m ())
-> [CondBranch ConfVar (TargetAnnotation a)] -> CheckM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CondBranch ConfVar (TargetAnnotation a) -> CheckM m ()
wBranch [CondBranch ConfVar (TargetAnnotation a)]
bs
      -- If there are T/F conditions, there is no need to check
      -- the intermediate 'TargetAnnotation' too.
      | Bool
otherwise = do
          (CondBranch ConfVar (TargetAnnotation a) -> CheckM m ())
-> [CondBranch ConfVar (TargetAnnotation a)] -> CheckM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CondBranch ConfVar (TargetAnnotation a) -> CheckM m ()
wBranch [CondBranch ConfVar (TargetAnnotation a)]
bs

    isSimple
      :: CondBranch ConfVar (TargetAnnotation a)
      -> Bool
    isSimple :: CondBranch ConfVar (TargetAnnotation a) -> Bool
isSimple (CondBranch Condition ConfVar
_ CondTree ConfVar (TargetAnnotation a)
_ Maybe (CondTree ConfVar (TargetAnnotation a))
Nothing) = Bool
True
    isSimple (CondBranch Condition ConfVar
_ CondTree ConfVar (TargetAnnotation a)
_ (Just CondTree ConfVar (TargetAnnotation a)
_)) = Bool
False

    wBranch
      :: CondBranch ConfVar (TargetAnnotation a)
      -> CheckM m ()
    wBranch :: CondBranch ConfVar (TargetAnnotation a) -> CheckM m ()
wBranch (CondBranch Condition ConfVar
k CondTree ConfVar (TargetAnnotation a)
t Maybe (CondTree ConfVar (TargetAnnotation a))
mf) = do
      Condition ConfVar -> CheckM m ()
forall (m :: * -> *). Monad m => Condition ConfVar -> CheckM m ()
checkCondVars Condition ConfVar
k
      CondTree ConfVar (TargetAnnotation a) -> CheckM m ()
wTree CondTree ConfVar (TargetAnnotation a)
t
      CheckM m ()
-> (CondTree ConfVar (TargetAnnotation a) -> CheckM m ())
-> Maybe (CondTree ConfVar (TargetAnnotation a))
-> CheckM m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CondTree ConfVar (TargetAnnotation a) -> CheckM m ()
wTree Maybe (CondTree ConfVar (TargetAnnotation a))
mf

-- | Condvar checking (misspelled OS in if conditions, etc).
checkCondVars :: Monad m => Condition ConfVar -> CheckM m ()
checkCondVars :: forall (m :: * -> *). Monad m => Condition ConfVar -> CheckM m ()
checkCondVars Condition ConfVar
cond =
  let (Condition ConfVar
_, [ConfVar]
vs) = Condition ConfVar
-> (ConfVar -> Either ConfVar Bool)
-> (Condition ConfVar, [ConfVar])
forall c d.
Condition c -> (c -> Either d Bool) -> (Condition d, [d])
simplifyCondition Condition ConfVar
cond (\ConfVar
v -> ConfVar -> Either ConfVar Bool
forall a b. a -> Either a b
Left ConfVar
v)
   in -- Using simplifyCondition is convenient and correct,
      -- if checks become more complex we can always walk
      -- 'Condition'.
      (ConfVar -> CheckM m ()) -> [ConfVar] -> CheckM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ConfVar -> CheckM m ()
forall (m :: * -> *). Monad m => ConfVar -> CheckM m ()
vcheck [ConfVar]
vs
  where
    vcheck :: Monad m => ConfVar -> CheckM m ()
    vcheck :: forall (m :: * -> *). Monad m => ConfVar -> CheckM m ()
vcheck (OS (OtherOS String
os)) =
      PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ [String] -> CheckExplanation
UnknownOS [String
os])
    vcheck (Arch (OtherArch String
arch)) =
      PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ [String] -> CheckExplanation
UnknownArch [String
arch])
    vcheck (Impl (OtherCompiler String
os) VersionRange
_) =
      PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ [String] -> CheckExplanation
UnknownCompiler [String
os])
    vcheck ConfVar
_ = () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Checking duplicated modules cannot unfortunately be done in the
-- “tree checking”. This is because of the monoidal instance in some targets,
-- where e.g. merged dependencies are `nub`’d, hence losing information for
-- this particular check.
checkDuplicateModules :: GenericPackageDescription -> [PackageCheck]
checkDuplicateModules :: GenericPackageDescription -> [PackageCheck]
checkDuplicateModules GenericPackageDescription
pkg =
  (CondTree ConfVar Library -> [PackageCheck])
-> [CondTree ConfVar Library] -> [PackageCheck]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CondTree ConfVar Library -> [PackageCheck]
forall {v}. CondTree v Library -> [PackageCheck]
checkLib (([CondTree ConfVar Library] -> [CondTree ConfVar Library])
-> (CondTree ConfVar Library
    -> [CondTree ConfVar Library] -> [CondTree ConfVar Library])
-> Maybe (CondTree ConfVar Library)
-> [CondTree ConfVar Library]
-> [CondTree ConfVar Library]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [CondTree ConfVar Library] -> [CondTree ConfVar Library]
forall a. a -> a
id (:) (GenericPackageDescription -> Maybe (CondTree ConfVar Library)
condLibrary GenericPackageDescription
pkg) ([CondTree ConfVar Library] -> [CondTree ConfVar Library])
-> ([(UnqualComponentName, CondTree ConfVar Library)]
    -> [CondTree ConfVar Library])
-> [(UnqualComponentName, CondTree ConfVar Library)]
-> [CondTree ConfVar Library]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnqualComponentName, CondTree ConfVar Library)
 -> CondTree ConfVar Library)
-> [(UnqualComponentName, CondTree ConfVar Library)]
-> [CondTree ConfVar Library]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar Library)
-> CondTree ConfVar Library
forall a b. (a, b) -> b
snd ([(UnqualComponentName, CondTree ConfVar Library)]
 -> [CondTree ConfVar Library])
-> [(UnqualComponentName, CondTree ConfVar Library)]
-> [CondTree ConfVar Library]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar Library)]
condSubLibraries GenericPackageDescription
pkg)
    [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ ((UnqualComponentName, CondTree ConfVar Executable)
 -> [PackageCheck])
-> [(UnqualComponentName, CondTree ConfVar Executable)]
-> [PackageCheck]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CondTree ConfVar Executable -> [PackageCheck]
forall {v}. CondTree v Executable -> [PackageCheck]
checkExe (CondTree ConfVar Executable -> [PackageCheck])
-> ((UnqualComponentName, CondTree ConfVar Executable)
    -> CondTree ConfVar Executable)
-> (UnqualComponentName, CondTree ConfVar Executable)
-> [PackageCheck]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar Executable)
-> CondTree ConfVar Executable
forall a b. (a, b) -> b
snd) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar Executable)]
condExecutables GenericPackageDescription
pkg)
    [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ ((UnqualComponentName, CondTree ConfVar TestSuite)
 -> [PackageCheck])
-> [(UnqualComponentName, CondTree ConfVar TestSuite)]
-> [PackageCheck]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CondTree ConfVar TestSuite -> [PackageCheck]
forall {v}. CondTree v TestSuite -> [PackageCheck]
checkTest (CondTree ConfVar TestSuite -> [PackageCheck])
-> ((UnqualComponentName, CondTree ConfVar TestSuite)
    -> CondTree ConfVar TestSuite)
-> (UnqualComponentName, CondTree ConfVar TestSuite)
-> [PackageCheck]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar TestSuite)
-> CondTree ConfVar TestSuite
forall a b. (a, b) -> b
snd) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar TestSuite)]
condTestSuites GenericPackageDescription
pkg)
    [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ ((UnqualComponentName, CondTree ConfVar Benchmark)
 -> [PackageCheck])
-> [(UnqualComponentName, CondTree ConfVar Benchmark)]
-> [PackageCheck]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CondTree ConfVar Benchmark -> [PackageCheck]
forall {v}. CondTree v Benchmark -> [PackageCheck]
checkBench (CondTree ConfVar Benchmark -> [PackageCheck])
-> ((UnqualComponentName, CondTree ConfVar Benchmark)
    -> CondTree ConfVar Benchmark)
-> (UnqualComponentName, CondTree ConfVar Benchmark)
-> [PackageCheck]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar Benchmark)
-> CondTree ConfVar Benchmark
forall a b. (a, b) -> b
snd) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar Benchmark)]
condBenchmarks GenericPackageDescription
pkg)
  where
    -- the duplicate modules check is has not been thoroughly vetted for backpack
    checkLib :: CondTree v Library -> [PackageCheck]
checkLib = String
-> (Library -> [ModuleName])
-> CondTree v Library
-> [PackageCheck]
forall a v.
String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
checkDups String
"library" (\Library
l -> Library -> [ModuleName]
explicitLibModules Library
l [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ (ModuleReexport -> ModuleName) -> [ModuleReexport] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleReexport -> ModuleName
moduleReexportName (Library -> [ModuleReexport]
reexportedModules Library
l))
    checkExe :: CondTree v Executable -> [PackageCheck]
checkExe = String
-> (Executable -> [ModuleName])
-> CondTree v Executable
-> [PackageCheck]
forall a v.
String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
checkDups String
"executable" Executable -> [ModuleName]
exeModules
    checkTest :: CondTree v TestSuite -> [PackageCheck]
checkTest = String
-> (TestSuite -> [ModuleName])
-> CondTree v TestSuite
-> [PackageCheck]
forall a v.
String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
checkDups String
"test suite" TestSuite -> [ModuleName]
testModules
    checkBench :: CondTree v Benchmark -> [PackageCheck]
checkBench = String
-> (Benchmark -> [ModuleName])
-> CondTree v Benchmark
-> [PackageCheck]
forall a v.
String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
checkDups String
"benchmark" Benchmark -> [ModuleName]
benchmarkModules
    checkDups :: String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
    checkDups :: forall a v.
String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck]
checkDups String
s a -> [ModuleName]
getModules CondTree v a
t =
      let sumPair :: (Int, Int) -> (Int, Int) -> (Int, Int)
sumPair (Int
x, Int
x') (Int
y, Int
y') = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x' :: Int, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y' :: Int)
          mergePair :: (a, a) -> (b, b) -> (a, b)
mergePair (a
x, a
x') (b
y, b
y') = (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
x', b -> b -> b
forall a. Ord a => a -> a -> a
max b
y b
y')
          maxPair :: (a, a) -> (b, b) -> (a, b)
maxPair (a
x, a
x') (b
y, b
y') = (a -> a -> a
forall a. Ord a => a -> a -> a
max a
x a
x', b -> b -> b
forall a. Ord a => a -> a -> a
max b
y b
y')
          libMap :: Map ModuleName (Int, Int)
          libMap :: Map ModuleName (Int, Int)
libMap =
            Map ModuleName (Int, Int)
-> (a -> Map ModuleName (Int, Int))
-> (Map ModuleName (Int, Int)
    -> Map ModuleName (Int, Int) -> Map ModuleName (Int, Int))
-> (Map ModuleName (Int, Int)
    -> Map ModuleName (Int, Int) -> Map ModuleName (Int, Int))
-> CondTree v a
-> Map ModuleName (Int, Int)
forall b a v.
b
-> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> CondTree v a -> b
foldCondTree
              Map ModuleName (Int, Int)
forall k a. Map k a
Map.empty
              (\a
v -> ((Int, Int) -> (Int, Int) -> (Int, Int))
-> [(ModuleName, (Int, Int))] -> Map ModuleName (Int, Int)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (Int, Int) -> (Int, Int) -> (Int, Int)
sumPair ([(ModuleName, (Int, Int))] -> Map ModuleName (Int, Int))
-> ([ModuleName] -> [(ModuleName, (Int, Int))])
-> [ModuleName]
-> Map ModuleName (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> (ModuleName, (Int, Int)))
-> [ModuleName] -> [(ModuleName, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (,(Int
1, Int
1)) ([ModuleName] -> Map ModuleName (Int, Int))
-> [ModuleName] -> Map ModuleName (Int, Int)
forall a b. (a -> b) -> a -> b
$ a -> [ModuleName]
getModules a
v)
              (((Int, Int) -> (Int, Int) -> (Int, Int))
-> Map ModuleName (Int, Int)
-> Map ModuleName (Int, Int)
-> Map ModuleName (Int, Int)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Int, Int) -> (Int, Int) -> (Int, Int)
forall {a} {b}. (Num a, Ord b) => (a, a) -> (b, b) -> (a, b)
mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely.
              (((Int, Int) -> (Int, Int) -> (Int, Int))
-> Map ModuleName (Int, Int)
-> Map ModuleName (Int, Int)
-> Map ModuleName (Int, Int)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Int, Int) -> (Int, Int) -> (Int, Int)
forall {a} {b}. (Ord a, Ord b) => (a, a) -> (b, b) -> (a, b)
maxPair) -- a module occurs the max of times it might appear in exclusive branches
              CondTree v a
t
          dupLibsStrict :: [ModuleName]
dupLibsStrict = Map ModuleName (Int, Int) -> [ModuleName]
forall k a. Map k a -> [k]
Map.keys (Map ModuleName (Int, Int) -> [ModuleName])
-> Map ModuleName (Int, Int) -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Bool)
-> Map ModuleName (Int, Int) -> Map ModuleName (Int, Int)
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) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst) Map ModuleName (Int, Int)
libMap
          dupLibsLax :: [ModuleName]
dupLibsLax = Map ModuleName (Int, Int) -> [ModuleName]
forall k a. Map k a -> [k]
Map.keys (Map ModuleName (Int, Int) -> [ModuleName])
-> Map ModuleName (Int, Int) -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Bool)
-> Map ModuleName (Int, Int) -> Map ModuleName (Int, Int)
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) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd) Map ModuleName (Int, Int)
libMap
       in if
              | Bool -> Bool
not ([ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
dupLibsLax) -> [CheckExplanation -> PackageCheck
PackageBuildImpossible (String -> [ModuleName] -> CheckExplanation
DuplicateModule String
s [ModuleName]
dupLibsLax)]
              | Bool -> Bool
not ([ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
dupLibsStrict) -> [CheckExplanation -> PackageCheck
PackageDistSuspicious (String -> [ModuleName] -> CheckExplanation
PotentialDupModule String
s [ModuleName]
dupLibsStrict)]
              | Bool
otherwise -> []