|
| 1 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 2 | +{-# LANGUAGE LambdaCase #-} |
| 3 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 4 | + |
| 5 | +-- | The core analyses of the tool. |
| 6 | + |
| 7 | +module Cabal.Lint ( |
| 8 | + -- * |
| 9 | + LintConfig (..), |
| 10 | + Summary, |
| 11 | + ResultP (ResultP), |
| 12 | + lintPackageDescription, |
| 13 | + lintProject, |
| 14 | + ) where |
| 15 | + |
| 16 | +import Data.Maybe (maybeToList) |
| 17 | +import Data.Map (Map) |
| 18 | +import qualified Data.Map as Map |
| 19 | +import Data.Set (Set) |
| 20 | +import qualified Data.Set as Set |
| 21 | +import qualified Distribution.Compat.NonEmptySet as NES |
| 22 | +import Cabal.Lint.Ids |
| 23 | +import Cabal.Lint.Ord |
| 24 | +import Cabal.Lint.Summygroup |
| 25 | +import Cabal.Lint.UX.Output |
| 26 | + |
| 27 | +import qualified Distribution.Compiler as C |
| 28 | +import qualified Distribution.Package as C |
| 29 | +import qualified Distribution.Types.Benchmark as C |
| 30 | +import qualified Distribution.Types.BuildInfo as C |
| 31 | +import qualified Distribution.Types.ComponentName as C |
| 32 | +import qualified Distribution.Types.CondTree as C |
| 33 | +import qualified Distribution.Types.Executable as C |
| 34 | +import qualified Distribution.Types.GenericPackageDescription as C |
| 35 | +import qualified Distribution.Types.Library as C |
| 36 | +import qualified Distribution.Types.LibraryName as C |
| 37 | +import qualified Distribution.Types.TestSuite as C |
| 38 | + |
| 39 | +----- |
| 40 | + |
| 41 | +-- | A multiplicity |
| 42 | +-- |
| 43 | +-- Example use: if a component constrains a dependency more than once, the |
| 44 | +-- linter emits a 'RepeatDeps' for that component. |
| 45 | +-- |
| 46 | +-- INVARIANT: The values are always >0. |
| 47 | +newtype Multiplicity = Multiplicity Int |
| 48 | + deriving (Eq, Ord) |
| 49 | + |
| 50 | +oneMultiplicity :: Multiplicity |
| 51 | +oneMultiplicity = Multiplicity 1 |
| 52 | + |
| 53 | +instance Semigroup Multiplicity where Multiplicity l <> Multiplicity r = Multiplicity $ l + r |
| 54 | +instance Summygroup Multiplicity where Multiplicity l <+> Multiplicity r = Multiplicity $ max l r |
| 55 | + |
| 56 | +----- |
| 57 | + |
| 58 | +newtype PerDep a = PerDep (Map DepId a) |
| 59 | + deriving (Eq, Ord) |
| 60 | + |
| 61 | +instance Semigroup a => Monoid (PerDep a) where mempty = PerDep Map.empty |
| 62 | +instance Semigroup a => Semigroup (PerDep a) where PerDep l <> PerDep r = PerDep $ Map.unionWith (<>) l r |
| 63 | + |
| 64 | +-- | TODO in the future, we might sometimes want 'Map.intersectionWith' here, but for now we always want 'Map.unionWith' |
| 65 | +instance Summygroup a => Summygroup (PerDep a) where PerDep l <+> PerDep r = PerDep $ Map.unionWith (<+>) l r |
| 66 | + |
| 67 | +----- |
| 68 | + |
| 69 | +data LintConfig puid = LintConfig { |
| 70 | + -- | The package being linted |
| 71 | + thisPackage :: PrjPkgId puid |
| 72 | + , |
| 73 | + requiredOptions :: Set String |
| 74 | + } |
| 75 | + |
| 76 | +----- |
| 77 | + |
| 78 | +-- | Check for 'ProjectMessage' |
| 79 | +lintProject :: Ord puid => Summary puid -> Set (ProjectMessage puid) |
| 80 | +lintProject (Summary (PerDep m1, Occurrences m2)) = |
| 81 | + mempty |
| 82 | + <> mconcat |
| 83 | + [ Set.singleton $ case Map.minViewWithKey m of |
| 84 | + -- there's just this one |
| 85 | + Just ((vrange, _), rest) | Map.null rest -> ConsistentVersionRange dep vrange |
| 86 | + _ -> InconsistentVersionRanges dep (Occurrences m) |
| 87 | + | (dep, Occurrences m) <- Map.toList m1 |
| 88 | + ] |
| 89 | + <> ( Set.singleton $ case Map.minViewWithKey m2 of |
| 90 | + Just ((mbLang, _), rest) | Map.null rest -> ConsistentDefaultLanguage mbLang |
| 91 | + _ -> InconsistentDefaultLanguages (Occurrences m2) |
| 92 | + ) |
| 93 | + |
| 94 | +----- |
| 95 | + |
| 96 | +newtype Summary puid = |
| 97 | + Summary |
| 98 | + ( PerDep (Occurrences MyVersionRange puid) |
| 99 | + , Occurrences (Maybe MyLanguage) puid |
| 100 | + ) |
| 101 | + deriving (Monoid, Semigroup, Summygroup) |
| 102 | + |
| 103 | +-- | Result of analyzing a component within a package |
| 104 | +data ResultC puid = ResultC (Summary puid) (Set ComponentError) |
| 105 | + |
| 106 | +instance Ord puid => Monoid (ResultC puid) where mempty = ResultC mempty mempty |
| 107 | +instance Ord puid => Semigroup (ResultC puid) where ResultC depsL errsL <> ResultC depsR errsR = ResultC (depsL <> depsR) (errsL `Set.union` errsR) |
| 108 | + |
| 109 | +-- | Result of analyzing a package |
| 110 | +data ResultP puid = |
| 111 | + ResultP |
| 112 | + (Summary puid) |
| 113 | + (Set PackageError) |
| 114 | + (Map C.ComponentName (NES.NonEmptySet ComponentError)) |
| 115 | + |
| 116 | +instance Ord puid => Monoid (ResultP puid) where mempty = ResultP mempty mempty mempty |
| 117 | +instance Ord puid => Semigroup (ResultP puid) where ResultP depsL errsL cerrsL <> ResultP depsR errsR cerrsR = ResultP (depsL <> depsR) (Set.union errsL errsR) (Map.unionWith (<>) cerrsL cerrsR) |
| 118 | + |
| 119 | +-- | Check for 'PackageError's and 'ComponentError's and also collect the |
| 120 | +-- summary info necessary for 'lintProject' |
| 121 | +lintPackageDescription :: forall puid. Ord puid => LintConfig puid -> C.GenericPackageDescription -> ResultP puid |
| 122 | +lintPackageDescription cfg gpd = |
| 123 | + ResultP mempty (NonEmptyForeignLibraries `ifJust` mkNES (Set.fromList (map fst forLibs))) mempty |
| 124 | + <> foldMap (\ x -> go (C.CLibName C.LMainLibName ) (fmap C.libBuildInfo x)) mbLib |
| 125 | + <> foldMap (\(cn, x) -> go (C.CLibName (C.LSubLibName cn)) (fmap C.libBuildInfo x)) subLibs |
| 126 | + <> foldMap (\(cn, x) -> go (C.CExeName cn ) (fmap C.buildInfo x)) exes |
| 127 | + <> foldMap (\(cn, x) -> go (C.CTestName cn ) (fmap C.testBuildInfo x)) tests |
| 128 | + <> foldMap (\(cn, x) -> go (C.CBenchName cn ) (fmap C.benchmarkBuildInfo x)) benchs |
| 129 | + where |
| 130 | + LintConfig _ _dummy_cfg = cfg |
| 131 | + LintConfig { |
| 132 | + thisPackage = puid |
| 133 | + , |
| 134 | + requiredOptions = options0 |
| 135 | + } = cfg |
| 136 | + |
| 137 | + C.GenericPackageDescription _ _ _ _ _ _ _ _ _dummy_gpd = gpd |
| 138 | + C.GenericPackageDescription { |
| 139 | + C.packageDescription = _ |
| 140 | + , |
| 141 | + C.gpdScannedVersion = _ |
| 142 | + , |
| 143 | + C.condLibrary = mbLib |
| 144 | + , |
| 145 | + C.condSubLibraries = subLibs |
| 146 | + , |
| 147 | + C.condForeignLibs = forLibs |
| 148 | + , |
| 149 | + C.condExecutables = exes |
| 150 | + , |
| 151 | + C.condTestSuites = tests |
| 152 | + , |
| 153 | + C.condBenchmarks = benchs |
| 154 | + } = gpd |
| 155 | + |
| 156 | + go :: C.ComponentName -> C.CondTree v c C.BuildInfo -> ResultP puid |
| 157 | + go cname tree = |
| 158 | + let ResultC deps cerrs = |
| 159 | + (goDepends <> goGhcOptions <> goLanguage) |
| 160 | + (CompId puid cname) |
| 161 | + tree |
| 162 | + in |
| 163 | + ResultP deps mempty |
| 164 | + $ Map.fromList [ (cname, x) | x <- maybeToList (mkNES cerrs) ] |
| 165 | + |
| 166 | + getDepends :: CompId puid -> C.BuildInfo -> PerDep (Occurrences MyVersionRange puid, Multiplicity) |
| 167 | + getDepends me bi = |
| 168 | + PerDep |
| 169 | + $ Map.fromListWith (<>) |
| 170 | + $ [ ( DepId pname libname |
| 171 | + , ( oneOccurrence (MyVersionRange vrange) me |
| 172 | + , oneMultiplicity |
| 173 | + ) |
| 174 | + ) |
| 175 | + | C.Dependency pname vrange libnames <- C.targetBuildDepends bi |
| 176 | + , libname <- NES.toList libnames |
| 177 | + ] |
| 178 | + |
| 179 | + goDepends :: CompId puid -> C.CondTree v c C.BuildInfo -> ResultC puid |
| 180 | + goDepends me tree = |
| 181 | + let PerDep m = goTree $ fmap (getDepends me) tree |
| 182 | + repeatedDeps = Map.keysSet $ Map.filter ((> oneMultiplicity) . snd) m |
| 183 | + in |
| 184 | + ResultC |
| 185 | + (Summary (PerDep (Map.map fst m), mempty)) |
| 186 | + (RepeatDeps `ifJust` mkNES repeatedDeps) |
| 187 | + |
| 188 | + getGhcOptions :: C.BuildInfo -> Always String |
| 189 | + getGhcOptions bi = |
| 190 | + mconcat |
| 191 | + $ [ oneAlways opt |
| 192 | + | (C.GHC, opts) <- C.perCompilerFlavorToList (C.options bi) |
| 193 | + , opt <- opts |
| 194 | + ] |
| 195 | + |
| 196 | + goGhcOptions :: CompId puid -> C.CondTree v c C.BuildInfo -> ResultC puid |
| 197 | + goGhcOptions _me tree = |
| 198 | + let Always counts = goTree $ fmap getGhcOptions tree |
| 199 | + in |
| 200 | + ResultC mempty |
| 201 | + $ mempty |
| 202 | + <> (RepeatOptions `ifJust` mkNES (Map.keysSet $ Map.filter (> 1) counts)) |
| 203 | + <> (MissingOptions `ifJust` mkNES (Set.difference options0 (Map.keysSet counts))) |
| 204 | + |
| 205 | + getLanguage :: CompId puid -> C.BuildInfo -> (Occurrences (Maybe MyLanguage) puid, Sometimes ComponentError) |
| 206 | + getLanguage me bi = |
| 207 | + ( oneOccurrence (MyLanguage <$> C.defaultLanguage bi) me |
| 208 | + , mconcat |
| 209 | + $ [ oneSometimes $ NonEmptyDefaultExtensions exts' |
| 210 | + | exts' <- maybeToList $ mkNES $ Set.fromList $ C.defaultExtensions bi |
| 211 | + ] |
| 212 | + ) |
| 213 | + |
| 214 | + goLanguage :: CompId puid -> C.CondTree v c C.BuildInfo -> ResultC puid |
| 215 | + goLanguage me tree = |
| 216 | + let (defaultLanguages, Sometimes errs) = |
| 217 | + goTree $ fmap (getLanguage me) tree |
| 218 | + in |
| 219 | + ResultC (Summary (mempty, defaultLanguages)) (Map.keysSet errs) |
| 220 | + |
| 221 | +----- |
| 222 | + |
| 223 | +goTree :: (Monoid m, Summygroup m) => C.CondTree v c m -> m |
| 224 | +goTree tree = |
| 225 | + let C.CondNode _ _ _dummy = tree |
| 226 | + C.CondNode { |
| 227 | + C.condTreeData = x |
| 228 | + , |
| 229 | + C.condTreeConstraints = _ |
| 230 | + , |
| 231 | + C.condTreeComponents = subtrees |
| 232 | + } = tree |
| 233 | + in |
| 234 | + foldr (<>) x (map goBranch subtrees) |
| 235 | + |
| 236 | +goBranch :: (Monoid m, Summygroup m) => C.CondBranch v c m -> m |
| 237 | +goBranch branch = |
| 238 | + let C.CondBranch _ _ _dummy = branch |
| 239 | + C.CondBranch { |
| 240 | + C.condBranchCondition = _ |
| 241 | + , |
| 242 | + C.condBranchIfTrue = tree |
| 243 | + , |
| 244 | + C.condBranchIfFalse = mbTree |
| 245 | + } = branch |
| 246 | + in |
| 247 | + goTree tree <+> maybe mempty goTree mbTree |
| 248 | + |
| 249 | +----- |
| 250 | + |
| 251 | +ifJust :: (a -> b) -> Maybe a -> Set b |
| 252 | +ifJust mkErr mb = maybe Set.empty (Set.singleton . mkErr) mb |
| 253 | + |
| 254 | +mkNES :: Ord a => Set a -> Maybe (NES.NonEmptySet a) |
| 255 | +mkNES xs = case Set.minView xs of |
| 256 | + Nothing -> Nothing |
| 257 | + Just (x, xs') -> Just $ foldr NES.insert (NES.singleton x) xs' |
0 commit comments