@@ -1,3 +1,4 @@
1+{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE GeneralizedNewtypeDeriving #-}
34{-# LANGUAGE NoImplicitPrelude #-}
@@ -11,30 +12,34 @@ module Stackage.CheckBuildPlan
1112 ) where
1213
1314import Control.Monad.Writer.Strict (Writer, execWriter, tell)
14−import qualified Data.Text as T
15+import qualified Data.Map.Strict as M
16+import qualified Data.Text as T
1517import Stackage.BuildConstraints
1618import Stackage.BuildPlan
1719import Stackage.PackageDescription
1820import Stackage.Prelude
1921
20−-- FIXME check cycles in dependencies, only looking at libraries and
21−-- executables
22−
2322-- | Check the build plan for missing deps, wrong versions, etc.
24−checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
23+checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()
2524checkBuildPlan BuildPlan {..}
2625 | null errs' = return ()
2726 | otherwise = throwM errs
2827 where
29− allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
28+ allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++
29+ map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages
3030 errs@(BadBuildPlan errs') =
3131 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
32+ -- Only looking at libraries and executables, benchmarks and tests
33+ -- are allowed to create cycles (e.g. test-framework depends on
34+ -- text, which uses test-framework in its test-suite).
35+ libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs
3236
3337-- | For a given package name and plan, check that its dependencies are:
3438--
3539-- 1. Existent (existing in the provided package map)
3640-- 2. Within version range
37−checkDeps :: Map PackageName Version
41+-- 3. Check for dependency cycles.
42+checkDeps :: Map PackageName (Version,[PackageName])
3843 -> (PackageName, PackagePlan)
3944 -> Writer BadBuildPlan ()
4045checkDeps allPackages (user, pb) =
@@ -43,8 +48,16 @@ checkDeps allPackages (user, pb) =
4348 go (dep, diRange -> range) =
4449 case lookup dep allPackages of
4550 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
46− Just version
47− | version `withinRange` range -> return ()
51+ Just (version,deps)
52+ | version `withinRange` range ->
53+ occursCheck allPackages
54+ (\d v ->
55+ tell $ BadBuildPlan $ singletonMap
56+ (d,v)
57+ errMap)
58+ dep
59+ deps
60+ []
4861 | otherwise -> tell $ BadBuildPlan $ singletonMap
4962 (dep, Just version)
5063 errMap
@@ -57,6 +70,38 @@ checkDeps allPackages (user, pb) =
5770 , puGithubPings = ppGithubPings pb
5871 }
5972
73+-- | Check whether the package(s) occurs within its own dependency
74+-- tree.
75+occursCheck
76+ :: Monad m
77+ => Map PackageName (Version,[PackageName])
78+ -- ^ All packages.
79+ -> (PackageName -> Maybe Version -> m ())
80+ -- ^ Report an erroneous package.
81+ -> PackageName
82+ -- ^ Starting package to check for cycles in.
83+ -> [PackageName]
84+ -- ^ Dependencies of the package.
85+ -> [PackageName]
86+ -- ^ Previously seen packages up the dependency tree.
87+ -> m ()
88+occursCheck allPackages reportError =
89+ go
90+ where
91+ go pkg deps seen =
92+ case find (flip elem seen) deps of
93+ Just cyclic ->
94+ reportError cyclic $
95+ fmap fst (lookup cyclic allPackages)
96+ Nothing ->
97+ forM_ deps $
98+ \pkg' ->
99+ case lookup pkg' allPackages of
100+ Just (_v,deps')
101+ | pkg' /= pkg -> go pkg' deps' seen'
102+ _ -> return ()
103+ where seen' = pkg : seen
104+
60105data PkgUser = PkgUser
61106 { puName :: PackageName
62107 , puVersion :: Version