@@ -0,0 +1,75 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
6+-- | Confirm that a build plan has a consistent set of dependencies.
7+module Stackage2.CheckBuildPlan
11+import Stackage2.Prelude
12+import Stackage2.BuildPlan
13+import Stackage2.PackageDescription
14+import Control.Monad.Writer.Strict (execWriter, Writer, tell)
15+import Distribution.Version (intersectVersionRanges, withinRange)
17+checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
18+checkBuildPlan BuildPlan {..}
19+ | null errs' = return ()
20+ | otherwise = throwM errs
22+ allPackages = bpCore ++ map pbVersion bpExtra
23+ errs@(BadBuildPlan errs') =
24+ execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
26+checkDeps :: Map PackageName Version
27+ -> (PackageName, PackageBuild FlatComponent)
28+ -> Writer BadBuildPlan ()
29+checkDeps allPackages (user, pb) =
30+ mapM_ go $ mapToList $ fcDeps $ pbDesc pb
33+ case lookup dep allPackages of
34+ Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
36+ | version `withinRange` range -> return ()
37+ | otherwise -> tell $ BadBuildPlan $ singletonMap
41+ errMap = singletonMap user range
43+newtype BadBuildPlan = BadBuildPlan (Map (PackageName, Maybe Version) (Map PackageName VersionRange)) -- FIXME add maintainer and Github ping info
45+instance Exception BadBuildPlan
46+instance Show BadBuildPlan where
47+ show (BadBuildPlan errs) =
48+ concatMap go $ mapToList errs
50+ go ((dep, mdepVer), users) = unlines
51+ $ showDepVer dep mdepVer
52+ : map showUser (mapToList users)
54+ showDepVer :: PackageName -> Maybe Version -> String
55+ showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
56+ showDepVer dep (Just version) = concat
63+ showUser :: (PackageName, VersionRange) -> String
64+ showUser (user, range) = concat
72+instance Monoid BadBuildPlan where
73+ mempty = BadBuildPlan mempty
74+ mappend (BadBuildPlan x) (BadBuildPlan y) =
75+ BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y