@@ -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
8+ ( checkBuildPlan
9+ ) where
10+
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)
16+
17+checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
18+checkBuildPlan BuildPlan {..}
19+ | null errs' = return ()
20+ | otherwise = throwM errs
21+ where
22+ allPackages = bpCore ++ map pbVersion bpExtra
23+ errs@(BadBuildPlan errs') =
24+ execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
25+
26+checkDeps :: Map PackageName Version
27+ -> (PackageName, PackageBuild FlatComponent)
28+ -> Writer BadBuildPlan ()
29+checkDeps allPackages (user, pb) =
30+ mapM_ go $ mapToList $ fcDeps $ pbDesc pb
31+ where
32+ go (dep, range) =
33+ case lookup dep allPackages of
34+ Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
35+ Just version
36+ | version `withinRange` range -> return ()
37+ | otherwise -> tell $ BadBuildPlan $ singletonMap
38+ (dep, Just version)
39+ errMap
40+ where
41+ errMap = singletonMap user range
42+
43+newtype BadBuildPlan = BadBuildPlan (Map (PackageName, Maybe Version) (Map PackageName VersionRange)) -- FIXME add maintainer and Github ping info
44+ deriving Typeable
45+instance Exception BadBuildPlan
46+instance Show BadBuildPlan where
47+ show (BadBuildPlan errs) =
48+ concatMap go $ mapToList errs
49+ where
50+ go ((dep, mdepVer), users) = unlines
51+ $ showDepVer dep mdepVer
52+ : map showUser (mapToList users)
53+
54+ showDepVer :: PackageName -> Maybe Version -> String
55+ showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
56+ showDepVer dep (Just version) = concat
57+ [ display dep
58+ , "-"
59+ , display version
60+ , " depended on by:"
61+ ]
62+
63+ showUser :: (PackageName, VersionRange) -> String
64+ showUser (user, range) = concat
65+ [ "- "
66+ , display user
67+ , " ("
68+ , display range
69+ , ")"
70+ ]
71+
72+instance Monoid BadBuildPlan where
73+ mempty = BadBuildPlan mempty
74+ mappend (BadBuildPlan x) (BadBuildPlan y) =
75+ BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y