git.iko.soy/stackage
on c05cacf help sign in
stackage/Stackage2/CheckBuildPlan.hs
75 lines 2.7 kB history raw
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.
7module Stackage2.CheckBuildPlan
8 ( checkBuildPlan
9 ) where
11import Stackage2.Prelude
12import Stackage2.BuildPlan
13import Stackage2.PackageDescription
14import Control.Monad.Writer.Strict (execWriter, Writer, tell)
15import Distribution.Version (intersectVersionRanges, withinRange)
17checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
18checkBuildPlan 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
26checkDeps :: Map PackageName Version
27 -> (PackageName, PackageBuild FlatComponent)
28 -> Writer BadBuildPlan ()
29checkDeps 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
43newtype BadBuildPlan = BadBuildPlan (Map (PackageName, Maybe Version) (Map PackageName VersionRange)) -- FIXME add maintainer and Github ping info
44 deriving Typeable
45instance Exception BadBuildPlan
46instance 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)
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 ]
63 showUser :: (PackageName, VersionRange) -> String
64 showUser (user, range) = concat
65 [ "- "
66 , display user
67 , " ("
68 , display range
69 , ")"
70 ]
72instance Monoid BadBuildPlan where
73 mempty = BadBuildPlan mempty
74 mappend (BadBuildPlan x) (BadBuildPlan y) =
75 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y