{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      :  Distribution.PackageDescription.Check.Monad
-- Copyright   :  Francesco Ariis 2022
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Primitives for package checking: check types and monadic interface.
-- Having these primitives in a different module allows us to appropriately
-- limit/manage the interface to suit checking needs.
module Distribution.PackageDescription.Check.Monad
  ( -- * Types and constructors
    CheckM (..)
  , execCheckM
  , CheckInterface (..)
  , CheckPackageContentOps (..)
  , CheckPreDistributionOps (..)
  , TargetAnnotation (..)
  , PackageCheck (..)
  , CheckExplanation (..)
  , CEType (..)
  , WarnLang (..)
  , CheckCtx (..)
  , pristineCheckCtx
  , initCheckCtx
  , PNames (..)

    -- * Operations
  , ppPackageCheck
  , isHackageDistError
  , asksCM
  , localCM
  , checkP
  , checkPkg
  , liftInt
  , tellP
  , checkSpecVer
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.CabalSpecVersion (CabalSpecVersion)
import Distribution.Package (packageName)
import Distribution.PackageDescription.Check.Warning
import Distribution.Simple.BuildToolDepends (desugarBuildToolSimple)
import Distribution.Simple.Glob (Glob, GlobResult)
import Distribution.Types.ExeDependency (ExeDependency)
import Distribution.Types.GenericPackageDescription
import Distribution.Types.LegacyExeDependency (LegacyExeDependency)
import Distribution.Types.PackageDescription (package, specVersion)
import Distribution.Types.PackageId (PackageIdentifier)
import Distribution.Types.UnqualComponentName

import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Writer as Writer
import qualified Data.ByteString.Lazy as BS
import qualified Data.Set as Set

import Control.Monad

-- Monadic interface for for Distribution.PackageDescription.Check.
--
-- Monadic checking allows us to have a fine grained control on checks
-- (e.g. omitting warning checks in certain situations).

-- * Interfaces

--

-- | Which interface to we have available/should we use? (to perform: pure
-- checks, package checks, pre-distribution checks.)
data CheckInterface m = CheckInterface
  { forall (m :: * -> *). CheckInterface m -> Bool
ciPureChecks :: Bool
  , -- Perform pure checks?
    forall (m :: * -> *).
CheckInterface m -> Maybe (CheckPackageContentOps m)
ciPackageOps :: Maybe (CheckPackageContentOps m)
  , -- If you want to perform package contents
    -- checks, provide an interface.
    forall (m :: * -> *).
CheckInterface m -> Maybe (CheckPreDistributionOps m)
ciPreDistOps :: Maybe (CheckPreDistributionOps m)
    -- If you want to work-tree checks, provide
    -- an interface.
  }

-- | A record of operations needed to check the contents of packages.
-- Abstracted over `m` to provide flexibility (could be IO, a .tar.gz
-- file, etc).
data CheckPackageContentOps m = CheckPackageContentOps
  { forall (m :: * -> *).
CheckPackageContentOps m -> FilePath -> m Bool
doesFileExist :: FilePath -> m Bool
  , forall (m :: * -> *).
CheckPackageContentOps m -> FilePath -> m Bool
doesDirectoryExist :: FilePath -> m Bool
  , forall (m :: * -> *).
CheckPackageContentOps m -> FilePath -> m [FilePath]
getDirectoryContents :: FilePath -> m [FilePath]
  , forall (m :: * -> *).
CheckPackageContentOps m -> FilePath -> m ByteString
getFileContents :: FilePath -> m BS.ByteString
  }

-- | A record of operations needed to check contents *of the work tree*
-- (compare it with 'CheckPackageContentOps'). This is still `m` abstracted
-- in case in the future we can obtain the same infos other than from IO
-- (e.g. a VCS work tree).
data CheckPreDistributionOps m = CheckPreDistributionOps
  { forall (m :: * -> *).
CheckPreDistributionOps m
-> FilePath -> Glob -> m [GlobResult FilePath]
runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath]
  , forall (m :: * -> *).
CheckPreDistributionOps m -> FilePath -> m [FilePath]
getDirectoryContentsM :: FilePath -> m [FilePath]
  }

-- | Context to perform checks (will be the Reader part in your monad).
data CheckCtx m = CheckCtx
  { forall (m :: * -> *). CheckCtx m -> CheckInterface m
ccInterface :: CheckInterface m
  , -- Interface for checks.

    -- Contextual infos for checks.
    forall (m :: * -> *). CheckCtx m -> Bool
ccFlag :: Bool
  , -- Are we under a user flag?

    -- Convenience bits that we prefer to carry
    -- in our Reader monad instead of passing it
    -- via ->, as they are often useful and often
    -- in deeply nested places in the GPD tree.
    forall (m :: * -> *). CheckCtx m -> CabalSpecVersion
ccSpecVersion :: CabalSpecVersion
  , -- Cabal version.
    forall (m :: * -> *).
CheckCtx m -> LegacyExeDependency -> Maybe ExeDependency
ccDesugar :: LegacyExeDependency -> Maybe ExeDependency
  , -- A desugaring function from
    -- Distribution.Simple.BuildToolDepends
    -- (desugarBuildToolSimple). Again since it
    -- eats PackageName and a list of executable
    -- names, it is more convenient to pass it
    -- via Reader.
    forall (m :: * -> *). CheckCtx m -> PNames
ccNames :: PNames
    -- Various names (id, libs, execs, tests,
    -- benchs), convenience.
  }

-- | Creates a pristing 'CheckCtx'. With pristine we mean everything that
-- can be deduced by GPD but *not* user flags information.
pristineCheckCtx
  :: Monad m
  => CheckInterface m
  -> GenericPackageDescription
  -> CheckCtx m
pristineCheckCtx :: forall (m :: * -> *).
Monad m =>
CheckInterface m -> GenericPackageDescription -> CheckCtx m
pristineCheckCtx CheckInterface m
ci GenericPackageDescription
gpd =
  let ens :: [UnqualComponentName]
ens = ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> UnqualComponentName)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> UnqualComponentName
forall a b. (a, b) -> a
fst (GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condExecutables GenericPackageDescription
gpd)
   in CheckInterface m
