git.iko.soy/stackage
on ff2dd38 help sign in
stackage/Stackage2/CheckBuildPlan.hs
102 lines 3.3 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)
16checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
17checkBuildPlan BuildPlan {..}
18 | null errs' = return ()
19 | otherwise = throwM errs
20 where
21 allPackages = bpCore ++ map pbVersion bpExtra
22 errs@(BadBuildPlan errs') =
23 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
25checkDeps :: Map PackageName Version
26 -> (PackageName, PackageBuild FlatComponent)
27 -> Writer BadBuildPlan ()
28checkDeps allPackages (user, pb) =
29 mapM_ go $ mapToList $ fcDeps $ pbDesc pb
30 where
31 go (dep, range) =
32 case lookup dep allPackages of
33 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
34 Just version
35 | version `withinRange` range -> return ()
36 | otherwise -> tell $ BadBuildPlan $ singletonMap
37 (dep, Just version)
38 errMap
39 where
40 errMap = singletonMap pu range
41 pu = PkgUser
42 { puName = user
43 , puVersion = pbVersion pb
44 , puMaintainer = pbMaintainer pb
45 , puGithubPings = pbGithubPings pb
46 }
48data PkgUser = PkgUser
49 { puName :: PackageName
50 , puVersion :: Version
51 , puMaintainer :: Maybe Maintainer
52 , puGithubPings :: Set Text
53 }
54 deriving (Eq, Ord)
56pkgUserShow1 :: PkgUser -> String
57pkgUserShow1 PkgUser {..} = concat
58 [ display puName
59 , "-"
60 , display puVersion
61 ]
63pkgUserShow2 :: PkgUser -> String
64pkgUserShow2 PkgUser {..} = unwords
65 $ (maybe "No maintainer" (unpack . unMaintainer) puMaintainer ++ ".")
66 : map (("@" ++) . unpack) (setToList puGithubPings)
68newtype BadBuildPlan =
69 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
70 deriving Typeable
71instance Exception BadBuildPlan
72instance Show BadBuildPlan where
73 show (BadBuildPlan errs) =
74 concatMap go $ mapToList errs
75 where
76 go ((dep, mdepVer), users) = unlines
77 $ showDepVer dep mdepVer
78 : map showUser (mapToList users)
80 showDepVer :: PackageName -> Maybe Version -> String
81 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
82 showDepVer dep (Just version) = concat
83 [ display dep
84 , "-"
85 , display version
86 , " depended on by:"
87 ]
89 showUser :: (PkgUser, VersionRange) -> String
90 showUser (pu, range) = concat
91 [ "- "
92 , pkgUserShow1 pu
93 , " ("
94 , display range
95 , "). "
96 , pkgUserShow2 pu
97 ]
99instance Monoid BadBuildPlan where
100 mempty = BadBuildPlan mempty
101 mappend (BadBuildPlan x) (BadBuildPlan y) =
102 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y