git.iko.soy/stackage
on baf1925 help sign in
stackage/Stackage/CheckBuildPlan.hs
111 lines 3.7 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 Stackage.CheckBuildPlan
9 ( checkBuildPlan
10 ) where
12import Control.Monad.Writer.Strict (Writer, execWriter, tell)
13import qualified Data.Text as T
14import Stackage.BuildConstraints
15import Stackage.BuildPlan
16import Stackage.PackageDescription
17import Stackage.Prelude
19-- FIXME check cycles in dependencies, only looking at libraries and
20-- executables
22checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
23checkBuildPlan BuildPlan {..}
24 | null errs' = return ()
25 | otherwise = throwM errs
26 where
27 allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
28 errs@(BadBuildPlan errs') =
29 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
31checkDeps :: Map PackageName Version
32 -> (PackageName, PackagePlan)
33 -> Writer BadBuildPlan ()
34checkDeps allPackages (user, pb) =
35 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
36 where
37 go (dep, diRange -> range) =
38 case lookup dep allPackages of
39 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
40 Just version
41 | version `withinRange` range -> return ()
42 | otherwise -> tell $ BadBuildPlan $ singletonMap
43 (dep, Just version)
44 errMap
45 where
46 errMap = singletonMap pu range
47 pu = PkgUser
48 { puName = user
49 , puVersion = ppVersion pb
50 , puMaintainer = pcMaintainer $ ppConstraints pb
51 , puGithubPings = ppGithubPings pb
52 }
54data PkgUser = PkgUser
55 { puName :: PackageName
56 , puVersion :: Version
57 , puMaintainer :: Maybe Maintainer
58 , puGithubPings :: Set Text
59 }
60 deriving (Eq, Ord)
62pkgUserShow1 :: PkgUser -> Text
63pkgUserShow1 PkgUser {..} = concat
64 [ display puName
65 , "-"
66 , display puVersion
67 ]
69pkgUserShow2 :: PkgUser -> Text
70pkgUserShow2 PkgUser {..} = unwords
71 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
72 : map (cons '@') (setToList puGithubPings)
74newtype BadBuildPlan =
75 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
76 deriving Typeable
77instance Exception BadBuildPlan
78instance Show BadBuildPlan where
79 show (BadBuildPlan errs) =
80 unpack $ concatMap go $ mapToList errs
81 where
82 go ((dep, mdepVer), users) = unlines
83 $ ""
84 : showDepVer dep mdepVer
85 : map showUser (mapToList users)
87 showDepVer :: PackageName -> Maybe Version -> Text
88 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
89 showDepVer dep (Just version) = concat
90 [ display dep
91 , "-"
92 , display version
93 , " depended on by:"
94 ]
96 showUser :: (PkgUser, VersionRange) -> Text
97 showUser (pu, range) = concat
98 [ "- "
99 , pkgUserShow1 pu
100 , " ("
101 -- add a space after < to avoid confusing Markdown processors (like
102 -- Github's issue tracker)
103 , T.replace "<" "< " $ display range
104 , "). "
105 , pkgUserShow2 pu
106 ]
108instance Monoid BadBuildPlan where
109 mempty = BadBuildPlan mempty
110 mappend (BadBuildPlan x) (BadBuildPlan y) =
111 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y