-> Bool
-> CabalSpecVersion
-> (LegacyExeDependency -> Maybe ExeDependency)
-> PNames
-> CheckCtx m
forall (m :: * -> *).
CheckInterface m
-> Bool
-> CabalSpecVersion
-> (LegacyExeDependency -> Maybe ExeDependency)
-> PNames
-> CheckCtx m
CheckCtx
        CheckInterface m
ci
        Bool
False
        (PackageDescription -> CabalSpecVersion
specVersion (PackageDescription -> CabalSpecVersion)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> CabalSpecVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription (GenericPackageDescription -> CabalSpecVersion)
-> GenericPackageDescription -> CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
gpd)
        (PackageName
-> [UnqualComponentName]
-> LegacyExeDependency
-> Maybe ExeDependency
desugarBuildToolSimple (GenericPackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName GenericPackageDescription
gpd) [UnqualComponentName]
ens)
        (GenericPackageDescription -> PNames
initPNames GenericPackageDescription
gpd)

-- | Adds useful bits to 'CheckCtx' (as now, whether we are operating under
-- a user off-by-default flag).
initCheckCtx :: Monad m => TargetAnnotation a -> CheckCtx m -> CheckCtx m
initCheckCtx :: forall (m :: * -> *) a.
Monad m =>
TargetAnnotation a -> CheckCtx m -> CheckCtx m
initCheckCtx TargetAnnotation a
t CheckCtx m
c = CheckCtx m
c{ccFlag = taPackageFlag t}

