{-# 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 :: TargetAnnota