git.iko.soy/stackage
on 48457d1 help sign in
stackage/Stackage2/CheckBuildPlan.hs
107 lines 3.5 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ViewPatterns #-}
7-- | Confirm that a build plan has a consistent set of dependencies.
8module Stackage2.CheckBuildPlan
9 ( checkBuildPlan
10 ) where
12import Control.Monad.Writer.Strict (Writer, execWriter, tell)
13import Stackage2.BuildConstraints
14import Stackage2.BuildPlan
15import Stackage2.PackageDescription
16import Stackage2.Prelude
18-- FIXME check cycles in dependencies, only looking at libraries and
19-- executables
21checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
22checkBuildPlan BuildPlan {..}
23 | null errs' = return ()
24 | otherwise = throwM errs
25 where
26 allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
27 errs@(BadBuildPlan errs') =
28 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
30checkDeps :: Map PackageName Version
31 -> (PackageName, PackagePlan)
32 -> Writer BadBuildPlan ()
33checkDeps allPackages (user, pb) =
34 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
35 where
36 go (dep, diRange -> range) =
37 case lookup dep allPackages of
38 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
39 Just version
40 | version `withinRange` range -> return ()
41 | otherwise -> tell $ BadBuildPlan $ singletonMap
42 (dep, Just version)
43 errMap
44 where
45 errMap = singletonMap pu range
46 pu = PkgUser
47 { puName = user
48 , puVersion = ppVersion pb
49 , puMaintainer = pcMaintainer $ ppConstraints pb
50 , puGithubPings = ppGithubPings pb
51 }
53data PkgUser = PkgUser
54 { puName :: PackageName
55 , puVersion :: Version
56 , puMaintainer :: Maybe Maintainer
57 , puGithubPings :: Set Text
58 }
59 deriving (Eq, Ord)
61pkgUserShow1 :: PkgUser -> Text
62pkgUserShow1 PkgUser {..} = concat
63 [ display puName
64 , "-"
65 , display puVersion
66 ]
68pkgUserShow2 :: PkgUser -> Text
69pkgUserShow2 PkgUser {..} = unwords
70 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
71 : map (cons '@') (setToList puGithubPings)
73newtype BadBuildPlan =
74 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
75 deriving Typeable
76instance Exception BadBuildPlan
77instance Show BadBuildPlan where
78 show (BadBuildPlan errs) =
79 unpack $ concatMap go $ mapToList errs
80 where
81 go ((dep, mdepVer), users) = unlines
82 $ showDepVer dep mdepVer
83 : map showUser (mapToList users)
85 showDepVer :: PackageName -> Maybe Version -> Text
86 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
87 showDepVer dep (Just version) = concat
88 [ display dep
89 , "-"
90 , display version
91 , " depended on by:"
92 ]
94 showUser :: (PkgUser, VersionRange) -> Text
95 showUser (pu, range) = concat
96 [ "- "
97 , pkgUserShow1 pu
98 , " ("
99 , display range
100 , "). "
101 , pkgUserShow2 pu
102 ]
104instance Monoid BadBuildPlan where
105 mempty = BadBuildPlan mempty
106 mappend (BadBuildPlan x) (BadBuildPlan y) =
107 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y