-- | 'TargetAnnotation' collects contextual information on the target we are
-- realising: a buildup of the various slices of the target (a library,
-- executable, etc. — is a monoid) whether we are under an off-by-default
-- package flag.
data TargetAnnotation a = TargetAnnotation
  { forall a. TargetAnnotation a -> a
taTarget :: a
  , -- The target we are building (lib, exe, etc.)
    forall a. TargetAnnotation a -> Bool
taPackageFlag :: Bool
    -- Whether we are under an off-by-default package flag.
  }
  deriving (Int -> TargetAnnotation a -> ShowS
[TargetAnnotation a] -> ShowS
TargetAnnotation a -> FilePath
(Int -> TargetAnnotation a -> ShowS)
-> (TargetAnnotation a -> FilePath)
-> ([TargetAnnotation a] -> ShowS)
-> Show (TargetAnnotation a)
forall a. Show a => Int -> TargetAnnotation a -> ShowS
forall a. Show a => [TargetAnnotation a] -> ShowS
forall a. Show a => TargetAnnotation a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TargetAnnotation a -> ShowS
showsPrec :: Int -> TargetAnnotation a -> ShowS
$cshow :: forall a. Show a => TargetAnnotation a -> FilePath
show :: TargetAnnotation a -> FilePath
$cshowList :: forall a. Show a => [TargetAnnotation a] -> ShowS
showList :: [TargetAnnotation a] -> ShowS
Show, TargetAnnotation a -> TargetAnnotation a -> Bool
(TargetAnnotation a -> TargetAnnotation a -> Bool)
-> (TargetAnnotation a -> TargetAnnotation a -> Bool)
-> Eq (TargetAnnotation a)
forall a. Eq a => TargetAnnotation a -> TargetAnnotation a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TargetAnnotation a -> TargetAnnotation a -> Bool
== :: TargetAnnotation a -> TargetAnnotation a -> Bool
$c/= :: forall a. Eq a => TargetAnnotation a -> TargetAnnotation a -> Bool
/= :: TargetAnnotation a -> TargetAnnotation a -> Bool
Eq, Eq (TargetAnnotation a)
Eq (TargetAnnotation a) =>
(TargetAnnotation a -> TargetAnnotation a -> Ordering)
-> (TargetAnnotation a -> TargetAnnotation a -> Bool)
-> (TargetAnnotation a -> TargetAnnotation a -> Bool)
-> (TargetAnnotation a -> TargetAnnotation a -> Bool)
-> (TargetAnnotation a -> TargetAnnotation a -> Bool)
-> (TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a)
-> (TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a)
-> Ord (TargetAnnotation a)
TargetAnnotation a -> TargetAnnotation a -> Bool
TargetAnnotation a -> TargetAnnotation a -> Ordering
TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (TargetAnnotation a)
forall a. Ord a => TargetAnnotation a -> TargetAnnotation a -> Bool
forall a.
Ord a =>
TargetAnnotation a -> TargetAnnotation a -> Ordering
forall a.
Ord a =>
TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
$ccompare :: forall a.
Ord a =>
TargetAnnotation a -> TargetAnnotation a -> Ordering
compare :: TargetAnnotation a -> TargetAnnotation a -> Ordering
$c< :: forall a. Ord a => TargetAnnotation a -> TargetAnnotation a -> Bool
< :: TargetAnnotation a -> TargetAnnotation a -> Bool
$c<= :: forall a. Ord a => TargetAnnotation a -> TargetAnnotation a -> Bool
<= :: TargetAnnotation a -> TargetAnnotation a -> Bool
$c> :: forall a. Ord a => TargetAnnotation a -> TargetAnnotation a -> Bool
> :: TargetAnnotation a -> TargetAnnotation a -> Bool
$c>= :: forall a. Ord a => TargetAnnotation a -> TargetAnnotation a -> Bool
>= :: TargetAnnotation a -> TargetAnnotation a -> Bool
$cmax :: forall a.
Ord a =>
TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
max :: TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
$cmin :: forall a.
Ord a =>
TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
min :: TargetAnnotation a -> TargetAnnotation a -> TargetAnnotation a
Ord)

