git.iko.soy/stackage
on ee9bc2b help sign in
stackage/Stackage/CheckBuildPlan.hs
116 lines 4.0 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
22-- | Check the build plan for missing deps, wrong versions, etc.
23checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
24checkBuildPlan BuildPlan {..}
25 | null errs' = return ()
26 | otherwise = throwM errs
27 where
28 allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
29 errs@(BadBuildPlan errs') =
30 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
32-- | For a given package name and plan, check that its dependencies are:
33--
34-- 1. Existent (existing in the provided package map)
35-- 2. Within version range
36checkDeps :: Map PackageName Version
37 -> (PackageName, PackagePlan)
38 -> Writer BadBuildPlan ()
39checkDeps allPackages (user, pb) =
40 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
41 where
42 go (dep, diRange -> range) =
43 case lookup dep allPackages of
44 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
45 Just version
46 | version `withinRange` range -> return ()
47 | otherwise -> tell $ BadBuildPlan $ singletonMap
48 (dep, Just version)
49 errMap
50 where
51 errMap = singletonMap pu range
52 pu = PkgUser
53 { puName = user
54 , puVersion = ppVersion pb
55 , puMaintainer = pcMaintainer $ ppConstraints pb
56 , puGithubPings = ppGithubPings pb
57 }
59data PkgUser = PkgUser
60 { puName :: PackageName
61 , puVersion :: Version
62 , puMaintainer :: Maybe Maintainer
63 , puGithubPings :: Set Text
64 }
65 deriving (Eq, Ord)
67pkgUserShow1 :: PkgUser -> Text
68pkgUserShow1 PkgUser {..} = concat
69 [ display puName
70 , "-"
71 , display puVersion
72 ]
74pkgUserShow2 :: PkgUser -> Text
75pkgUserShow2 PkgUser {..} = unwords
76 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
77 : map (cons '@') (setToList puGithubPings)
79newtype BadBuildPlan =
80 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
81 deriving Typeable
82instance Exception BadBuildPlan
83instance Show BadBuildPlan where
84 show (BadBuildPlan errs) =
85 unpack $ concatMap go $ mapToList errs
86 where
87 go ((dep, mdepVer), users) = unlines
88 $ ""
89 : showDepVer dep mdepVer
90 : map showUser (mapToList users)
92 showDepVer :: PackageName -> Maybe Version -> Text
93 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
94 showDepVer dep (Just version) = concat
95 [ display dep
96 , "-"
97 , display version
98 , " depended on by:"
99 ]
101 showUser :: (PkgUser, VersionRange) -> Text
102 showUser (pu, range) = concat
103 [ "- "
104 , pkgUserShow1 pu
105 , " ("
106 -- add a space after < to avoid confusing Markdown processors (like
107 -- Github's issue tracker)
108 , T.replace "<" "< " $ display range
109 , "). "
110 , pkgUserShow2 pu
111 ]
113instance Monoid BadBuildPlan where
114 mempty = BadBuildPlan mempty
115 mappend (BadBuildPlan x) (BadBuildPlan y) =
116 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y