git.iko.soy/stackage
on e88ec3f help sign in
stackage/Stackage2/CheckBuildPlan.hs
103 lines 3.4 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NoImplicitPrelude #-}
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 Control.Monad.Writer.Strict (Writer, execWriter, tell)
12import Stackage2.BuildConstraints
13import Stackage2.BuildPlan
14import Stackage2.PackageDescription
15import Stackage2.Prelude
17checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
18checkBuildPlan BuildPlan {..}
19 | null errs' = return ()
20 | otherwise = throwM errs
21 where
22 allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
23 errs@(BadBuildPlan errs') =
24 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
26checkDeps :: Map PackageName Version
27 -> (PackageName, PackagePlan)
28 -> Writer BadBuildPlan ()
29checkDeps allPackages (user, pb) =
30 mapM_ go $ mapToList $ sdPackages $ ppDesc 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 pu range
42 pu = PkgUser
43 { puName = user
44 , puVersion = ppVersion pb
45 , puMaintainer = pcMaintainer $ ppConstraints pb
46 , puGithubPings = ppGithubPings pb
47 }
49data PkgUser = PkgUser
50 { puName :: PackageName
51 , puVersion :: Version
52 , puMaintainer :: Maybe Maintainer
53 , puGithubPings :: Set Text
54 }
55 deriving (Eq, Ord)
57pkgUserShow1 :: PkgUser -> Text
58pkgUserShow1 PkgUser {..} = concat
59 [ display puName
60 , "-"
61 , display puVersion
62 ]
64pkgUserShow2 :: PkgUser -> Text
65pkgUserShow2 PkgUser {..} = unwords
66 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
67 : map (cons '@') (setToList puGithubPings)
69newtype BadBuildPlan =
70 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
71 deriving Typeable
72instance Exception BadBuildPlan
73instance Show BadBuildPlan where
74 show (BadBuildPlan errs) =
75 unpack $ concatMap go $ mapToList errs
76 where
77 go ((dep, mdepVer), users) = unlines
78 $ showDepVer dep mdepVer
79 : map showUser (mapToList users)
81 showDepVer :: PackageName -> Maybe Version -> Text
82 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
83 showDepVer dep (Just version) = concat
84 [ display dep
85 , "-"
86 , display version
87 , " depended on by:"
88 ]
90 showUser :: (PkgUser, VersionRange) -> Text
91 showUser (pu, range) = concat
92 [ "- "
93 , pkgUserShow1 pu
94 , " ("
95 , display range
96 , "). "
97 , pkgUserShow2 pu
98 ]
100instance Monoid BadBuildPlan where
101 mempty = BadBuildPlan mempty
102 mappend (BadBuildPlan x) (BadBuildPlan y) =
103 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y