-- | A collection os names, shipping tuples around is annoying.
data PNames = PNames
  { PNames -> PackageIdentifier
pnPackageId :: PackageIdentifier -- Package ID…
  -- … and a bunch of lib, exe, test, bench names.
  , PNames -> [UnqualComponentName]
pnSubLibs :: [UnqualComponentName]
  , PNames -> [UnqualComponentName]
pnExecs :: [UnqualComponentName]
  , PNames -> [UnqualComponentName]
pnTests :: [UnqualComponentName]
  , PNames -> [UnqualComponentName]
pnBenchs :: [UnqualComponentName]
  }

-- | Init names from a GPD.
initPNames :: GenericPackageDescription -> PNames
initPNames :: GenericPackageDescription -> PNames
initPNames GenericPackageDescription
gpd =
  PackageIdentifier
-> [UnqualComponentName]
-> [UnqualComponentName]
-> [UnqualComponentName]
-> [UnqualComponentName]
-> PNames
PNames
    (PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
gpd)
    (((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> UnqualComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst ([(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
 -> [UnqualComponentName])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
gpd)
    (((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> UnqualComponentName)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> UnqualComponentName
forall a b. (a, b) -> a
fst ([(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
 -> [UnqualComponentName])
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condExecutables GenericPackageDescription
gpd)
    (((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> UnqualComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> UnqualComponentName
forall a b. (a, b) -> a
fst ([(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
 -> [UnqualComponentName])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites GenericPackageDescription
gpd)
    (((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> UnqualComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> UnqualComponentName
forall a b. (a, b) -> a
fst ([(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
 -> [UnqualComponentName])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks GenericPackageDescription
gpd)

-- | Check monad, carrying a context, collecting 'PackageCheck's.
-- Using Set for writer (automatic sort) is useful for output stability
-- on different platforms.
-- It is nothing more than a monad stack with Reader+Writer.
-- `m` is the monad that could be used to do package/file checks.
newtype CheckM m a
  = CheckM
      ( Reader.ReaderT
          (CheckCtx m)
          ( Writer.WriterT
              (Set.Set PackageCheck)
              m
          )
          a
      )
  deriving ((forall a b. (a -> b) -> CheckM m a -> CheckM m b)
-> (forall a b. a -> CheckM m b -> CheckM m a)
-> Functor (CheckM m)
forall a b. a -> CheckM m b -> CheckM m a
forall a b. (a -> b) -> CheckM m a -> CheckM m b
forall (m :: * -> *) a b.
Functor m =>
a -> CheckM m b -> CheckM m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CheckM m a -> CheckM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CheckM m a -> CheckM m b
fmap :: forall a b. (a -> b) -> CheckM m a -> CheckM m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> CheckM m b -> CheckM m a
<$ :: forall a b. a -> CheckM m b -> CheckM m a
Functor, Functor (CheckM m)
Functor (CheckM m) =>
(forall a. a -> CheckM m a)
-> (forall a b. CheckM m (a -> b) -> CheckM m a -> CheckM m b)
-> (forall a b c.
    (a -> b -> c) -> CheckM m a -> CheckM m b -> CheckM m c)
-> (forall a b. CheckM m a -> CheckM m b -> CheckM m b)
-> (forall a b. CheckM m a -> CheckM m b -> CheckM m a)
-> Applicative (CheckM m)
forall a. a -> CheckM m a
forall a b. CheckM m a -> CheckM m b -> CheckM m a
forall a b. CheckM m a -> CheckM m b -> CheckM m b
forall a b. CheckM m (a -> b) -> CheckM m a -> CheckM m b
forall a b c.
(a -> b -> c) -> CheckM m a -> CheckM m b -> CheckM m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (CheckM m)
forall (m :: * -> *) a. Applicative m => a -> CheckM m a
forall (m :: * -> *) a b.
Applicative m =>
CheckM m a -> CheckM m b -> CheckM m a
forall (m :: * -> *) a b.
Applicative m =>
CheckM m a -> CheckM m b -> CheckM m b
forall (m :: * -> *) a b.
Applicative m =>
CheckM m (a -> b) -> CheckM m a -> CheckM m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> CheckM m a -> CheckM m b -> CheckM m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> CheckM m a
pure :: forall a. a -> CheckM m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
CheckM m (a -> b) -> CheckM m a -> CheckM m b
<*> :: forall a b. CheckM m (a -> b) -> CheckM m a -> CheckM m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> CheckM m a -> CheckM m b -> CheckM m c
liftA2 :: forall a b c.
(a -> b -> c) -> CheckM m a -> CheckM m b -> CheckM m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
CheckM m a -> CheckM m b -> CheckM m b
*> :: forall a b. CheckM m a -> CheckM m b -> CheckM m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
CheckM m a -> CheckM m b -> CheckM m a
<* :: forall a b. CheckM m a -> CheckM m b -> CheckM m a
Applicative, Applicative (CheckM m)
Applicative (CheckM m) =>
(forall a b. CheckM m a -> (a -> CheckM m b) -> CheckM m b)
-> (forall a b. CheckM m a -> CheckM m b -> CheckM m b)
-> (forall a. a -> CheckM m a)
-> Monad (CheckM m)
forall a. a -> CheckM m a
forall a b. CheckM m a -> CheckM m b -> CheckM m b
forall a b. CheckM m a -> (a -> CheckM m b) -> CheckM m b
forall (m :: * -> *). Monad m => Applicative (CheckM m)
forall (m :: * -> *) a. Monad m => a -> CheckM m a
forall (m :: * -> *) a b.
Monad m =>
CheckM m a -> CheckM m b -> CheckM m b
forall (m :: * -> *) a b.
Monad m =>
CheckM m a -> (a -> CheckM m b) -> CheckM m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CheckM m a -> (a -> CheckM m b) -> CheckM m b
>>= :: forall a b. CheckM m a -> (a -> CheckM m b) -> CheckM m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CheckM m a -> CheckM m b -> CheckM m b
>> :: forall a b. CheckM m a -> CheckM m b -> CheckM m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> CheckM m a
return :: forall a. a -> CheckM m a
Monad)

-- Not autoderiving MonadReader and MonadWriter gives us better
-- control on the interface of CheckM.

-- | Execute a CheckM monad, leaving `m [PackageCheck]` which can be
-- run in the appropriate `m` environment (IO, pure, …).
execCheckM :: Monad m => CheckM m () -> CheckCtx m -> m [PackageCheck]
execCheckM :: forall (m :: * -> *).
Monad m =>
CheckM m () -> CheckCtx m -> m [PackageCheck]
execCheckM (CheckM ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
rwm) CheckCtx m
ctx =
  let wm :: WriterT (Set PackageCheck) m ()
wm = ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
-> CheckCtx m -> WriterT (Set PackageCheck) m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
rwm CheckCtx m
ctx
      m :: m (Set PackageCheck)
m = WriterT (Set PackageCheck) m () -> m (Set PackageCheck)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
Writer.execWriterT WriterT (Set PackageCheck) m ()
wm
   in Set PackageCheck -> [PackageCheck]
forall a. Set a -> [a]
Set.toList (Set PackageCheck -> [PackageCheck])
-> m (Set PackageCheck) -> m [PackageCheck]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Set PackageCheck)
m

-- | As 'checkP' but always succeeding.
tellP :: Monad m => PackageCheck -> CheckM m ()
tellP :: forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP = Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP Bool
True

-- | Add a package warning withoutu performing any check.
tellCM :: Monad m => PackageCheck -> CheckM m ()
tellCM :: forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellCM PackageCheck
ck = do
  cf <- (CheckCtx m -> Bool) -> CheckM m Bool
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM CheckCtx m -> Bool
forall (m :: * -> *). CheckCtx m -> Bool
ccFlag
  unless
    (cf && canSkip ck)
    -- Do not push this message if the warning is not severe *and*
    -- we are under a non-default package flag.
    (CheckM . Writer.tell $ Set.singleton ck)
  where
    -- Check if we can skip this error if we are under a
    -- non-default user flag.
    canSkip :: PackageCheck -> Bool
    canSkip :: PackageCheck -> Bool
canSkip PackageCheck
wck = Bool -> Bool
not (PackageCheck -> Bool
isSevereLocal PackageCheck
wck) Bool -> Bool -> Bool
|| PackageCheck -> Bool
isErrAllowable PackageCheck
wck

    isSevereLocal :: PackageCheck -> Bool
    isSevereLocal :: PackageCheck -> Bool
isSevereLocal (PackageBuildImpossible CheckExplanation
_) = Bool
True
    isSevereLocal (PackageBuildWarning CheckExplanation
_) = Bool
True
    isSevereLocal (PackageDistSuspicious CheckExplanation
_) = Bool
False
    isSevereLocal (PackageDistSuspiciousWarn CheckExplanation
_) = Bool
False
    isSevereLocal (PackageDistInexcusable CheckExplanation
_) = Bool
True

    -- There are some errors which, even though severe, will
    -- be allowed by Hackage *if* under a non-default flag.
    isErrAllowable :: PackageCheck -> Bool
    isErrAllowable :: PackageCheck -> Bool
isErrAllowable PackageCheck
c = case PackageCheck -> CheckExplanation
extractCheckExplantion PackageCheck
c of
      (WErrorUnneeded FilePath
_) -> Bool
True
      (JUnneeded FilePath
_) -> Bool
True
      (FDeferTypeErrorsUnneeded FilePath
_) -> Bool
True
      (DynamicUnneeded FilePath
_) -> Bool
True
      (ProfilingUnneeded FilePath
_) -> Bool
True
      CheckExplanation
_ -> Bool
False

-- | Lift a monadic computation to CM.
liftCM :: Monad m => m a -> CheckM m a
liftCM :: forall (m :: * -> *) a. Monad m => m a -> CheckM m a
liftCM m a
ma = ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a -> CheckM m a
forall (m :: * -> *) a.
ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a -> CheckM m a
CheckM (ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
 -> CheckM m a)
-> (m a -> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a)
-> m a
-> CheckM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Set PackageCheck) m a
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (CheckCtx m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (WriterT (Set PackageCheck) m a
 -> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a)
-> (m a -> WriterT (Set PackageCheck) m a)
-> m a
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT (Set PackageCheck) m a
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (Set PackageCheck) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m a -> CheckM m a) -> m a -> CheckM m a
forall a b. (a -> b) -> a -> b
$ m a
ma

-- | Lift a monadic action via an interface. Missing interface, no action.
liftInt
  :: forall m i
   . Monad m
  => (CheckInterface m -> Maybe (i m))
  -- Check interface, may or may not exist. If it does not,
  -- the check simply will not be performed.
  -> (i m -> m [PackageCheck])
  -- The actual check to perform with the above-mentioned
  -- interface. Note the [] around `PackageCheck`, this is
  -- meant to perform/collect multiple checks.
  -> CheckM m ()
liftInt :: forall (m :: * -> *) (i :: (* -> *) -> *).
Monad m =>
(CheckInterface m -> Maybe (i m))
-> (i m -> m [PackageCheck]) -> CheckM m ()
liftInt CheckInterface m -> Maybe (i m)
acc i m -> m [PackageCheck]
f = do
  ops <- (CheckCtx m -> Maybe (i m)) -> CheckM m (Maybe (i m))
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM (CheckInterface m -> Maybe (i m)
acc (CheckInterface m -> Maybe (i m))
-> (CheckCtx m -> CheckInterface m) -> CheckCtx m -> Maybe (i m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckCtx m -> CheckInterface m
forall (m :: * -> *). CheckCtx m -> CheckInterface m
ccInterface)
  maybe (return ()) l ops
  where
    l :: i m -> CheckM m ()
    l :: i m -> CheckM m ()
l i m
wi = do
      cks <- m [PackageCheck] -> CheckM m [PackageCheck]
forall (m :: * -> *) a. Monad m => m a -> CheckM m a
liftCM (i m -> m [PackageCheck]
f i m
wi)
      mapM_ (check True) cks

-- | Most basic check function. You do not want to export this, rather export
-- “smart” functions (checkP, checkPkg) to enforce relevant properties.
check
  :: Monad m
  => Bool -- Is there something to warn about?
  -> PackageCheck -- Warn message.
  -> CheckM m ()
check :: forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
check Bool
True PackageCheck
ck = PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellCM PackageCheck
ck
check Bool
False PackageCheck
_ = () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Pure check not requiring IO or other interfaces.
checkP
  :: Monad m
  => Bool -- Is there something to warn about?
  -> PackageCheck -- Warn message.
  -> CheckM m ()
checkP :: forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP Bool
b PackageCheck
ck = do
  pb <- (CheckCtx m -> Bool) -> CheckM m Bool
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM (CheckInterface m -> Bool
forall (m :: * -> *). CheckInterface m -> Bool
ciPureChecks (CheckInterface m -> Bool)
-> (CheckCtx m -> CheckInterface m) -> CheckCtx m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckCtx m -> CheckInterface m
forall (m :: * -> *). CheckCtx m -> CheckInterface m
ccInterface)
  when pb (check b ck)

-- Check with 'CheckPackageContentOps' operations (i.e. package file checks).
--
checkPkg
  :: forall m
   . Monad m
  => (CheckPackageContentOps m -> m Bool)
  -- Actual check to perform with CPC interface
  -> PackageCheck
  -- Warn message.
  -> CheckM m ()
checkPkg :: forall (m :: * -> *).
Monad m =>
(CheckPackageContentOps m -> m Bool) -> PackageCheck -> CheckM m ()
checkPkg CheckPackageContentOps m -> m Bool
f PackageCheck
ck = (CheckInterface m -> Maybe (CheckPackageContentOps m))
-> (CheckPackageContentOps m -> m Bool)
-> PackageCheck
-> CheckM m ()
forall (m :: * -> *) (i :: (* -> *) -> *).
Monad m =>
(CheckInterface m -> Maybe (i m))
-> (i m -> m Bool) -> PackageCheck -> CheckM m ()
checkInt CheckInterface m -> Maybe (CheckPackageContentOps m)
forall (m :: * -> *).
CheckInterface m -> Maybe (CheckPackageContentOps m)
ciPackageOps CheckPackageContentOps m -> m Bool
f PackageCheck
ck

-- | Generalised version for checks that need an interface. We pass a Reader
-- accessor to such interface ‘i’, a check function.
checkIntDep
  :: forall m i
   . Monad m
  => (CheckInterface m -> Maybe (i m))
  -- Check interface, may or may not exist. If it does not,
  -- the check simply will not be performed.
  -> (i m -> m (Maybe PackageCheck))
  -- The actual check to perform (single check).
  -> CheckM m ()
checkIntDep :: forall (m :: * -> *) (i :: (* -> *) -> *).
Monad m =>
(CheckInterface m -> Maybe (i m))
-> (i m -> m (Maybe PackageCheck)) -> CheckM m ()
checkIntDep CheckInterface m -> Maybe (i m)
acc i m -> m (Maybe PackageCheck)
mck = do
  po <- (CheckCtx m -> Maybe (i m)) -> CheckM m (Maybe (i m))
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM (CheckInterface m -> Maybe (i m)
acc (CheckInterface m -> Maybe (i m))
-> (CheckCtx m -> CheckInterface m) -> CheckCtx m -> Maybe (i m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckCtx m -> CheckInterface m
forall (m :: * -> *). CheckCtx m -> CheckInterface m
ccInterface)
  maybe (return ()) (lc . mck) po
  where
    lc :: Monad m => m (Maybe PackageCheck) -> CheckM m ()
    lc :: Monad m => m (Maybe PackageCheck) -> CheckM m ()
lc m (Maybe PackageCheck)
wmck = do
      b <- m (Maybe PackageCheck) -> CheckM m (Maybe PackageCheck)
forall (m :: * -> *) a. Monad m => m a -> CheckM m a
liftCM m (Maybe PackageCheck)
wmck
      maybe (return ()) (check True) b

-- | As 'checkIntDep', but 'PackageCheck' does not depend on the monadic
-- computation.
checkInt
  :: forall m i
   . Monad m
  => (CheckInterface m -> Maybe (i m))
  -- Where to get the interface (if available).
  -> (i m -> m Bool)
  -- Condition to check
  -> PackageCheck
  -- Warning message to add (does not depend on `m`).
  -> CheckM m ()
checkInt :: forall (m :: * -> *) (i :: (* -> *) -> *).
Monad m =>
(CheckInterface m -> Maybe (i m))
-> (i m -> m Bool) -> PackageCheck -> CheckM m ()
checkInt CheckInterface m -> Maybe (i m)
acc i m -> m Bool
f PackageCheck
ck =
  (CheckInterface m -> Maybe (i m))
-> (i m -> m (Maybe PackageCheck)) -> CheckM m ()
forall (m :: * -> *) (i :: (* -> *) -> *).
Monad m =>
(CheckInterface m -> Maybe (i m))
-> (i m -> m (Maybe PackageCheck)) -> CheckM m ()
checkIntDep
    CheckInterface m -> Maybe (i m)
acc
    ( \i m
ops -> do
        b <- i m -> m Bool
f i m
ops
        if b
          then return $ Just ck
          else return Nothing
    )

-- | `local` (from Control.Monad.Reader) for CheckM.
localCM :: Monad m => (CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m ()
localCM :: forall (m :: * -> *).
Monad m =>
(CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m ()
localCM CheckCtx m -> CheckCtx m
cf (CheckM ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
im) = ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
-> CheckM m ()
forall (m :: * -> *) a.
ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a -> CheckM m a
CheckM (ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
 -> CheckM m ())
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
-> CheckM m ()
forall a b. (a -> b) -> a -> b
$ (CheckCtx m -> CheckCtx m)
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
forall a.
(CheckCtx m -> CheckCtx m)
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
Reader.local CheckCtx m -> CheckCtx m
cf ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) ()
im

-- | `ask` (from Control.Monad.Reader) for CheckM.
asksCM :: Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM :: forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM CheckCtx m -> a
f = ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a -> CheckM m a
forall (m :: * -> *) a.
ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a -> CheckM m a
CheckM (ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
 -> CheckM m a)
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
-> CheckM m a
forall a b. (a -> b) -> a -> b
$ (CheckCtx m -> a)
-> ReaderT (CheckCtx m) (WriterT (Set PackageCheck) m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks CheckCtx m -> a
f

-- As checkP, but with an additional condition: the check will be performed
-- only if our spec version is < `vc`.
checkSpecVer
  :: Monad m
  => CabalSpecVersion -- Perform this check only if our
  -- spec version is < than this.
  -> Bool -- Check condition.
  -> PackageCheck -- Check message.
  -> CheckM m ()
checkSpecVer :: forall (m :: * -> *).
Monad m =>
CabalSpecVersion -> Bool -> PackageCheck -> CheckM m ()
checkSpecVer CabalSpecVersion
vc Bool
cond PackageCheck
c = do
  vp <- (CheckCtx m -> CabalSpecVersion) -> CheckM m CabalSpecVersion
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM CheckCtx m -> CabalSpecVersion
forall (m :: * -> *). CheckCtx m -> CabalSpecVersion
ccSpecVersion
  unless (vp >= vc) (checkP cond c)